Index: trunk/configure.ac.in
===================================================================
--- trunk/configure.ac.in (revision 8899)
+++ trunk/configure.ac.in (revision 8900)
@@ -1,1241 +1,1242 @@
dnl configure.ac -- Main configuration script for WHIZARD
dnl
dnl Process this file with autoconf to produce a configure script.
dnl ************************************************************************
dnl configure.ac -- Main configuration script for WHIZARD
dnl configure.ac -- WHIZARD configuration
dnl
dnl Copyright (C) 1999-2023 by
dnl Wolfgang Kilian <kilian@physik.uni-siegen.de>
dnl Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
dnl Juergen Reuter <juergen.reuter@desy.de>
dnl with contributions from
dnl cf. main AUTHORS file
dnl
dnl WHIZARD is free software; you can redistribute it and/or modify it
dnl under the terms of the GNU General Public License as published by
dnl the Free Software Foundation; either version 2, or (at your option)
dnl any later version.
dnl
dnl WHIZARD is distributed in the hope that it will be useful, but
dnl WITHOUT ANY WARRANTY; without even the implied warranty of
dnl MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
dnl GNU General Public License for more details.
dnl
dnl You should have received a copy of the GNU General Public License
dnl along with this program; if not, write to the Free Software
dnl Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
dnl
dnl ***********************************************************************
dnl Environment variables that can be set by the user:
dnl FC Fortran compiler
dnl FCFLAGS Fortran compiler flags
dnl ***********************************************************************
dnl
dnl Start configuration
AC_INIT([XXXWHIZARDXXX],[3.1.2.1])
AC_CONFIG_MACRO_DIR([m4])
AM_INIT_AUTOMAKE([1.12.2 color-tests parallel-tests])
AC_PREREQ([2.65])
AM_MAKE_INCLUDE
dnl Make make less verbose to improve signal/noise
AM_SILENT_RULES([yes])
########################################################################
### Package-specific initialization
AC_MSG_NOTICE([**************************************************************])
WO_CONFIGURE_SECTION([Start of package configuration])
### Further version information
PACKAGE_DATE="Mar 21 2023"
PACKAGE_STATUS="alpha"
AC_SUBST(PACKAGE_DATE)
AC_SUBST(PACKAGE_STATUS)
AC_MSG_NOTICE([**************************************************************])
AC_MSG_NOTICE([Package name: AC_PACKAGE_NAME()])
AC_MSG_NOTICE([Version: AC_PACKAGE_VERSION()])
AC_MSG_NOTICE([Date: $PACKAGE_DATE])
AC_MSG_NOTICE([Status: $PACKAGE_STATUS])
AC_MSG_NOTICE([**************************************************************])
########################################################################
###---------------------------------------------------------------------
### shared library versioning (not the same as the package version!)
LIBRARY_VERSION="-version-info 2:2:0"
AC_SUBST([LIBRARY_VERSION])
########################################################################
###---------------------------------------------------------------------
### Define the main package variables
### Source directory, for testing purposes
SRCDIR=`cd $srcdir && pwd`
AC_SUBST([SRCDIR])
### Build directory, for testing purposes
BUILDDIR=`pwd`
AC_SUBST([BUILDDIR])
### Location of installed libraries and such
eval BINDIR=$bindir
case $BINDIR in
NONE*) eval BINDIR=$prefix/bin ;;
esac
case $BINDIR in
NONE*) BINDIR="\${prefix}/bin" ;;
esac
AC_SUBST([BINDIR])
eval INCLUDEDIR=$includedir
case $INCLUDEDIR in
NONE*) eval INCLUDEDIR=$prefix/include ;;
esac
case $INCLUDEDIR in
NONE*) INCLUDEDIR="\${prefix}/include" ;;
esac
AC_SUBST([INCLUDEDIR])
eval LIBDIR=$libdir
case $LIBDIR in
NONE*) eval LIBDIR=$prefix/lib ;;
esac
case $LIBDIR in
NONE*) eval LIBDIR=$ac_default_prefix/lib ;;
esac
AC_SUBST([LIBDIR])
### Location of installed libraries and such
eval PKGLIBDIR=$libdir/$PACKAGE
case $PKGLIBDIR in
NONE*) eval PKGLIBDIR=$prefix/lib/$PACKAGE ;;
esac
case $PKGLIBDIR in
NONE*) PKGLIBDIR="\${prefix}/lib/$PACKAGE" ;;
esac
AC_SUBST([PKGLIBDIR])
### Location of installed system-independent data
eval PKGDATADIR=$datarootdir/$PACKAGE
case $PKGDATADIR in
NONE*) eval PKGDATADIR=$prefix/share/$PACKAGE ;;
esac
case $PKGDATADIR in
NONE*) PKGDATADIR="\${prefix}/share/$PACKAGE" ;;
esac
AC_SUBST([PKGDATADIR])
### Location of installed TeX files and such
eval PKGTEXDIR=$datarootdir/texmf/$PACKAGE
case $PKGTEXDIR in
NONE*) eval PKGTEXDIR=$prefix/share/texmf/$PACKAGE ;;
esac
case $PKGTEXDIR in
NONE*) PKGTEXDIR="\${prefix}/share/texmf/$PACKAGE" ;;
esac
AC_SUBST([PKGTEXDIR])
### Parent location of installed .mod files
### To be used in Fortran source
FMODDIR=$prefix/lib/mod
case $FMODDIR in
NONE*) FMODDIR="\${prefix}/lib/mod" ;;
esac
AC_SUBST([FMODDIR])
### To be used in Makefile.am
### Don't use ${libdir} since lib may be changed to lib64 by configure
fmoddir="\${prefix}/lib/mod"
AC_SUBST([fmoddir])
########################################################################
###---------------------------------------------------------------------
### Required programs and checks
### GNU Tools
WO_CONFIGURE_SECTION([Generic tools])
### Initialize LIBTOOL
LT_INIT(dlopen)
LT_PREREQ([2.4.1b])
AX_CHECK_GNU_MAKE()
AC_PROG_GREP()
AC_MSG_CHECKING([for the suffix of shared libraries])
case $host in
*-darwin* | rhapsody*)
SHRLIB_EXT="dylib"
;;
cygwin* | mingw* | pw32* | cegcc* | os2*)
SHRLIB_EXT="dll"
;;
hpux9* | hpux10* | hpux11*)
SHRLIB_EXT="sl"
;;
*)
SHRLIB_EXT="so"
;;
esac
if test "x$SHRLIB_EXT" != "x"; then
SHRLIB_EXT=$SHRLIB_EXT
else
SHRLIB_EXT="so"
fi
AC_MSG_RESULT([.$SHRLIB_EXT])
AC_SUBST(SHRLIB_EXT)
### Export whether the C compiler is GNU
AC_MSG_CHECKING([whether the C compiler is the GNU compiler])
if test "x$ac_cv_c_compiler_gnu" = "xyes"; then
CC_IS_GNU=".true."
else
CC_IS_GNU=".false."
fi
AC_MSG_RESULT([$ac_cv_c_compiler_gnu])
AC_SUBST([CC_IS_GNU])
AC_CHECK_HEADERS([quadmath.h])
if test "x$ac_cv_header_quadmath_h" = "xyes"; then
CC_HAS_QUADMATH=".true."
else
CC_HAS_QUADMATH=".false."
fi
AC_SUBST([CC_HAS_QUADMATH])
########################################################################
###---------------------------------------------------------------------
### Host system MAC OS X check for XCode
case $host in
*-darwin*)
WO_HLINE()
AC_MSG_NOTICE([Host is $host, checking for XCode])
AC_PATH_PROG(XCODE_SELECT, xcode-select)
# locate currently selected Xcode path
if test "x$XCODE_SELECT" != "x"; then
AC_MSG_CHECKING(Xcode location)
DEVELOPER_DIR=`$XCODE_SELECT -print-path`
AC_MSG_RESULT([$DEVELOPER_DIR])
else
DEVELOPER_DIR=/Developer
fi
AC_SUBST(DEVELOPER_DIR)
XCODEPLIST=$DEVELOPER_DIR/Applications/Xcode.app/Contents/version.plist
if test -r "$XCODEPLIST"; then
AC_MSG_CHECKING(Xcode version)
if test "x$DEFAULTS" != "x"; then
XCODE_VERSION=`$DEFAULTS read $DEVELOPER_DIR/Applications/Xcode.app/Contents/version CFBundleShortVersionString`
else
XCODE_VERSION=`tr -d '\r\n' < $XCODEPLIST | sed -e 's/.*<key>CFBundleShortVersionString<\/key>.<string>\([[0-9.]]*\)<\/string>.*/\1/'`
fi
AC_MSG_RESULT([$XCODE_VERSION])
AC_SUBST(XCODE_VERSION)
fi
AC_MSG_NOTICE([checking for Security Integrity Protocol (SIP)])
AC_PATH_PROG(CSRUTIL, csrutil)
if test "x$CSRUTIL" != "x"; then
SIP_CHECK=`$CSRUTIL status | $SED "s/System Integrity Protection status: //"`
if test "$SIP_CHECK" = "enabled."; then
SIP_ACTIVE="yes"
else
SIP_ACTIVE="no"
fi
else
SIP_ACTIVE="no"
fi
AC_MSG_CHECKING([Checking whether MAC OS X SIP is activated])
AC_MSG_RESULT([$SIP_ACTIVE])
AC_SUBST([SIP_ACTIVE])
WO_HLINE()
;;
*)
;;
esac
########################################################################
###---------------------------------------------------------------------
### Enable the distribution tools
### (default: disabled, to speed up compilation)
AC_ARG_ENABLE([distribution],
[AS_HELP_STRING([--enable-distribution],
[build the distribution incl. all docu (developers only) [[no]]])])
AC_CACHE_CHECK([whether we want to build the distribution],
[wo_cv_distribution],
[dnl
if test "$enable_distribution" = "yes"; then
wo_cv_distribution=yes
else
wo_cv_distribution=no
fi])
AM_CONDITIONAL([DISTRIBUTION],
[test "$enable_distribution" = "yes"])
### ONLY_FULL {{{
########################################################################
###---------------------------------------------------------------------
if test "$enable_shared" = no; then
AC_MSG_ERROR([you've used --disable-shared which will not produce a working Whizard.])
fi
### ONLY_FULL }}}
########################################################################
###---------------------------------------------------------------------
### We include the m4 macro tool here
AC_PATH_PROG(M4,m4,false)
if test "$M4" = false; then
AM_CONDITIONAL([M4_AVAILABLE],[false])
else
AM_CONDITIONAL([M4_AVAILABLE],[true])
fi
########################################################################
###---------------------------------------------------------------------
### Dynamic runtime linking
WO_CONFIGURE_SECTION([Dynamic runtime linking])
### Look for libdl (should provide 'dlopen' and friends)
AC_PROG_CC()
WO_PROG_DL()
### Define the conditional for static builds
if test "$enable_static" = yes; then
AM_CONDITIONAL([STATIC_AVAILABLE],[true])
else
AM_CONDITIONAL([STATIC_AVAILABLE],[false])
fi
########################################################################
###---------------------------------------------------------------------
### Noweb
WO_CONFIGURE_SECTION([Checks for 'noweb' system])
### Enable/disable noweb and determine locations of notangle, cpif, noweave
WO_PROG_NOWEB()
########################################################################
###---------------------------------------------------------------------
### LaTeX
WO_CONFIGURE_SECTION([Checks for 'LaTeX' system])
### Determine whether LaTeX is present
AC_PROG_LATEX()
AC_PROG_DVIPS()
AC_PROG_PDFLATEX()
AC_PROG_MAKEINDEX()
AC_PROG_PS2PDF()
AC_PROG_EPSPDF()
AC_PROG_EPSTOPDF()
if test "$EPSPDF" = "no" -a "$EPSTOPDF" = "no"; then
AC_MSG_NOTICE([*********************************************************])
AC_MSG_NOTICE([WARNING: eps(to)pdf n/a; O'Mega documentation will crash!])
AC_MSG_NOTICE([WARNING: this applies only to the svn developer version!])
AC_MSG_NOTICE([*********************************************************])
fi
AC_PROG_CONTEXT()
AC_PROG_GZIP()
AC_PATH_PROG(ACROREAD,acroread,false)
AC_PATH_PROG(GHOSTVIEW,gv ghostview,false)
AC_PROG_DOT()
### Determine whether Metapost is present and whether event display is possible
AC_PROG_MPOST()
WO_CHECK_EVENT_ANALYSIS_METHODS()
### We put here the check for HEVEA components as well
WO_PROG_HEVEA()
########################################################################
###---------------------------------------------------------------------
### Fortran compiler
WO_CONFIGURE_SECTION([Fortran compiler checks])
### Determine default compiler to use
user_FCFLAGS="${FCFLAGS}"
AC_PROG_FC()
### Choose FC standard for PYTHIA6 F77 files
AC_PROG_F77([$FC])
### Determine compiler vendor and version
WO_FC_GET_VENDOR_AND_VERSION()
### Veto against old gfortran < 9.x versions
WO_FC_VETO_GFORTRAN_LT_9()
### Veto against old ifort < 21.x versions
WO_FC_VETO_IFORT_LT_21()
### Veto against ifort 21.0/1/2
WO_FC_VETO_IFORT_21012()
### Require extension '.f90' for all compiler checks
AC_FC_SRCEXT([f90])
### Determine flags and extensions
WO_FC_PARAMETERS()
### Determine flags for linking the Fortran runtime library
WO_FC_LIBRARY_LDFLAGS()
### Check for Fortran 95 features
WO_FC_CHECK_F95()
### Check for allocatable subobjects (TR15581)
WO_FC_CHECK_TR15581()
### Check for allocatable scalars
WO_FC_CHECK_ALLOCATABLE_SCALARS()
### Check for ISO C binding support
WO_FC_CHECK_C_BINDING()
### Check for procedures pointers and abstract interfaces
WO_FC_CHECK_PROCEDURE_POINTERS()
### Check for type extension and further OO features
WO_FC_CHECK_OO_FEATURES()
### Check for submodules (not yet used)
WO_FC_CHECK_TR19767()
### Check for F2003 command-line interface
WO_FC_CHECK_CMDLINE()
### Check for F2003-style access to environment variables
WO_FC_CHECK_ENVVAR()
### Check for the flush statement
WO_FC_CHECK_FLUSH()
### Check for iso_fortran_env
WO_FC_CHECK_ISO_FORTRAN_ENV()
WO_FC_CHECK_ISO_FORTRAN_ENV_2008()
### Turn on/off master switch for debugging features
WO_FC_SET_DEBUG()
### OpenMP threading activated upon request
AC_OPENMP()
WO_FC_SET_OPENMP()
### Profiling compilation enforced upon request
WO_FC_SET_PROFILING()
### Impure subroutines enforced upon request
WO_FC_SET_OMEGA_IMPURE()
### Find the extension of Fortran module files
WO_FC_MODULE_FILE([FC_MODULE_NAME], [FCMOD], [$FC], [f90])
###---------------------------------------------------------------------
### Check for the requested precision
WO_FC_CONFIGURE_KINDS([src/basics/kinds.f90])
### ONLY_FULL {{{
AC_PROG_INSTALL()
${INSTALL} -d circe1/src
cp -a src/basics/kinds.f90 circe1/src
${INSTALL} -d circe2/src
cp -a src/basics/kinds.f90 circe2/src
${INSTALL} -d omega/src
cp -a src/basics/kinds.f90 omega/src
${INSTALL} -d vamp/src
cp -a src/basics/kinds.f90 vamp/src
### ONLY_FULL }}}
### ONLY_VAMP_AND_FULL {{{
########################################################################
# VAMP Fortran options for the configure script
########################################################################
WO_FC_SET_MPI()
### ONLY_VAMP_AND_FULL }}}
########################################################################
###---------------------------------------------------------------------
### OCaml
WO_CONFIGURE_SECTION([Objective Caml checks])
### Check for ocamlc and its relatives
AC_PROG_OCAML()
if test "$enable_ocaml" != "no"; then
AC_OCAML_VERSION_CHECK(408000)
AC_PROG_OCAMLLEX()
AC_PROG_OCAMLYACC()
AC_PROG_OCAMLCP()
### Ocamlweb is required to be newer than v0.9
AC_PROG_OCAMLWEB(009000)
AC_PROG_OCAML_LABLGTK()
AC_PATH_PROGS([OCAMLDOT],[ocamldot],[no])
AM_CONDITIONAL([OCAMLDOT_AVAILABLE],[test "$OCAMLDOT" != "no"])
AC_PATH_PROGS([OCAMLDEP],[ocamldep],[no])
AM_CONDITIONAL([OCAMLDEP_AVAILABLE],[test "$OCAMLDEP" != "no"])
AC_PATH_PROGS([OCAMLDEFUN],[ocamldefun],[no])
else
AC_MSG_NOTICE([WARNING: OCaml and O'Mega matrix elements disabled by request!])
AM_CONDITIONAL([OCAMLWEB_AVAILABLE],[false])
AM_CONDITIONAL([OCAMLDOT_AVAILABLE],[false])
AM_CONDITIONAL([OCAMLDEP_AVAILABLE],[false])
fi
########################################################################
###---------------------------------------------------------------------
### C++
WO_CONFIGURE_SECTION([C++ compiler checks])
AC_PROG_CXX()
AC_CXX_LIBRARY_LDFLAGS()
########################################################################
###---------------------------------------------------------------------
### Checks for external interfaces
WO_CONFIGURE_SECTION([Checking for PYTHON / PYTHON API])
AX_PYTHON_DEVEL([>= '3.5'])
WO_PROG_PYTHON_API()
### ONLY_OMEGA_AND_FULL {{{
########################################################################
# O'Mega options for the configure script
########################################################################
########################################################################
###---------------------------------------------------------------------
### O'Mega UFO file paths
WO_CONFIGURE_SECTION([O'Mega UFO file paths])
AC_ARG_ENABLE([default-UFO-dir],
[ --enable-default-UFO-dir=directory
Read precomputed model tables from this directory,
which will be populated by an administrator at
install time [[default=$datadir/UFO, enabled]].],
[case "$enableval" in
no) OMEGA_DEFAULT_UFO_DIR="."
;;
*) OMEGA_DEFAULT_UFO_DIR="$enableval"
;;
esac],
[### use eval b/c $datadir defaults to unexpanded ${datarootdir}
case "$OMEGA_DEFAULT_UFO_DIR" in
"") OMEGA_DEFAULT_UFO_DIR="${prefix}/omega/share/UFO"
;;
*) eval OMEGA_DEFAULT_UFO_DIR="$datadir/UFO"
;;
esac])
AC_SUBST([OMEGA_DEFAULT_UFO_DIR])
case "$OMEGA_DEFAULT_UFO_DIR" in
.|""|NONE*) OMEGA_DEFAULT_UFO_DIR="."
;;
*) AC_MSG_NOTICE([Creating default UFO directory $OMEGA_DEFAULT_UFO_DIR])
$MKDIR_P "$OMEGA_DEFAULT_UFO_DIR" 2>/dev/null
chmod u+w "$OMEGA_DEFAULT_UFO_DIR" 2>/dev/null
;;
esac
###---------------------------------------------------------------------
### Recola
WO_CONFIGURE_SECTION([RECOLA])
WO_PROG_RECOLA()
### ONLY_OMEGA_AND_FULL }}}
### ONLY_FULL {{{
########################################################################
###---------------------------------------------------------------------
### Libraries
###---------------------------------------------------------------------
### LHAPDF
WO_CONFIGURE_SECTION([LHAPDF])
WO_PROG_LHAPDF()
###---------------------------------------------------------------------
### ROOT
WO_CONFIGURE_SECTION([ROOT])
WO_ROOT_PATH(,[
AC_DEFINE([HAVE_ROOT],,[Root library])
AC_CHECK_LIB([dl],[dlopen],[],AC_MSG_WARN([Root libraries not linking properly]))
],AC_MSG_RESULT([The ROOT support of HepMC might not be working properly]))
###---------------------------------------------------------------------
### HepMC
WO_CONFIGURE_SECTION([HepMC])
WO_PROG_HEPMC()
###---------------------------------------------------------------------
### STDHEP
WO_CONFIGURE_SECTION([STDHEP])
WO_PROG_TIRPC()
AC_MSG_NOTICE([StdHEP v5.06.01 is included internally])
###---------------------------------------------------------------------
### LCIO
WO_CONFIGURE_SECTION([LCIO])
WO_PROG_LCIO()
###---------------------------------------------------------------------
### HDF5 (for events, grids etc.)
WO_CONFIGURE_SECTION([HDF5])
WO_PROG_HDF5(1.8.0,no)
###---------------------------------------------------------------------
### PYTHIA6, PYTHIA8 etc
WO_CONFIGURE_SECTION([SHOWERS PYTHIA6 PYTHIA8 MPI])
WO_PROG_QCD()
WO_PROG_PYTHIA8()
###---------------------------------------------------------------------
### HOPPET
WO_CONFIGURE_SECTION([HOPPET])
WO_PROG_HOPPET()
###---------------------------------------------------------------------
### FASTJET
WO_CONFIGURE_SECTION([FASTJET])
WO_PROG_FASTJET()
###---------------------------------------------------------------------
### GoSam
WO_CONFIGURE_SECTION([GOSAM])
WO_PROG_GOSAM()
###---------------------------------------------------------------------
### OpenLoops
WO_CONFIGURE_SECTION([OPENLOOPS])
WO_PROG_OPENLOOPS()
###---------------------------------------------------------------------
### LoopTools
WO_CONFIGURE_SECTION([LOOPTOOLS])
WO_PROG_LOOPTOOLS()
### ONLY_FULL }}}
########################################################################
###---------------------------------------------------------------------
### Extra flags for helping the linker finding libraries
WO_CONFIGURE_SECTION([Handle linking with C++ libraries])
WO_PROG_STDCPP()
### ONLY_FULL {{{
########################################################################
###---------------------------------------------------------------------
### Miscellaneous
WO_CONFIGURE_SECTION([Numerical checks])
### Disable irrelevant optimization for parameter files
### (default: disabled, to speed up compilation)
AC_ARG_ENABLE([optimization-for-parameter-files],
[AS_HELP_STRING([--enable-optimization-for-parameter-files],
[enable (useless) optimization for parameter files [[no]]])])
AC_CACHE_CHECK([whether we want optimization for parameter files],
[wo_cv_optimization_for_parfiles],
[dnl
if test "$enable_optimization_for_parameter_files" = "yes"; then
wo_cv_optimization_for_parfiles=yes
else
wo_cv_optimization_for_parfiles=no
fi])
AM_CONDITIONAL([OPTIMIZATION_FOR_PARFILES],
[test "$enable_optimization_for_parameter_files" = "yes"])
### ONLY_FULL }}}
########################################################################
###---------------------------------------------------------------------
### Wrapup
WO_CONFIGURE_SECTION([Finalize configuration])
### Main directory
AC_CONFIG_FILES([Makefile])
### ONLY_FULL {{{
###---------------------------------------------------------------------
### Subdirectory src
AC_CONFIG_FILES([src/Makefile])
###---------------------------------------------------------------------
### Subdirectory python: WHIZARD's PYTHON/CYTHON interface
AC_CONFIG_FILES([python/Makefile])
AC_CONFIG_FILES([python/setup.py], [chmod u+x python/setup.py])
AC_CONFIG_LINKS([python/whizard_python.pyx:python/whizard_python.pyx])
AC_CONFIG_LINKS([python/cwhizard.pxd:python/cwhizard.pxd])
###---------------------------------------------------------------------
### Subdirectory src/hepmc
AC_CONFIG_FILES([src/hepmc/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/lcio
AC_CONFIG_FILES([src/lcio/Makefile])
###---------------------------------------------------------------------
### Subdirectory contrib: external code shipped with WHIZARD
AC_CONFIG_FILES([contrib/Makefile])
###---------------------------------------------------------------------
### Subdirectory pythia6: WHIZARD's internal PYTHIA6 version
AC_CONFIG_FILES([contrib/pythia6/Makefile])
###---------------------------------------------------------------------
### Subdirectory tauola: WHIZARD's internal TAUOLA version
AC_CONFIG_FILES([contrib/tauola/Makefile])
###---------------------------------------------------------------------
### Subdirectory stdhep: WHIZARD's internal StdHep version
AC_CONFIG_FILES([contrib/mcfio/Makefile])
AC_CONFIG_FILES([contrib/stdhep/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/muli: multiple interactions
AC_CONFIG_FILES([src/muli/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/lhapdf5: dummy library as LHAPDF5 replacement
AC_CONFIG_FILES([src/lhapdf5/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/lhapdf: LHAPDF v6
AC_CONFIG_FILES([src/lhapdf/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/pdf_builtin: Electron PDFs
AC_CONFIG_FILES([src/qed_pdf/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/pdf_builtin: Builtin PDFs
AC_CONFIG_FILES([src/pdf_builtin/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/tauola
AC_CONFIG_FILES([src/tauola/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/xdr: XDR reader
AC_CONFIG_FILES([src/xdr/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/hoppet
AC_CONFIG_FILES([src/hoppet/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/fastjet
AC_CONFIG_FILES([src/fastjet/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/looptools
AC_CONFIG_FILES([src/looptools/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/shower: shower and all that
AC_CONFIG_FILES([src/pythia8/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/shower: shower and all that
AC_CONFIG_FILES([src/shower/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/noweb-frame: frame for whizard Noweb sources
AC_CONFIG_FILES([src/noweb-frame/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/basics: numeric kinds, strings
AC_CONFIG_FILES([src/basics/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/utilities: simple utilities
AC_CONFIG_FILES([src/utilities/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/testing: unit-test support
AC_CONFIG_FILES([src/testing/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/system: modules related to local setup and OS issues
AC_CONFIG_FILES([src/system/Makefile])
AC_CONFIG_FILES([src/system/system_dependencies.f90], [
# Be cautious: Special handling of brackets due to M4!
# 1. Configure lines containing @VARIABLE@ must be indented by exactly 7 spaces
# to be split (^[[[:space:]]]\{7\}), the first non-space character has to
# be an double-quote (\"). and the line has to have at least 110 characters where the
# 111th must not be a double quote, a whitespace, a slash or an ampersand ([^\" \/&]).
# 2. Appeand each 110-wide character block (\(.\{110\}[[^\"]]\), refer to a block as \1)
# (without a trailing double-quote) with an ampersand, a literal newline character,
# seven white-spaces and another ampersand. Repeat with remaining pattern space (be greedy).
# Note: The greedy options also allows us to parse the line beginning from each character
# again with the search pattern.
$SED "/^[[[:space:]]]\{7\}\".\{110,\}[[^\"]]/ s/\(.\{110\}[[^\" \/&]]\)/\1\&\\n \&/g" \
< src/system/system_dependencies.f90 \
> src/system/system_dependencies.tmp
mv -f src/system/system_dependencies.tmp src/system/system_dependencies.f90
])
AC_CONFIG_FILES([src/system/debug_master.f90])
###---------------------------------------------------------------------
### Subdirectory src/combinatorics: standard algorithms
AC_CONFIG_FILES([src/combinatorics/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/parsing: text-handling and parsing
AC_CONFIG_FILES([src/parsing/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/rng: random-number generation
AC_CONFIG_FILES([src/rng/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/expr_base: abstract expressions
AC_CONFIG_FILES([src/expr_base/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/physics: particle-physics related functions
AC_CONFIG_FILES([src/physics/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/qft: quantum (field) theory concepts as data types
AC_CONFIG_FILES([src/qft/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/types: HEP and other types for common use
AC_CONFIG_FILES([src/types/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/matrix_elements: process code and libraries
AC_CONFIG_FILES([src/matrix_elements/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/me_methods: specific process code and interface
AC_CONFIG_FILES([src/me_methods/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/particles: particle objects
AC_CONFIG_FILES([src/particles/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/beams: beams and beam structure
AC_CONFIG_FILES([src/beams/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/events: generic events and event I/O
AC_CONFIG_FILES([src/events/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/vegas: VEGAS Monte Carlo adaptive integration
AC_CONFIG_FILES([src/vegas/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/mci: multi-channel integration and event generation
AC_CONFIG_FILES([src/mci/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/phase_space: parameterization and evaluation
AC_CONFIG_FILES([src/phase_space/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/blha: BLHA support (NLO data record)
AC_CONFIG_FILES([src/blha/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/gosam: GoSAM support (NLO amplitudes)
AC_CONFIG_FILES([src/gosam/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/openloops: OpenLoops support (NLO amplitudes)
AC_CONFIG_FILES([src/openloops/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/recola: Recola support (NLO amplitudes)
AC_CONFIG_FILES([src/recola/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/fks: FKS subtraction algorithm
AC_CONFIG_FILES([src/fks/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/matching: matching algorithms
AC_CONFIG_FILES([src/matching/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/variables: Implementation of variable lists
AC_CONFIG_FILES([src/variables/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/model_features: Model access and methods
AC_CONFIG_FILES([src/model_features/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/models: Model-specific code
AC_CONFIG_FILES([src/models/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/threshold
AC_CONFIG_FILES([src/threshold/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/models/threeshl_bundle
AC_CONFIG_FILES([src/models/threeshl_bundle/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/process_integration
AC_CONFIG_FILES([src/process_integration/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/transforms: event transforms and event API
AC_CONFIG_FILES([src/transforms/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/whizard-core
AC_CONFIG_FILES([src/whizard-core/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/api
AC_CONFIG_FILES([src/api/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/main
AC_CONFIG_FILES([src/main/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/prebuilt
AC_CONFIG_FILES([src/prebuilt/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/feynmf
AC_CONFIG_FILES([src/feynmf/Makefile])
###---------------------------------------------------------------------
### Subdirectory src/gamelan: WHIZARD graphics package
AC_CONFIG_FILES([src/gamelan/Makefile])
AC_CONFIG_FILES([src/gamelan/whizard-gml], [chmod u+x src/gamelan/whizard-gml])
###---------------------------------------------------------------------
### Subdirectory share
AC_CONFIG_FILES([share/Makefile])
###---------------------------------------------------------------------
### Subdirectory share/doc
AC_CONFIG_FILES([share/doc/Makefile])
###---------------------------------------------------------------------
### Subdirectory share/models
AC_CONFIG_FILES([share/models/Makefile])
###---------------------------------------------------------------------
### Subdirectory share/cuts
AC_CONFIG_FILES([share/cuts/Makefile])
###---------------------------------------------------------------------
### Subdirectory share/beam-sim
AC_CONFIG_FILES([share/beam-sim/Makefile])
###---------------------------------------------------------------------
### Subdirectory share/susy
AC_CONFIG_FILES([share/susy/Makefile])
###---------------------------------------------------------------------
### Subdirectory share/examples
AC_CONFIG_FILES([share/examples/Makefile])
###---------------------------------------------------------------------
### Subdirectory share/tests
AC_CONFIG_FILES([share/tests/Makefile])
###---------------------------------------------------------------------
### Subdirectory share/muli
AC_CONFIG_FILES([share/muli/Makefile])
###---------------------------------------------------------------------
### Subdirectory share/SM_tt_threshold_data
AC_CONFIG_FILES([share/SM_tt_threshold_data/Makefile])
###---------------------------------------------------------------------
### Subdirectory share/gui
AC_CONFIG_FILES([share/gui/Makefile])
###---------------------------------------------------------------------
### Subdirectory tests
AC_CONFIG_FILES([tests/Makefile])
AC_CONFIG_FILES([tests/models/Makefile])
AC_CONFIG_FILES([tests/models/UFO/Makefile])
AC_CONFIG_FILES([tests/models/UFO/SM/Makefile])
AC_CONFIG_FILES([tests/models/UFO/MSSM/Makefile])
##_CONFIG_FILES([tests/models/UFO/SMEFTsim_top_alphaScheme/Makefile])
AC_CONFIG_FILES([tests/unit_tests/Makefile])
AC_CONFIG_FILES([tests/functional_tests/Makefile])
AC_CONFIG_FILES([tests/ext_tests_mssm/Makefile])
AC_CONFIG_FILES([tests/ext_tests_nmssm/Makefile])
AC_CONFIG_FILES([tests/ext_tests_ilc/Makefile])
AC_CONFIG_FILES([tests/ext_tests_shower/Makefile])
AC_CONFIG_FILES([tests/ext_tests_nlo/Makefile])
AC_CONFIG_FILES([tests/ext_tests_nlo_add/Makefile])
AC_CONFIG_FILES([tests/unit_tests/run_whizard_ut.sh],
[chmod u+x tests/unit_tests/run_whizard_ut.sh])
AC_CONFIG_FILES([tests/unit_tests/run_whizard_ut_c.sh],
[chmod u+x tests/unit_tests/run_whizard_ut_c.sh])
AC_CONFIG_FILES([tests/unit_tests/run_whizard_ut_cc.sh],
[chmod u+x tests/unit_tests/run_whizard_ut_cc.sh])
AC_CONFIG_FILES([tests/functional_tests/run_whizard.sh],
[chmod u+x tests/functional_tests/run_whizard.sh])
AC_CONFIG_FILES([tests/ext_tests_mssm/run_whizard.sh],
[chmod u+x tests/ext_tests_mssm/run_whizard.sh])
AC_CONFIG_FILES([tests/ext_tests_nmssm/run_whizard.sh],
[chmod u+x tests/ext_tests_nmssm/run_whizard.sh])
AC_CONFIG_FILES([tests/ext_tests_ilc/run_whizard.sh],
[chmod u+x tests/ext_tests_ilc/run_whizard.sh])
AC_CONFIG_FILES([tests/ext_tests_shower/run_whizard.sh],
[chmod u+x tests/ext_tests_shower/run_whizard.sh])
AC_CONFIG_FILES([tests/ext_tests_nlo/run_whizard.sh],
[chmod u+x tests/ext_tests_nlo/run_whizard.sh])
AC_CONFIG_FILES([tests/ext_tests_nlo_add/run_whizard.sh],
[chmod u+x tests/ext_tests_nlo_add/run_whizard.sh])
###--------------------------------------------------------------------
### Subdirectory scripts
AC_CONFIG_FILES([scripts/Makefile])
AC_CONFIG_FILES([scripts/whizard-config], [chmod u+x scripts/whizard-config])
AC_CONFIG_FILES([scripts/whizard-setup.sh], [chmod u+x scripts/whizard-setup.sh])
AC_CONFIG_FILES([scripts/whizard-setup.csh], [chmod u+x scripts/whizard-setup.csh])
### ONLY_FULL }}}
### ONLY_CIRCE1_AND_FULL {{{
###--------------------------------------------------------------------
### CIRCE1 subdirectory files
AC_CONFIG_FILES([circe1/Makefile])
AC_CONFIG_FILES([circe1/src/Makefile])
AC_CONFIG_FILES([circe1/minuit/Makefile])
AC_CONFIG_FILES([circe1/tools/Makefile])
AC_CONFIG_FILES([circe1/share/Makefile])
AC_CONFIG_FILES([circe1/share/data/Makefile])
AC_CONFIG_FILES([circe1/share/doc/Makefile])
### ONLY_CIRCE1_AND_FULL }}}
### ONLY_CIRCE2_AND_FULL {{{
###--------------------------------------------------------------------
### CIRCE2 subdirectory files
AC_CONFIG_FILES([circe2/Makefile])
AC_CONFIG_FILES([circe2/src/Makefile])
AC_CONFIG_FILES([circe2/share/Makefile])
AC_CONFIG_FILES([circe2/share/doc/Makefile])
AC_CONFIG_FILES([circe2/share/examples/Makefile])
AC_CONFIG_FILES([circe2/share/data/Makefile])
AC_CONFIG_FILES([circe2/share/tests/Makefile])
AC_CONFIG_FILES([circe2/tests/Makefile])
AC_CONFIG_FILES([circe2/tests/test_wrapper.sh], [chmod u+x circe2/tests/test_wrapper.sh])
AC_CONFIG_FILES([circe2/tests/circe2_tool.sh], [chmod u+x circe2/tests/circe2_tool.sh])
AC_CONFIG_FILES([circe2/tests/generate.sh], [chmod u+x circe2/tests/generate.sh])
### ONLY_CIRCE2_AND_FULL }}}
### ONLY_OMEGA_AND_FULL {{{
###--------------------------------------------------------------------
### OMEGA subdirectory files
AC_CONFIG_FILES([omega/Makefile])
AC_CONFIG_FILES([omega/bin/Makefile])
AC_CONFIG_FILES([omega/lib/Makefile])
AC_CONFIG_FILES([omega/models/Makefile])
AC_CONFIG_FILES([omega/src/Makefile])
AC_CONFIG_FILES([omega/share/Makefile])
AC_CONFIG_FILES([omega/share/doc/Makefile])
AC_CONFIG_FILES([omega/extensions/Makefile])
AC_CONFIG_FILES([omega/extensions/people/Makefile])
AC_CONFIG_FILES([omega/extensions/people/jr/Makefile])
AC_CONFIG_FILES([omega/extensions/people/tho/Makefile])
AC_CONFIG_FILES([omega/tests/Makefile])
AC_CONFIG_FILES([omega/tests/UFO/Makefile])
AC_CONFIG_FILES([omega/tests/UFO/SM/Makefile])
AC_CONFIG_FILES([omega/tests/UFO/MSSM/Makefile])
+AC_CONFIG_FILES([omega/tests/UFO/Exotic_Color/Makefile])
AC_CONFIG_FILES([omega/tests/UFO/SMEFTsim_top_alphaScheme/Makefile])
AC_CONFIG_FILES([omega/tools/Makefile])
AC_CONFIG_FILES([omega/scripts/Makefile])
AC_CONFIG_FILES([omega/scripts/omega-config], [chmod u+x omega/scripts/omega-config])
AC_CONFIG_FILES([omega/scripts/ufo-sanitizer], [chmod u+x omega/scripts/ufo-sanitizer])
# Copy config.mli to the build directory (otherwise ocamlc and/or
# ocamlopt would create one on their own).
###--------------------------------------------------------------------
AC_CONFIG_FILES([omega/src/config.ml])
case "$srcdir" in
.) ;;
*) $MKDIR_P ./omega/src
rm -f ./omega/src/config.mli
cp $srcdir/omega/src/config.mli ./omega/src/config.mli 1>/dev/null 2>&1;;
esac
###--------------------------------------------------------------------
### ONLY_OMEGA_AND_FULL }}}
### ONLY_VAMP_AND_FULL {{{
###--------------------------------------------------------------------
### VAMP subdirectory files
AC_CONFIG_FILES([vamp/Makefile])
AC_CONFIG_FILES([vamp/src/Makefile])
AC_CONFIG_FILES([vamp/share/Makefile])
AC_CONFIG_FILES([vamp/share/doc/Makefile])
AC_CONFIG_FILES([vamp/tests/Makefile])
### ONLY_VAMP_AND_FULL }}}
########################################################################
###---------------------------------------------------------------------
### Final output
AC_OUTPUT()
### ONLY_FULL {{{
########################################################################
###---------------------------------------------------------------------
### Final output
WO_SUMMARY()
### ONLY_FULL }}}
########################################################################
Index: trunk/omega/tests/omega_unit.ml
===================================================================
--- trunk/omega/tests/omega_unit.ml (revision 8899)
+++ trunk/omega/tests/omega_unit.ml (revision 8900)
@@ -1,230 +1,236 @@
(* omega_unit.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
open OUnit
let unattended = ref true
let skip_if_unattended () =
skip_if !unattended "not suitable for unattended tests"
let trivial_test =
"trivial" >::
(bracket
(fun () -> true)
(fun b -> assert_bool "always true" b)
(fun b -> ()))
let short_random_list n =
let l = ref [] in
for i = 1 to n do
l := Random.int 1024 :: !l
done;
!l
let allowed_recursion_depth () =
let rec allowed_recursion_depth' n =
try
allowed_recursion_depth' (succ n)
with
| Stack_overflow -> n in
allowed_recursion_depth' 0
let long_random_list factor =
let n = factor * allowed_recursion_depth () in
let l = ref [] in
for i = 1 to n do
l := Random.int n :: !l
done;
!l
module Integer =
struct
type t = int
let compare = compare
let pp_printer = Format.pp_print_int
let pp_print_sep = OUnitDiff.pp_comma_separator
end
module Integer_List = OUnitDiff.ListSimpleMake(Integer)
module ThoList_Unit_Tests =
struct
let inner_list = ThoList.range 1 5
let outer_list = List.map (( * ) 10) (ThoList.range 1 4)
let f n = List.map ((+) n) inner_list
let flatmap =
"flatmap" >::
(fun () ->
let result = ThoList.flatmap f outer_list
and expected = List.flatten (List.map f outer_list) in
assert_equal expected result)
let rev_flatmap =
"rev_flatmap" >::
(fun () ->
let result = ThoList.rev_flatmap f outer_list
and expected = List.rev (ThoList.flatmap f outer_list) in
Integer_List.assert_equal expected result)
let flatmap_stack_overflow =
"flatmap_stack_overflow" >::
(fun () ->
skip_if !unattended "memory limits not suitable for unattended tests";
let l = long_random_list 2 in
let f n = List.map ((+) n) (short_random_list 2) in
assert_raises Stack_overflow
(fun () -> ThoList.flatmap f l))
let rev_flatmap_no_stack_overflow =
"rev_flatmap_no_stack_overflow" >::
(fun () ->
skip_if !unattended "memory limits not suitable for unattended tests";
let l = long_random_list 10 in
let f n = List.map ((+) n) (short_random_list 10) in
ignore (ThoList.rev_flatmap f l);
assert_bool "always true" true)
let suite =
"ThoList" >:::
[flatmap;
flatmap_stack_overflow;
rev_flatmap;
rev_flatmap_no_stack_overflow ]
end
module IListSet =
Set.Make (struct type t = int list let compare = compare end)
let list_elements_unique l =
let rec list_elements_unique' set = function
| [] -> true
| x :: rest ->
if IListSet.mem x set then
false
else
list_elements_unique' (IListSet.add x set) rest in
list_elements_unique' IListSet.empty l
let ilistset_test =
"IListSet" >::
(fun () ->
assert_bool "true" (list_elements_unique [[1];[2]]);
assert_bool "false" (not (list_elements_unique [[1];[1]])))
module Combinatorics_Unit_Tests =
struct
let permute =
"permute" >::
(fun () ->
let n = 8 in
let l = ThoList.range 1 n in
let result = Combinatorics.permute l in
assert_equal (Combinatorics.factorial n) (List.length result);
assert_bool "unique" (list_elements_unique result))
let permute_no_stack_overflow =
"permute_no_stack_overflow" >::
(fun () ->
skip_if !unattended "memory limits not suitable for unattended tests";
let n = 10 in (* n = 10 needs 1 GB, n = 11 needs 7.3 GB *)
let l = ThoList.range 1 n in
let result = Combinatorics.permute l in
assert_equal (Combinatorics.factorial n) (List.length result))
let suite =
"Combinatorics" >:::
[permute;
permute_no_stack_overflow]
end
let selftest_suite =
"testsuite" >:::
[trivial_test;
ilistset_test]
module Permutation_Test_Using_Lists =
Permutation.Test(Permutation.Using_Lists)
module Permutation_Test_Using_Arrays =
Permutation.Test(Permutation.Using_Arrays)
let suite =
"omega" >:::
[selftest_suite;
ThoList_Unit_Tests.suite;
ThoList.Test.suite;
ThoArray.Test.suite;
ThoString.Test.suite;
+ ThoMap.Test.suite;
+ PArray.Test.suite;
Partial.Test.suite;
Permutation_Test_Using_Lists.suite;
Permutation_Test_Using_Arrays.suite;
Combinatorics_Unit_Tests.suite;
Combinatorics.Test.suite;
+ DAG.Test.suite;
+ Orders.Test.suite;
Young.Test.suite;
Algebra.Q.Test.suite;
Algebra.QC.Test.suite;
Algebra.Laurent.Test.suite;
+ Arrow.Test.suite;
+ Birdtracks.Test.suite;
+ Color_Fusion.Test.suite;
Color.Flow.Test.suite;
- Color.Arrow.Test.suite;
- Color.Birdtracks.Test.suite;
- Color.SU3.Test.suite;
- (* [Color.U3.Test.suite;] *)
+ SU3.Test.suite;
+ (* [U3.Test.suite;] *)
UFO_targets.Fortran.Test.suite;
UFO_Lorentz.Test.suite;
UFOx.Test.suite;
UFO.Test.suite;
Format_Fortran.Test.suite;
Dirac.Chiral.test_suite;
Dirac.Dirac.test_suite;
Dirac.Majorana.test_suite]
let suite_long =
"omega long" >:::
[Young.Test.suite_long;
Color.Flow.Test.suite_long;
- Color.Arrow.Test.suite_long;
- Color.Birdtracks.Test.suite_long;
- Color.SU3.Test.suite_long;
- (* [Color.U3.Test.suite_long] *) ]
+ Arrow.Test.suite_long;
+ Birdtracks.Test.suite_long;
+ Color_Fusion.Test.suite_long;
+ SU3.Test.suite_long;
+ (* [U3.Test.suite_long] *) ]
let run_suite_long = ref false
let _ =
ignore
(run_test_tt_main
~arg_specs:[("-attended", Arg.Clear unattended,
" run tests that depend on the environment");
("-unattended", Arg.Set unattended,
" don't run tests depend on the environment");
("-long", Arg.Set run_suite_long,
" also run the very long tests")]
suite);
if !run_suite_long then
ignore (run_test_tt suite_long);
exit 0
Index: trunk/omega/tests/comparisons_orders.list
===================================================================
--- trunk/omega/tests/comparisons_orders.list (revision 0)
+++ trunk/omega/tests/comparisons_orders.list (revision 8900)
@@ -0,0 +1,10 @@
+# comparisons_orders.list --
+# ----------------------------------------------------------------------
+# thr abs_thr n roots model process ...
+# ----------------------------------------------------------------------
+uudd 0.95 1E-11 100 1000 SM scatter u ubar -> d dbar
+uuddg 0.90 1E-11 100 1000 SM scatter u ubar -> d dbar g
+uudda 0.90 1E-11 100 1000 SM scatter u ubar -> d dbar A
+uuddga 0.80 1E-11 100 1000 SM scatter u ubar -> d dbar g A
+uudduu 0.75 1E-11 100 1000 SM scatter u ubar -> d dbar u ubar
+uudduudd 0.75 1E-11 100 1000 SM scatter u ubar -> d dbar u ubar d dbar
Index: trunk/omega/tests/compare_orders_driver.sh
===================================================================
--- trunk/omega/tests/compare_orders_driver.sh (revision 0)
+++ trunk/omega/tests/compare_orders_driver.sh (revision 8900)
@@ -0,0 +1,160 @@
+#! /bin/sh
+# compare_orders_driver.sh --
+########################################################################
+
+omega="$1"
+shift
+
+models="sm"
+
+modules=""
+
+########################################################################
+while read module threshold abs_threshold n roots model mode process; do
+
+ case $module in
+
+ '#'*) # skip comments
+ ;;
+
+ '') # skip empty lines
+ ;;
+
+ '!'*) break
+ ;;
+
+ *)
+ ########################################################################
+ modules="$modules $module"
+ eval threshold_$module=$threshold
+ eval abs_threshold_$module=$abs_threshold
+ eval n_$module=$n
+ eval roots_$module=$roots
+ eval process_$module="'$process'"
+ ########################################################################
+
+ # echo "running $omega -$mode '$process'" 1>&2
+ $omega "$@" \
+ -target:parameter_module parameters_$model \
+ -target:module amplitude_compare_orders_v1_${module} \
+ -$mode "$process" 2>/dev/null
+ # echo "running $omega -orders '~{} = [0..]' -$mode '$process'" 1>&2
+ $omega "$@" \
+ -target:parameter_module parameters_$model \
+ -target:module amplitude_compare_orders_v2_${module} \
+ -orders '~{} = [0..]' -$mode "$process" 2>/dev/null
+ ;;
+ esac
+
+done
+########################################################################
+
+for module in $modules; do
+
+ for mode in v1 v2; do
+
+cat <<EOF
+module interface_compare_orders_${mode}_${module}
+ use omega_interface
+ use amplitude_compare_orders_${mode}_${module}
+ implicit none
+ private
+ public :: load
+contains
+ function load () result (p)
+ type(omega_procedures) :: p
+ p%number_particles_in => number_particles_in
+ p%number_particles_out => number_particles_out
+ p%number_spin_states => number_spin_states
+ p%spin_states => spin_states
+ p%number_flavor_states => number_flavor_states
+ p%flavor_states => flavor_states
+ p%number_color_indices => number_color_indices
+ p%number_color_flows => number_color_flows
+ p%color_flows => color_flows
+ p%number_color_factors => number_color_factors
+ p%color_factors => color_factors
+ p%color_sum => color_sum
+ p%new_event => new_event
+ p%reset_helicity_selection => reset_helicity_selection
+ p%is_allowed => is_allowed
+ p%get_amplitude => get_amplitude
+ end function load
+end module interface_compare_orders_${mode}_${module}
+
+EOF
+
+ done
+
+done
+
+########################################################################
+
+cat <<EOF
+program compare_orders_driver
+ use kinds
+ use compare_lib
+EOF
+
+for module in $modules; do
+ for mode in v1 v2; do
+cat <<EOF
+ use interface_compare_orders_${mode}_${module}, load_${mode}_${module} => load
+EOF
+ done
+done
+
+for model in $models; do
+cat <<EOF
+ use parameters_$model, init_parameters_$model => init_parameters
+EOF
+done
+
+cat <<EOF
+ implicit none
+ integer, parameter :: N = 1000
+ real(kind=default), parameter :: ROOTS = 1000
+ integer, parameter :: SEED = 42
+ integer :: failures, attempts, failed_processes, attempted_processes
+ failed_processes = 0
+ attempted_processes = 0
+EOF
+
+for model in $models; do
+cat <<EOF
+ call init_parameters_$model ()
+EOF
+done
+
+for module in $modules; do
+
+eval process="\${process_$module}"
+eval n="\${n_$module}"
+eval threshold="\${threshold_$module}"
+eval abs_threshold="\${abs_threshold_$module}"
+eval roots="\${roots_$module}"
+
+cat <<EOF
+ print *, "checking process '$process'"
+ call check (load_v1_$module (), load_v2_$module (), &
+ roots = real ($roots, kind=default), &
+ threshold = real ($threshold, kind=default), &
+ n = $n, seed = SEED, &
+ abs_threshold = real ($abs_threshold, kind=default), &
+ failures = failures, attempts = attempts)
+ if (failures > 0) then
+ print *, failures, " failures in ", attempts, " attempts"
+ failed_processes = failed_processes + 1
+ end if
+EOF
+done
+
+cat <<EOF
+ if (failed_processes > 0) then
+ print *, failed_processes, " failed processes in ", attempted_processes, " attempts"
+ stop 1
+ end if
+end program compare_orders_driver
+EOF
+
+exit 0
Index: trunk/omega/tests/exotic_color_driver.sh
===================================================================
--- trunk/omega/tests/exotic_color_driver.sh (revision 0)
+++ trunk/omega/tests/exotic_color_driver.sh (revision 8900)
@@ -0,0 +1,33 @@
+#! /bin/sh -x
+########################################################################
+
+# Edited by tests/Makefile using $(SED)
+
+EXOTIC_COLOR_TESTS="%%EXOTIC_COLOR_TESTS%%"
+srcdir="%%srcdir%%"
+SED="%%SED%%"
+OMEGA_UFO="%%OMEGA_UFO%%"
+OMEGA_UFO_MAJORANA="%%OMEGA_UFO_MAJORANA%%"
+EXOTIC_COLOR_UFO_DIR="%%EXOTIC_COLOR_UFO_DIR%%"
+
+########################################################################
+
+# Run the tests:
+for name in $EXOTIC_COLOR_TESTS; do
+ file="$srcdir/$name"
+ process="`$SED '/^#/d' $file | $SED -n 1p`"
+ cascade="`$SED '/^#/d' $file | $SED -n 2p`"
+ $SED '/^#/d' $file | $SED -n '3,$p' >$name.expected
+ $OMEGA_UFO -model:UFO_dir "$EXOTIC_COLOR_UFO_DIR" -model:exec \
+ -scatter "$process" -cascade "$cascade" -quiet \
+ | $SED -n '/flavor combinations/,$p' >$name.result
+ diff $name.expected $name.result
+ rc=$?
+ if test "$rc" -ne 0; then
+ exit $rc
+ else
+ rm -f $name.expected $name.result
+ fi
+done
+
+exit 0
Index: trunk/omega/tests/sextet-exchange.exotic_color
===================================================================
--- trunk/omega/tests/sextet-exchange.exotic_color (revision 0)
+++ trunk/omega/tests/sextet-exchange.exotic_color (revision 8900)
@@ -0,0 +1,319 @@
+# sextet-exchange.exotic_color --
+########################################################################
+# process
+s3 s3 -> s3 s3
+# cascade
+3 + 4
+########################################################################
+! flavor combinations:
+!
+! 1: s3 s3 -> s3 s3
+!
+! color flows:
+!
+! 1: ( 1, 0) ( 2, 0) -> ( 1, 0) ( 2, 0)
+! 2: ( 2, 0) ( 1, 0) -> ( 1, 0) ( 2, 0)
+!
+! NB: i.g. not all color flows contribute to all flavor
+! combinations. Consult the array FLV_COL_IS_ALLOWED
+! below for the allowed combinations.
+!
+! Color Factors:
+!
+! ( 1, 1): + N^2
+! ( 2, 1): + N
+! ( 2, 2): + N^2
+!
+! vanishing or redundant flavor combinations:
+!
+!
+! diagram selection (MIGHT BREAK GAUGE INVARIANCE!!!):
+!
+! 3+4 ~ ? grouping {{3,4}}
+!
+!
+module omega_amplitude
+ use kinds
+ use omega95
+ use omega_color, OCF => omega_color_factor
+ use omega_amplitude_ufo
+ implicit none
+ private
+ public :: number_particles_in, number_particles_out, number_color_indices, &
+ reset_helicity_selection, new_event, is_allowed, get_amplitude, &
+ color_sum, external_masses, openmp_supported, number_spin_states, &
+ spin_states, number_flavor_states, flavor_states, number_color_flows, &
+ color_flows, number_color_factors, color_factors
+
+ ! DON'T EVEN THINK of removing the following!
+ ! If the compiler complains about undeclared
+ ! or undefined variables, you are compiling
+ ! against an incompatible omega95 module!
+ integer, dimension(7), parameter, private :: require = &
+ (/ omega_spinors_2010_01_A, omega_spinor_cpls_2010_01_A, &
+ omega_vectors_2010_01_A, omega_polarizations_2010_01_A, &
+ omega_couplings_2010_01_A, omega_color_2010_01_A, &
+ omega_utils_2010_01_A /)
+
+ integer, parameter :: n_prt = 4
+ integer, parameter :: n_in = 2
+ integer, parameter :: n_out = 2
+ integer, parameter :: n_cflow = 2
+ integer, parameter :: n_cindex = 2
+ integer, parameter :: n_flv = 1
+ integer, parameter :: n_hel = 1
+ integer, parameter :: n_co = 0
+ integer, parameter :: n_cop = 0
+
+ ! NB: you MUST NOT change the value of N_ here!!!
+ ! It is defined here for convenience only and must be
+ ! compatible with hardcoded values in the amplitude!
+ real(kind=default), parameter :: N_ = 3
+ logical, parameter :: F = .false.
+ logical, parameter :: T = .true.
+
+ integer, dimension(n_co,n_cop), save, protected :: table_coupling_orders
+
+ integer, dimension(n_prt,n_hel), save, protected :: table_spin_states
+ data table_spin_states(:, 1) / 0, 0, 0, 0 /
+
+ integer, dimension(n_prt,n_flv), save, protected :: table_flavor_states
+ data table_flavor_states(:, 1) / 3, 3, 3, 3 / ! s3 s3 s3 s3
+
+ integer, dimension(n_cindex,n_prt,n_cflow), save, protected :: table_color_flows
+ data table_color_flows(:,:, 1) / 1,0, 2,0, 1,0, 2,0 /
+ data table_color_flows(:,:, 2) / 2,0, 1,0, 1,0, 2,0 /
+
+ logical, dimension(n_prt,n_cflow), save, protected :: table_ghost_flags
+ data table_ghost_flags(:, 1) / F, F, F, F /
+ data table_ghost_flags(:, 2) / F, F, F, F /
+
+ integer, parameter :: n_cfactors = 4
+ type(OCF), dimension(n_cfactors), save, protected :: table_color_factors
+ real(kind=default), parameter, private :: color_factor_000001 = +N_**2
+ data table_color_factors( 1) / OCF(1,1,color_factor_000001) /
+ real(kind=default), parameter, private :: color_factor_000002 = +N_
+ data table_color_factors( 2) / OCF(1,2,color_factor_000002) /
+ real(kind=default), parameter, private :: color_factor_000003 = +N_
+ data table_color_factors( 3) / OCF(2,1,color_factor_000003) /
+ real(kind=default), parameter, private :: color_factor_000004 = +N_**2
+ data table_color_factors( 4) / OCF(2,2,color_factor_000004) /
+
+ logical, dimension(n_flv, n_cflow), save, protected :: flv_col_is_allowed
+ data flv_col_is_allowed(:, 1) / T /
+ data flv_col_is_allowed(:, 2) / T /
+
+ complex(kind=default), dimension(n_flv, n_cflow, n_hel), save :: amp
+
+ logical, dimension(n_hel), save :: hel_is_allowed = T
+ real(kind=default), dimension(n_hel), save :: hel_max_abs = 0
+ real(kind=default), save :: hel_sum_abs = 0, hel_threshold = 1E10_default
+ integer, save :: hel_count = 0, hel_cutoff = 100
+ integer :: i
+ integer, save, dimension(n_hel) :: hel_map = (/(i, i = 1, n_hel)/)
+ integer, save :: hel_finite = n_hel
+
+ type(momentum) :: p1, p2, p3, p4
+ type(momentum) :: p12
+ complex(kind=default) :: owf_f5_o2_p4, owf_f5_o1_p3, owf_f6_i2_p2, &
+ owf_f6_i2_p1, owf_f6_i1_p2, owf_f6_i1_p1
+ complex(kind=default) :: owf_f4_i21_p12_X1, owf_f4_i21_p12_X2, &
+ owf_f4_i12_p12_X1, owf_f4_i12_p12_X2
+ complex(kind=default) :: oks_f6_i2_f6_i1_f6_i1_f6_i2, &
+ oks_f6_i1_f6_i2_f6_i1_f6_i2
+
+contains
+
+ pure function number_particles_in () result (n)
+ integer :: n
+ n = n_in
+ end function number_particles_in
+
+ pure function number_particles_out () result (n)
+ integer :: n
+ n = n_out
+ end function number_particles_out
+
+ pure function number_spin_states () result (n)
+ integer :: n
+ n = size (table_spin_states, dim=2)
+ end function number_spin_states
+
+ pure subroutine spin_states (a)
+ integer, dimension(:,:), intent(out) :: a
+ a = table_spin_states
+ end subroutine spin_states
+
+ pure function number_flavor_states () result (n)
+ integer :: n
+ n = size (table_flavor_states, dim=2)
+ end function number_flavor_states
+
+ pure subroutine flavor_states (a)
+ integer, dimension(:,:), intent(out) :: a
+ a = table_flavor_states
+ end subroutine flavor_states
+
+ pure subroutine external_masses (m, flv)
+ real(kind=default), dimension(:), intent(out) :: m
+ integer, intent(in) :: flv
+ select case (flv)
+ case ( 1)
+ m( 1) = ZERO
+ m( 2) = ZERO
+ m( 3) = ZERO
+ m( 4) = ZERO
+ end select
+ end subroutine external_masses
+
+ pure function openmp_supported () result (status)
+ logical :: status
+ status = .false.
+ end function openmp_supported
+
+ pure function number_color_indices () result (n)
+ integer :: n
+ n = size (table_color_flows, dim=1)
+ end function number_color_indices
+
+ pure function number_color_flows () result (n)
+ integer :: n
+ n = size (table_color_flows, dim=3)
+ end function number_color_flows
+
+ pure subroutine color_flows (a, g)
+ integer, dimension(:,:,:), intent(out) :: a
+ logical, dimension(:,:), intent(out) :: g
+ a = table_color_flows
+ g = table_ghost_flags
+ end subroutine color_flows
+
+ pure function number_color_factors () result (n)
+ integer :: n
+ n = size (table_color_factors)
+ end function number_color_factors
+
+ pure subroutine color_factors (cf)
+ type(OCF), dimension(:), intent(out) :: cf
+ cf = table_color_factors
+ end subroutine color_factors
+
+ function color_sum (flv, hel) result (amp2)
+ integer, intent(in) :: flv, hel
+ real(kind=default) :: amp2
+ amp2 = real (omega_color_sum (flv, hel, amp, table_color_factors))
+ end function color_sum
+
+ subroutine new_event (p)
+ real(kind=default), dimension(0:3,*), intent(in) :: p
+ logical :: mask_dirty
+ integer :: hel
+ call calculate_amplitudes (amp, p, hel_is_allowed)
+ if ((hel_threshold .gt. 0) .and. (hel_count .le. hel_cutoff)) then
+ call omega_update_helicity_selection (hel_count, amp, hel_max_abs, &
+ hel_sum_abs, hel_is_allowed, hel_threshold, hel_cutoff, &
+ mask_dirty)
+ if (mask_dirty) then
+ hel_finite = 0
+ do hel = 1, n_hel
+ if (hel_is_allowed(hel)) then
+ hel_finite = hel_finite + 1
+ hel_map(hel_finite) = hel
+ end if
+ end do
+ end if
+ end if
+ end subroutine new_event
+
+ subroutine reset_helicity_selection (threshold, cutoff)
+ real(kind=default), intent(in) :: threshold
+ integer, intent(in) :: cutoff
+ integer :: i
+ hel_is_allowed = T
+ hel_max_abs = 0
+ hel_sum_abs = 0
+ hel_count = 0
+ hel_threshold = threshold
+ hel_cutoff = cutoff
+ hel_map = (/(i, i = 1, n_hel)/)
+ hel_finite = n_hel
+ end subroutine reset_helicity_selection
+
+ pure function is_allowed (flv, hel, col) result (yorn)
+ logical :: yorn
+ integer, intent(in) :: flv, hel, col
+ yorn = hel_is_allowed(hel) .and. flv_col_is_allowed(flv,col)
+ end function is_allowed
+
+ pure function get_amplitude (flv, hel, col) result (amp_result)
+ complex(kind=default) :: amp_result
+ integer, intent(in) :: flv, hel, col
+ amp_result = amp(flv, col, hel)
+ end function get_amplitude
+
+
+
+ subroutine calculate_amplitudes (amp, k, mask)
+ complex(kind=default), dimension(:,:,:), intent(out) :: amp
+ real(kind=default), dimension(0:3,*), intent(in) :: k
+ logical, dimension(:), intent(in) :: mask
+ integer, dimension(n_prt) :: s
+ integer :: h, hi
+ p1 = - k(:,1) ! incoming
+ p2 = - k(:,2) ! incoming
+ p3 = k(:,3) ! outgoing
+ p4 = k(:,4) ! outgoing
+ p12 = p1 + p2
+ amp = 0
+ if (hel_finite == 0) return
+ do hi = 1, hel_finite
+ h = hel_map(hi)
+ s = table_spin_states(:,h)
+ owf_f6_i2_p1 = 1
+ owf_f6_i1_p2 = 1
+ owf_f5_o1_p3 = 1
+ owf_f5_o2_p4 = 1
+ owf_f6_i1_p1 = 1
+ owf_f6_i2_p2 = 1
+ call compute_fusions_0001 ()
+ call compute_brakets_0001 ()
+ amp(1,1,h) = oks_f6_i1_f6_i2_f6_i1_f6_i2
+ amp(1,2,h) = oks_f6_i2_f6_i1_f6_i1_f6_i2
+ end do
+ end subroutine calculate_amplitudes
+ subroutine compute_fusions_0001 ()
+ owf_f4_i12_p12_X2 = pr_phi(p12,ZERO,ZERO, &
+ + SSS1_p201(+ GC_1,owf_f6_i1_p2,p2,owf_f6_i2_p1,p1))
+ owf_f4_i21_p12_X2 = pr_phi(p12,ZERO,ZERO, &
+ + SSS1_p201(+ GC_1,owf_f6_i1_p2,p2,owf_f6_i2_p1,p1))
+ owf_f4_i12_p12_X1 = pr_phi(p12,ZERO,ZERO, &
+ + SSS1_p201(+ GC_1,owf_f6_i2_p2,p2,owf_f6_i1_p1,p1))
+ owf_f4_i21_p12_X1 = pr_phi(p12,ZERO,ZERO, &
+ + SSS1_p201(+ GC_1,owf_f6_i2_p2,p2,owf_f6_i1_p1,p1))
+ end subroutine compute_fusions_0001
+ subroutine compute_brakets_0001 ()
+ oks_f6_i2_f6_i1_f6_i1_f6_i2 = 0
+ oks_f6_i2_f6_i1_f6_i1_f6_i2 = oks_f6_i2_f6_i1_f6_i1_f6_i2 &
+ + owf_f4_i12_p12_X2*( &
+ + SSS1_p201(+ GC_1,owf_f5_o2_p4,p4,owf_f5_o1_p3,p3))
+ oks_f6_i2_f6_i1_f6_i1_f6_i2 = oks_f6_i2_f6_i1_f6_i1_f6_i2 &
+ + owf_f4_i21_p12_X2*( &
+ + SSS1_p201(+ GC_1,owf_f5_o2_p4,p4,owf_f5_o1_p3,p3))
+ oks_f6_i2_f6_i1_f6_i1_f6_i2 = &
+ - oks_f6_i2_f6_i1_f6_i1_f6_i2 ! 2 vertices, 1 propagators
+ oks_f6_i2_f6_i1_f6_i1_f6_i2 = oks_f6_i2_f6_i1_f6_i1_f6_i2 &
+ / sqrt(2.0_default) ! symmetry factor
+ oks_f6_i1_f6_i2_f6_i1_f6_i2 = 0
+ oks_f6_i1_f6_i2_f6_i1_f6_i2 = oks_f6_i1_f6_i2_f6_i1_f6_i2 &
+ + owf_f4_i12_p12_X1*( &
+ + SSS1_p201(+ GC_1,owf_f5_o2_p4,p4,owf_f5_o1_p3,p3))
+ oks_f6_i1_f6_i2_f6_i1_f6_i2 = oks_f6_i1_f6_i2_f6_i1_f6_i2 &
+ + owf_f4_i21_p12_X1*( &
+ + SSS1_p201(+ GC_1,owf_f5_o2_p4,p4,owf_f5_o1_p3,p3))
+ oks_f6_i1_f6_i2_f6_i1_f6_i2 = &
+ - oks_f6_i1_f6_i2_f6_i1_f6_i2 ! 2 vertices, 1 propagators
+ oks_f6_i1_f6_i2_f6_i1_f6_i2 = oks_f6_i1_f6_i2_f6_i1_f6_i2 &
+ / sqrt(2.0_default) ! symmetry factor
+ end subroutine compute_brakets_0001
+
+end module omega_amplitude
Index: trunk/omega/tests/UFO/Exotic_Color/lorentz.py
===================================================================
--- trunk/omega/tests/UFO/Exotic_Color/lorentz.py (revision 0)
+++ trunk/omega/tests/UFO/Exotic_Color/lorentz.py (revision 8900)
@@ -0,0 +1,45 @@
+# This is not FeynRules output coresponding to a realistic model.
+# It's a handcrafted UFO model for testing exotic color representations.
+# Everything ignored by O'Mega has been stripped.
+# Don't expect Madgraph to be able to use it.
+########################################################################
+
+FFS1 = Lorentz(name = 'FFS1',
+ spins = [ 2, 2, 1 ],
+ structure = 'Identity(2,1)')
+
+FFV1 = Lorentz(name = 'FFV1',
+ spins = [ 2, 2, 3 ],
+ structure = 'Gamma(3,2,1)')
+
+VVV1 = Lorentz(name = 'VVV1',
+ spins = [ 3, 3, 3 ],
+ structure = 'P(3,1)*Metric(1,2) - P(3,2)*Metric(1,2) - P(2,1)*Metric(1,3) + P(2,3)*Metric(1,3) + P(1,2)*Metric(2,3) - P(1,3)*Metric(2,3)')
+
+VVS1 = Lorentz(name = 'VVS1',
+ spins = [ 3, 3, 1 ],
+ structure = 'Metric(1,2)')
+
+VSS1 = Lorentz(name = 'VSS1',
+ spins = [ 3, 1, 1 ],
+ structure = 'P(1,2) - P(1,3)')
+
+SSS1 = Lorentz(name = 'SSS1',
+ spins = [ 1, 1, 1 ],
+ structure = '1')
+
+VVVV1 = Lorentz(name = 'VVVV1',
+ spins = [ 3, 3, 3, 3 ],
+ structure = 'Metric(1,4)*Metric(2,3) - Metric(1,3)*Metric(2,4)')
+
+VVVV2 = Lorentz(name = 'VVVV2',
+ spins = [ 3, 3, 3, 3 ],
+ structure = 'Metric(1,4)*Metric(2,3) + Metric(1,3)*Metric(2,4) - 2*Metric(1,2)*Metric(3,4)')
+
+VVVV3 = Lorentz(name = 'VVVV3',
+ spins = [ 3, 3, 3, 3 ],
+ structure = 'Metric(1,4)*Metric(2,3) - Metric(1,2)*Metric(3,4)')
+
+VVVV4 = Lorentz(name = 'VVVV4',
+ spins = [ 3, 3, 3, 3 ],
+ structure = 'Metric(1,3)*Metric(2,4) - Metric(1,2)*Metric(3,4)')
Index: trunk/omega/tests/UFO/Exotic_Color/Makefile.am
===================================================================
--- trunk/omega/tests/UFO/Exotic_Color/Makefile.am (revision 0)
+++ trunk/omega/tests/UFO/Exotic_Color/Makefile.am (revision 8900)
@@ -0,0 +1,38 @@
+# Makefile.am -- Makefile for O'Mega within and without WHIZARD
+##
+## Process this file with automake to produce Makefile.in
+##
+########################################################################
+#
+# Copyright (C) 1999-2016 by
+# Wolfgang Kilian <kilian@physik.uni-siegen.de>
+# Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+# Juergen Reuter <juergen.reuter@desy.de>
+# Christian Speckner <cnspeckn@googlemail.com>
+#
+# 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.
+#
+########################################################################
+
+EXTRA_DIST = \
+ couplings.py \
+ lorentz.py \
+ parameters.py \
+ particles.py \
+ vertices.py
+
+########################################################################
+## The End.
+########################################################################
Index: trunk/omega/tests/UFO/Exotic_Color/couplings.py
===================================================================
--- trunk/omega/tests/UFO/Exotic_Color/couplings.py (revision 0)
+++ trunk/omega/tests/UFO/Exotic_Color/couplings.py (revision 8900)
@@ -0,0 +1,14 @@
+# This is not FeynRules output coresponding to a realistic model.
+# It's a handcrafted UFO model for testing exotic color representations.
+# Everything ignored by O'Mega has been stripped.
+# Don't expect Madgraph to be able to use it.
+########################################################################
+
+GC_1 = Coupling(name = 'GC_1',
+ value = 'complex(0,1)*g',
+ order = {'1':1})
+
+GC_2 = Coupling(name = 'GC_2',
+ value = 'complex(0,1)*g**2',
+ order = {'1':1})
+
Index: trunk/omega/tests/UFO/Exotic_Color/parameters.py
===================================================================
--- trunk/omega/tests/UFO/Exotic_Color/parameters.py (revision 0)
+++ trunk/omega/tests/UFO/Exotic_Color/parameters.py (revision 8900)
@@ -0,0 +1,19 @@
+# This is not FeynRules output coresponding to a realistic model.
+# It's a handcrafted UFO model for testing exotic color representations.
+# Everything ignored by O'Mega has been stripped.
+# Don't expect Madgraph to be able to use it.
+########################################################################
+
+ZERO = Parameter(name = 'ZERO',
+ nature = 'internal',
+ type = 'real',
+ value = '0.0',
+ texname = '0')
+
+g = Parameter(name = 'g',
+ nature = 'external',
+ type = 'real',
+ value = 1,
+ texname = 'g',
+ lhablock = 'FRBlock',
+ lhacode = [ 1 ])
Index: trunk/omega/tests/UFO/Exotic_Color/vertices.py
===================================================================
--- trunk/omega/tests/UFO/Exotic_Color/vertices.py (revision 0)
+++ trunk/omega/tests/UFO/Exotic_Color/vertices.py (revision 8900)
@@ -0,0 +1,61 @@
+# This is not FeynRules output coresponding to a realistic model.
+# It's a handcrafted UFO model for testing exotic color representations.
+# Everything ignored by O'Mega has been stripped.
+# Don't expect Madgraph to be able to use it.
+########################################################################
+
+V_1 = Vertex(name = 'V_1',
+ particles = [ P.g, P.g, P.g ],
+ color = [ 'f(1,2,3)' ],
+ lorentz = [ L.VVV1 ],
+ couplings = {(0,0):C.GC_1})
+
+V_2 = Vertex(name = 'V_2',
+ particles = [ P.g, P.g, P.g, P.g ],
+ color = [ 'f(-1,1,2)*f(3,4,-1)', 'f(-1,1,3)*f(2,4,-1)', 'f(-1,1,4)*f(2,3,-1)' ],
+ lorentz = [ L.VVVV1, L.VVVV3, L.VVVV4 ],
+ couplings = {(1,1):C.GC_2,(0,0):C.GC_2,(2,2):C.GC_2})
+
+
+V_3 = Vertex(name = 'V_3',
+ particles = [ P.f3__tilde__, P.f3, P.g ],
+ color = [ 'T(3,2,1)' ],
+ lorentz = [ L.FFV1 ],
+ couplings = {(0,0):C.GC_1})
+
+V_4 = Vertex(name = 'V_4',
+ particles = [ P.s3, P.s3, P.s6__tilde__ ],
+ color = [ 'K6(3,2,1)' ],
+ lorentz = [ L.SSS1 ],
+ couplings = {(0,0):C.GC_1})
+
+V_5 = Vertex(name = 'V_5',
+ particles = [ P.s3__tilde__, P.s3__tilde__, P.s6 ],
+ color = [ 'K6Bar(3,2,1)' ],
+ lorentz = [ L.SSS1 ],
+ couplings = {(0,0):C.GC_1})
+
+V_6 = Vertex(name = 'V_6',
+ particles = [ P.s, P.s, P.ss__tilde__ ],
+ color = [ '1' ],
+ lorentz = [ L.SSS1 ],
+ couplings = {(0,0):C.GC_1})
+
+V_7 = Vertex(name = 'V_7',
+ particles = [ P.s__tilde__, P.s__tilde__, P.ss ],
+ color = [ '1' ],
+ lorentz = [ L.SSS1 ],
+ couplings = {(0,0):C.GC_1})
+
+V_8 = Vertex(name = 'V_8',
+ particles = [ P.g, P.s3__tilde__, P.s3 ],
+ color = [ 'T(1,3,2)' ],
+ lorentz = [ L.VSS1 ],
+ couplings = {(0,0):C.GC_1})
+
+V_9 = Vertex(name = 'V_9',
+ particles = [ P.g, P.s6__tilde__, P.s6 ],
+ color = [ 'T6(1,3,2)' ],
+ lorentz = [ L.VSS1 ],
+ couplings = {(0,0):C.GC_1})
+
Index: trunk/omega/tests/UFO/Exotic_Color/particles.py
===================================================================
--- trunk/omega/tests/UFO/Exotic_Color/particles.py (revision 0)
+++ trunk/omega/tests/UFO/Exotic_Color/particles.py (revision 8900)
@@ -0,0 +1,84 @@
+# This is not FeynRules output coresponding to a realistic model.
+# It's a handcrafted UFO model for testing exotic color representations.
+# Everything ignored by O'Mega has been stripped.
+# Don't expect Madgraph to be able to use it.
+########################################################################
+
+g = Particle(pdg_code = 21,
+ name = 'g',
+ antiname = 'g',
+ spin = 3,
+ color = 8,
+ mass = Param.ZERO,
+ width = Param.ZERO,
+ texname = 'g',
+ antitexname = 'g',
+ charge = 0,
+ GhostNumber = 0,
+ LeptonNumber = 0,
+ Y = 0)
+
+f3 = Particle(pdg_code = 1,
+ name = 'f3',
+ antiname = 'f3~',
+ spin = 2,
+ color = 3,
+ mass = Param.ZERO,
+ width = Param.ZERO,
+ texname = 'f_3',
+ antitexname = '\bar f_3',
+ charge = -1)
+
+f3__tilde__ = f3.anti()
+
+s = Particle(pdg_code = 2,
+ name = 's',
+ antiname = 's~',
+ spin = 1,
+ color = 1,
+ mass = Param.ZERO,
+ width = Param.ZERO,
+ texname = 's',
+ antitexname = '\bar s',
+ charge = -1)
+
+s__tilde__ = s.anti()
+
+ss = Particle(pdg_code = 22,
+ name = 'ss',
+ antiname = 'ss~',
+ spin = 1,
+ color = 1,
+ mass = Param.ZERO,
+ width = Param.ZERO,
+ texname = 'ss',
+ antitexname = '\bar s\bar s',
+ charge = -2)
+
+ss__tilde__ = ss.anti()
+
+s3 = Particle(pdg_code = 3,
+ name = 's3',
+ antiname = 's3~',
+ spin = 1,
+ color = 3,
+ mass = Param.ZERO,
+ width = Param.ZERO,
+ texname = 's_3',
+ antitexname = '\bar s_3',
+ charge = -1)
+
+s3__tilde__ = s3.anti()
+
+s6 = Particle(pdg_code = 4,
+ name = 's6',
+ antiname = 's6~',
+ spin = 1,
+ color = 6,
+ mass = Param.ZERO,
+ width = Param.ZERO,
+ texname = 's_6',
+ antitexname = '\bar s_6',
+ charge = -2)
+
+s6__tilde__ = s6.anti()
Index: trunk/omega/tests/UFO/Makefile.am
===================================================================
--- trunk/omega/tests/UFO/Makefile.am (revision 8899)
+++ trunk/omega/tests/UFO/Makefile.am (revision 8900)
@@ -1,34 +1,34 @@
# Makefile.am -- Makefile for O'Mega within and without WHIZARD
##
## Process this file with automake to produce Makefile.in
##
########################################################################
#
# Copyright (C) 1999-2016 by
# Wolfgang Kilian <kilian@physik.uni-siegen.de>
# Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
# Juergen Reuter <juergen.reuter@desy.de>
# 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 = SM MSSM SMEFTsim_top_alphaScheme
+SUBDIRS = SM MSSM Exotic_Color SMEFTsim_top_alphaScheme
########################################################################
## The End.
########################################################################
Index: trunk/omega/tests/Makefile.am
===================================================================
--- trunk/omega/tests/Makefile.am (revision 8899)
+++ trunk/omega/tests/Makefile.am (revision 8900)
@@ -1,1064 +1,1105 @@
# Makefile.am -- Makefile for O'Mega within and without WHIZARD
##
## Process this file with automake to produce Makefile.in
##
########################################################################
#
# Copyright (C) 1999-2023 by
# Wolfgang Kilian <kilian@physik.uni-siegen.de>
# Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
# Juergen Reuter <juergen.reuter@desy.de>
# 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 += exotic_color
+# if there is some debugging output ...
+# XFAIL_TESTS += exotic_color
+
+EXOTIC_COLOR_TESTS = \
+ sextet-exchange.exotic_color
+
+exotic_color: exotic_color_driver.sh Makefile $(OMEGA_UFO)
+ $(SED) -e 's|%%EXOTIC_COLOR_TESTS%%|$(EXOTIC_COLOR_TESTS)|' \
+ -e 's|%%srcdir%%|$(srcdir)|' \
+ -e 's|%%SED%%|$(SED)|' \
+ -e 's|%%OMEGA_UFO%%|$(OMEGA_UFO)|' \
+ -e 's|%%OMEGA_UFO_MAJORANA%%|$(OMEGA_UFO_MAJORANA)|' \
+ -e 's|%%EXOTIC_COLOR_UFO_DIR%%|$(OMEGA_UFO_PATH)/Exotic_Color|' $< >$@
+ chmod +x $@
+
+EXTRA_DIST += exotic_color_driver.sh $(EXOTIC_COLOR_TESTS)
+
+########################################################################
+
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)
########################################################################
+TESTS += compare_orders
+EXTRA_PROGRAMS += compare_orders
+EXTRA_DIST += compare_orders_driver.sh
+EXTRA_DIST += comparisons_orders.list
+
+COMPARE_ORDERS_SUPPORT_F90 = $(WARD_SUPPORT_F90)
+COMPARE_ORDERS_SUPPORT_O = $(WARD_SUPPORT_O)
+
+run_compare_orders: compare_orders
+ ./compare_orders
+
+compare_orders.f90: comparisons_orders.list compare_orders_driver.sh
+ @if $(AM_V_P); then :; else echo " COMPARE_ORDERS_DRIVER"; fi
+ $(AM_V_at)$(SHELL) $(srcdir)/compare_orders_driver.sh "$(OMEGA_SM)" < $< > $@
+
+compare_orders_SOURCES = $(COMPARE_LIB_F90)
+nodist_compare_orders_SOURCES = compare_orders.f90
+compare_orders_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la
+
+compare_orders.o: $(COMPARE_LIB_O)
+
+########################################################################
+
if OCAML_AVAILABLE
TESTS += compare_majorana compare_majorana_legacy compare_majorana_UFO
# XFAIL_TESTS += compare_majorana_UFO
EXTRA_PROGRAMS += compare_majorana compare_majorana_legacy compare_majorana_UFO
EXTRA_DIST += compare_driver_majorana.sh compare_driver_majorana_UFO.sh
EXTRA_DIST += comparisons_majorana.list comparisons_majorana_legacy.list \
comparisons_majorana_UFO.list
compare_majorana.f90: comparisons_majorana.list
@if $(AM_V_P); then :; else echo " COMPARE_DRIVER"; fi
$(AM_V_at)$(SHELL) $(srcdir)/compare_driver_majorana.sh Maj \
"$(OMEGA_XXX)" "$(OMEGA_XXX_MAJORANA)" < $< > $@
compare_majorana_legacy.f90: comparisons_majorana_legacy.list
@if $(AM_V_P); then :; else echo " COMPARE_DRIVER"; fi
$(AM_V_at)$(SHELL) $(srcdir)/compare_driver_majorana.sh MajL \
"$(OMEGA_XXX)" "$(OMEGA_XXX_MAJORANA_LEGACY)" < $< > $@
compare_majorana_UFO.f90: comparisons_majorana_UFO.list
@if $(AM_V_P); then :; else echo " COMPARE_DRIVER"; fi
$(AM_V_at)$(SHELL) $(srcdir)/compare_driver_majorana_UFO.sh MajU \
"$(OMEGA_UFO)" "$(OMEGA_UFO_MAJORANA)" "$(OMEGA_UFO_PATH)" < $< > $@
compare_majorana.f90 compare_majorana_legacy.f90 compare_majorana_UFO.f90: \
compare_driver_majorana.sh $(OMEGA_UFO) $(OMEGA_UFO_MAJORANA)
compare_majorana_SOURCES = $(COMPARE_LIB_F90)
nodist_compare_majorana_SOURCES = compare_majorana.f90
compare_majorana_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la
compare_majorana_legacy_SOURCES = $(COMPARE_LIB_F90)
nodist_compare_majorana_legacy_SOURCES = compare_majorana_legacy.f90
compare_majorana_legacy_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la
compare_majorana_UFO_SOURCES = $(COMPARE_LIB_F90) parameters_SM_UFO.f90
nodist_compare_majorana_UFO_SOURCES = compare_majorana_UFO.f90
compare_majorana_UFO_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la
compare_majorana.o compare_majorana_legacy.o compare_majorana_UFO.o: $(COMPARE_LIB_O)
compare_majorana_UFO.o: parameters_SM_UFO.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 $(OMEGA_UFO_PATH)/SM/ -model:exec \
-target:parameter_module parameters_sm_ufo -params > $@
endif
########################################################################
if OCAML_AVAILABLE
# At quadruple or extended precision, these tests take waaaaaayyyy too long!
if FC_PREC
else
TESTS += fermi_UFO
# XFAIL_TESTS += fermi_UFO
# We need more work on the parameters to pass the tests
# at quadruple or extended precision.
if FC_PREC
XFAIL_TESTS += fermi_UFO
endif
EXTRA_PROGRAMS += fermi_UFO
EXTRA_DIST += fermi_driver_UFO.sh
EXTRA_DIST += fermi_UFO.list
FERMI_UFO_SUPPORT_F90 = \
omega_interface.f90 omega_testtools.f90 tao_random_numbers.f90
FERMI_UFO_SUPPORT_O = $(FERMI_UFO_SUPPORT_F90:.f90=.o)
fermi_UFO_lib.o: $(FERMI_SUPPORT_O)
FERMI_UFO_LIB_F90 = fermi_lib.f90 $(FERMI_UFO_SUPPORT_F90)
FERMI_UFO_LIB_O = $(FERMI_UFO_LIB_F90:.f90=.o)
run_fermi_UFO: fermi_UFO
./fermi_UFO
fermi_UFO.f90: fermi_UFO.list fermi_driver_UFO.sh $(OMEGA_UFO)
@if $(AM_V_P); then :; else echo " FERMI_UFO_DRIVER"; fi
$(AM_V_at)$(SHELL) $(srcdir)/fermi_driver_UFO.sh \
$(OMEGA_UFO) $(OMEGA_UFO_MAJORANA) $(OMEGA_UFO_PATH) \
$(OMEGA_SPLIT) < $< > $@
fermi_UFO_SOURCES = $(FERMI_UFO_LIB_F90)
nodist_fermi_UFO_SOURCES = fermi_UFO.f90 parameters_SM_UFO.f90
fermi_UFO_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la
fermi_UFO.o: $(FERMI_UFO_LIB_O) parameters_SM_UFO.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) parameters_SM_UFO.o
endif
endif
########################################################################
TESTS += compare_amplitude_VM
EXTRA_PROGRAMS += compare_amplitude_VM
EXTRA_DIST += compare_driver_VM.sh compare_driver_VM_wrappers.sh
EXTRA_DIST += comparisons_VM.list
compare_amplitude_VM.f90: comparisons_VM.list comparisons_VM.wrappers.o
@if $(AM_V_P); then :; else echo " COMPARE_DRIVER_VM"; fi
$(AM_V_at)$(SHELL) $(srcdir)/compare_driver_VM.sh \
"$(OMEGA_XXX) " "$(OMEGA_XXX_VM) " "$(OMEGA_XXX_VM_PARAMS_OPTS)" < $< > $@
comparisons_VM.wrappers.f90: comparisons_VM.list
@if $(AM_V_P); then :; else echo " COMPARE_DRIVER_VM_WRAPPERS"; fi
$(AM_V_at)$(SHELL) $(srcdir)/compare_driver_VM_wrappers.sh \
"$(OMEGA_XXX) " "$(OMEGA_XXX_VM) " "$(OMEGA_XXX_VM_PARAMS_OPTS)" < $< > $@
# Explicitly state dependence on model files
compare_amplitude_VM.f90: compare_driver_VM.sh \
$(OMEGA_QED) $(OMEGA_QED_VM) \
$(OMEGA_QCD) $(OMEGA_QCD_VM) \
$(OMEGA_SM) $(OMEGA_SM_VM) \
$(OMEGA_SM_CKM) $(OMEGA_SM_CKM_VM) \
$(OMEGA_SM_Higgs) $(OMEGA_SM_Higgs_VM) \
$(OMEGA_THDM) $(OMEGA_THDM_VM) \
$(OMEGA_THDM_CKM) $(OMEGA_THDM_CKM_VM) \
$(OMEGA_HSExt) $(OMEGA_HSExt_VM) \
$(OMEGA_Zprime) $(OMEGA_Zprime_VM)
COMPARE_EXTRA_MODELS = parameters_SM_CKM.f90 parameters_SM_Higgs.f90 \
parameters_THDM.f90 parameters_THDM_CKM.f90 parameters_HSExt.f90 \
parameters_Zprime.f90
compare_amplitude_VM_SOURCES = $(COMPARE_LIB_F90) $(COMPARE_EXTRA_MODELS)
nodist_compare_amplitude_VM_SOURCES = compare_amplitude_VM.f90 comparisons_VM.wrappers.f90
compare_amplitude_VM_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la
compare_amplitude_VM.o: $(COMPARE_LIB_O)
########################################################################
if FC_USE_OPENMP
TESTS += test_openmp
EXTRA_PROGRAMS += test_openmp
TESTOPENMP_SUPPORT_F90 = $(WARD_SUPPORT_F90)
TESTOPENMP_SUPPORT_O = $(WARD_SUPPORT_O)
test_openmp_SOURCES = test_openmp.f90 $(TESTOPENMP_SUPPORT_F90)
nodist_test_openmp_SOURCES = amplitude_openmp.f90
test_openmp_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la
amplitude_openmp.f90: $(OMEGA_QCD) Makefile
$(OMEGA_QCD) $(OMEGA_QCD_OPTS) -target:openmp \
-target:module amplitude_openmp -scatter "gl gl -> gl gl gl" > $@
test_openmp.o: amplitude_openmp.o
test_openmp.o: $(TESTOPENMP_SUPPORT_O)
amplitude_openmp.o: parameters_QCD.o
endif
########################################################################
EXTRA_PROGRAMS += benchmark_VM_vs_Fortran
EXTRA_DIST += benchmark_VM_vs_Fortran_driver.sh
BENCHMARK_LIB_F90 = benchmark_lib.f90 $(WARD_SUPPORT_F90)
BENCHMARK_LIB_O = $(BENCHMARK_LIB_F90:.f90=.o)
benchmark_VM_vs_Fortran.f90: benchmark_processes.list benchmark_processes.wrappers.o
@if $(AM_V_P); then :; else echo " BENCHMARK_VM_DRIVER"; fi
$(AM_V_at)$(SHELL) $(srcdir)/benchmark_VM_vs_Fortran_driver.sh \
"$(OMEGA_XXX) " "$(OMEGA_XXX_VM) " "$(OMEGA_XXX_VM_PARAMS_OPTS)" < $< > $@
benchmark_processes.wrappers.f90: benchmark_processes.list
@if $(AM_V_P); then :; else echo " BENCHMARK_DRIVER_WRAPPERS"; fi
$(AM_V_at)$(SHELL) $(srcdir)/benchmark_driver_wrappers.sh \
"$(OMEGA_XXX) " "$(OMEGA_XXX_VM) " "$(OMEGA_XXX_VM_PARAMS_OPTS)" < $< > $@
# Explicitly state dependence on model files
benchmark_VM_vs_Fortran.f90: benchmark_VM_vs_Fortran_driver.sh \
$(OMEGA_QED) $(OMEGA_QED_VM) \
$(OMEGA_QCD) $(OMEGA_QCD_VM) \
$(OMEGA_SM) $(OMEGA_SM_VM)
benchmark_VM_vs_Fortran_SOURCES = $(BENCHMARK_LIB_F90)
nodist_benchmark_VM_vs_Fortran_SOURCES = benchmark_VM_vs_Fortran.f90 benchmark_processes.wrappers.f90
benchmark_VM_vs_Fortran_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la
benchmark_VM_vs_Fortran.o: $(BENCHMARK_LIB_O)
########################################################################
if FC_USE_OPENMP
EXTRA_PROGRAMS += benchmark_amp_parallel
benchmark_amp_parallel.f90: benchmark_processes.list benchmark_processes.wrappers.o
@if $(AM_V_P); then :; else echo " BENCHMARK_PARALLEL_DRIVER"; fi
$(AM_V_at)$(SHELL) $(srcdir)/benchmark_amp_parallel_driver.sh \
"$(OMEGA_XXX) " "$(OMEGA_XXX_VM) " "$(OMEGA_XXX_VM_PARAMS_OPTS)" < $< > $@
# Explicitly state dependence on model files
benchmark_amp_parallel.f90: benchmark_amp_parallel_driver.sh \
$(OMEGA_QED) $(OMEGA_QED_VM) \
$(OMEGA_QCD) $(OMEGA_QCD_VM) \
$(OMEGA_SM) $(OMEGA_SM_VM)
benchmark_amp_parallel_SOURCES = $(BENCHMARK_LIB_F90)
nodist_benchmark_amp_parallel_SOURCES = benchmark_amp_parallel.f90 benchmark_processes.wrappers.f90
benchmark_amp_parallel_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la
benchmark_amp_parallel.o: $(BENCHMARK_LIB_O)
endif
########################################################################
EXTRA_PROGRAMS += benchmark
run_benchmark: benchmark
./benchmark
BENCHMARK_PROCESS = -scatter "gl gl -> gl gl gl"
BENCHMARK_SPLIT_SIZE = 10
benchmark_SOURCES = benchmark.f90 parameters_QCD.f90
nodist_benchmark_SOURCES = \
amplitude_benchmark_v1.f90 amplitude_benchmark_v2.f90 \
amplitude_benchmark_v3.f90 # amplitude_benchmark_v4.f90
benchmark_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la
amplitude_benchmark_v1.f90: $(OMEGA_QCD) Makefile
$(OMEGA_QCD) $(OMEGA_QCD_OPTS) -target:module amplitude_benchmark_v1 \
$(BENCHMARK_PROCESS) -target:single_function > $@
amplitude_benchmark_v2.f90: $(OMEGA_QCD) Makefile
$(OMEGA_QCD) $(OMEGA_QCD_OPTS) -target:module amplitude_benchmark_v2 \
$(BENCHMARK_PROCESS) -target:split_function $(BENCHMARK_SPLIT_SIZE) > $@
amplitude_benchmark_v3.f90: $(OMEGA_QCD) Makefile
$(OMEGA_QCD) $(OMEGA_QCD_OPTS) -target:module amplitude_benchmark_v3 \
$(BENCHMARK_PROCESS) -target:split_module $(BENCHMARK_SPLIT_SIZE) > $@
amplitude_benchmark_v4.f90: $(OMEGA_QCD) Makefile
$(OMEGA_QCD) $(OMEGA_QCD_OPTS) -target:module amplitude_benchmark_v4 \
$(BENCHMARK_PROCESS) -target:split_file $(BENCHMARK_SPLIT_SIZE) > $@
benchmark.o: \
amplitude_benchmark_v1.o amplitude_benchmark_v2.o \
amplitude_benchmark_v3.o # amplitude_benchmark_v4.o
benchmark.o: parameters_QCD.o
amplitude_benchmark_v1.o amplitude_benchmark_v2.o \
amplitude_benchmark_v3.o amplitude_benchmark_v4.o: parameters_QCD.o
########################################################################
EXTRA_PROGRAMS += benchmark_UFO_SM
run_benchmark_UFO_SM: benchmark_UFO_SM
./benchmark_UFO_SM
# NB: This IS portable ...
UFO_SM = $(OMEGA_UFO_PATH)/SM/
BENCHMARK_UFO_SM_PROCESS = -scatter "e+ e- -> W+ W- Z Z"
benchmark_UFO_SM_SOURCES = \
benchmark_UFO_SM.f90 parameters_SM_from_UFO.f90
nodist_benchmark_UFO_SM_SOURCES = \
amplitude_benchmark_UFO_SM.f90 \
amplitude_benchmark_UFO_SM_classic.f90 \
parameters_SM_UFO.f90
benchmark_UFO_SM_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la
amplitude_benchmark_UFO_SM_classic.f90: $(OMEGA_SM) Makefile
$(OMEGA_SM) -target:module amplitude_benchmark_UFO_SM_classic \
-target:parameter_module parameters_SM_from_UFO \
$(BENCHMARK_UFO_SM_PROCESS) > $@
amplitude_benchmark_UFO_SM.f90: $(OMEGA_UFO) Makefile
$(OMEGA_UFO) -model:UFO_dir $(UFO_SM) -model:exec \
-target:module amplitude_benchmark_UFO_SM \
-target:parameter_module parameters_SM_UFO \
$(BENCHMARK_UFO_SM_PROCESS) > $@
benchmark_UFO_SM.o: \
amplitude_benchmark_UFO_SM.o amplitude_benchmark_UFO_SM_classic.o
benchmark_UFO_SM.o: parameters_SM_UFO.o parameters_SM_from_UFO.o
amplitude_benchmark_UFO_SM_classic.o: parameters_SM_from_UFO.o
amplitude_benchmark_UFO_SM.o: parameters_SM_UFO.o
########################################################################
EXTRA_PROGRAMS += benchmark_UFO_SMEFT
run_benchmark_UFO_SMEFT: benchmark_UFO_SMEFT
./benchmark_UFO_SMEFT
# NB: This is NOT portable ...
UFO_SMEFT = /home/ohl/physics/SMEFT_mW_UFO/
BENCHMARK_UFO_SMEFT_PROCESS = -scatter "e+ e- -> W+ W- Z"
benchmark_UFO_SMEFT_SOURCES = benchmark_UFO_SMEFT.f90
nodist_benchmark_UFO_SMEFT_SOURCES = \
amplitude_benchmark_UFO_SMEFT.f90 \
amplitude_benchmark_UFO_SMEFT_opt.f90 \
parameters_UFO_SMEFT.f90
benchmark_UFO_SMEFT_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la
amplitude_benchmark_UFO_SMEFT.f90: $(OMEGA_UFO) Makefile
$(OMEGA_UFO) -model:UFO_dir $(UFO_SMEFT) -model:exec \
-target:module amplitude_benchmark_UFO_SMEFT \
-target:parameter_module parameters_UFO_SMEFT \
$(BENCHMARK_UFO_SMEFT_PROCESS) | $(SED) 's/g == 0/.false./' > $@
amplitude_benchmark_UFO_SMEFT_opt.f90: $(OMEGA_UFO) Makefile
$(OMEGA_UFO) -model:UFO_dir $(UFO_SMEFT) -model:exec \
-target:module amplitude_benchmark_UFO_SMEFT_opt \
-target:parameter_module parameters_UFO_SMEFT \
$(BENCHMARK_UFO_SMEFT_PROCESS) > $@
benchmark_UFO_SMEFT.o: \
amplitude_benchmark_UFO_SMEFT.o amplitude_benchmark_UFO_SMEFT_opt.o
benchmark_UFO_SMEFT.o: parameters_UFO_SMEFT.o
amplitude_benchmark_UFO_SMEFT.o amplitude_benchmark_UFO_SMEFT_opt.o: \
parameters_UFO_SMEFT.o
parameters_UFO_SMEFT.f90: $(OMEGA_UFO)
$(OMEGA_UFO) -model:UFO_dir $(UFO_SMEFT) -model:exec \
-target:parameter_module parameters_UFO_SMEFT -params > $@
########################################################################
if OCAML_AVAILABLE
TESTS += vertex_unit
EXTRA_PROGRAMS += vertex_unit
vertex_unit_SOURCES = vertex_unit.ml
vertex_unit: $(OMEGA_CORE) vertex_unit.cmx
@if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi
$(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) -o vertex_unit \
unix.cmxa $(OMEGA_CORE) $(OMEGA_MODELS) vertex_unit.cmx
vertex_unit.cmx: vertex_unit.ml
vertex_unit.cmx: $(OMEGA_CORE) $(OMEGA_MODELS)
endif
########################################################################
if OCAML_AVAILABLE
TESTS += ufo_unit
EXTRA_PROGRAMS += ufo_unit
ufo_unit_SOURCES = ufo_unit.ml
ufo_unit: $(OMEGA_CORE) ufo_unit.cmx
@if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi
$(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) -o ufo_unit \
unix.cmxa $(OMEGA_CORE) $(OMEGA_MODELS) ufo_unit.cmx
ufo_unit.cmx: ufo_unit.ml
ufo_unit.cmx: $(OMEGA_CORE) $(OMEGA_MODELS)
endif
########################################################################
if OCAML_AVAILABLE
TESTS += keystones_omegalib keystones_UFO
TESTS += keystones_omegalib_bispinors keystones_UFO_bispinors
# XFAIL_TESTS += keystones_UFO
# XFAIL_TESTS += keystones_UFO_bispinors
EXTRA_PROGRAMS += keystones_omegalib keystones_UFO
EXTRA_PROGRAMS += keystones_omegalib_bispinors keystones_UFO_bispinors
keystones_omegalib_SOURCES = omega_testtools.f90 keystones_tools.f90
nodist_keystones_omegalib_SOURCES = keystones_omegalib.f90
keystones_omegalib_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la
keystones_UFO_SOURCES = omega_testtools.f90 keystones_tools.f90
nodist_keystones_UFO_SOURCES = keystones_UFO.f90
keystones_UFO_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la
keystones_omegalib_bispinors_SOURCES = omega_testtools.f90 keystones_tools.f90
nodist_keystones_omegalib_bispinors_SOURCES = keystones_omegalib_bispinors.f90
keystones_omegalib_bispinors_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la
keystones_UFO_bispinors_SOURCES = omega_testtools.f90 keystones_tools.f90
nodist_keystones_UFO_bispinors_SOURCES = keystones_UFO_bispinors.f90
keystones_UFO_bispinors_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la
EXTRA_PROGRAMS += keystones_omegalib_generate keystones_UFO_generate
EXTRA_PROGRAMS += keystones_omegalib_bispinors_generate keystones_UFO_bispinors_generate
keystones_omegalib_generate_SOURCES = \
keystones.ml keystones.mli keystones_omegalib_generate.ml
keystones_UFO_generate_SOURCES = \
keystones.ml keystones.mli keystones_UFO_generate.ml
keystones_omegalib_bispinors_generate_SOURCES = \
keystones.ml keystones.mli keystones_omegalib_bispinors_generate.ml
keystones_UFO_bispinors_generate_SOURCES = \
keystones.ml keystones.mli keystones_UFO_bispinors_generate.ml
keystones_omegalib.f90: keystones_omegalib_generate
./keystones_omegalib_generate -cat > $@
keystones_UFO.f90: keystones_UFO_generate
./keystones_UFO_generate -cat > $@
keystones_omegalib_bispinors.f90: keystones_omegalib_bispinors_generate
./keystones_omegalib_bispinors_generate -cat > $@
keystones_UFO_bispinors.f90: keystones_UFO_bispinors_generate
./keystones_UFO_bispinors_generate -cat > $@
keystones_omegalib_generate: $(OMEGA_CORE) keystones_omegalib_generate.cmx
@if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi
$(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) \
-o keystones_omegalib_generate \
unix.cmxa $(OMEGA_CORE) $(OMEGA_MODELS) \
keystones.cmx keystones_omegalib_generate.cmx
keystones_UFO_generate: $(OMEGA_CORE) keystones_UFO_generate.cmx
@if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi
$(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) \
-o keystones_UFO_generate \
unix.cmxa $(OMEGA_CORE) $(OMEGA_MODELS) \
keystones.cmx keystones_UFO_generate.cmx
keystones_omegalib_bispinors_generate: $(OMEGA_CORE) keystones_omegalib_bispinors_generate.cmx
@if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi
$(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) \
-o keystones_omegalib_bispinors_generate \
unix.cmxa $(OMEGA_CORE) $(OMEGA_MODELS) \
keystones.cmx keystones_omegalib_bispinors_generate.cmx
keystones_UFO_bispinors_generate: $(OMEGA_CORE) keystones_UFO_bispinors_generate.cmx
@if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi
$(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) \
-o keystones_UFO_bispinors_generate \
unix.cmxa $(OMEGA_CORE) $(OMEGA_MODELS) \
keystones.cmx keystones_UFO_bispinors_generate.cmx
keystones_omegalib_generate.cmx: \
keystones.cmi keystones.cmx keystones_omegalib_generate.ml
keystones_omegalib_generate.cmx: $(OMEGA_CORE) $(OMEGA_MODELS)
keystones_UFO_generate.cmx: \
keystones.cmi keystones.cmx keystones_UFO_generate.ml
keystones_UFO_generate.cmx: $(OMEGA_CORE) $(OMEGA_MODELS)
keystones_omegalib_bispinors_generate.cmx: \
keystones.cmi keystones.cmx keystones_omegalib_bispinors_generate.ml
keystones_omegalib_bispinors_generate.cmx: $(OMEGA_CORE) $(OMEGA_MODELS)
keystones_UFO_bispinors_generate.cmx: \
keystones.cmi keystones.cmx keystones_UFO_bispinors_generate.ml
keystones_UFO_bispinors_generate.cmx: $(OMEGA_CORE) $(OMEGA_MODELS)
keystones.cmx: keystones.ml keystones.cmi
keystones.cmx: $(OMEGA_CORE) $(OMEGA_MODELS)
keystones.cmi: keystones.mli $(OMEGA_CORE)
endif
########################################################################
if RECOLA_AVAILABLE
TESTS += compare_amplitude_recola
# We need more work on the parameters to pass the tests
# at quadruple or extended precision
if FC_PREC
XFAIL_TESTS += compare_amplitude_recola
endif
EXTRA_PROGRAMS += compare_amplitude_recola
AM_FCFLAGS += $(RECOLA_INCLUDES)
compare_amplitude_recola_SOURCES = \
parameters_SM_Higgs_recola.f90 \
omega_interface.f90 compare_lib.f90 compare_lib_recola.f90 \
omega_testtools.f90 tao_random_numbers.f90
nodist_compare_amplitude_recola_SOURCES = compare_amplitude_recola.f90
compare_amplitude_recola.f90: comparisons_recola.list compare_driver_recola.sh
@if $(AM_V_P); then :; else echo " COMPARE_DRIVER_RECOLA"; fi
$(AM_V_at)$(SHELL) $(srcdir)/compare_driver_recola.sh \
"$(OMEGA_XXX) -model:constant_width" < $< > $@
compare_amplitude_recola.o: \
omega_testtools.f90 compare_lib.o compare_lib_recola.o \
tao_random_numbers.o \
parameters_SM_Higgs_recola.o
compare_lib_recola.o: \
omega_testtools.f90 compare_lib.o tao_random_numbers.o \
parameters_SM_Higgs_recola.o
compare_amplitude_recola_LDADD = \
$(LDFLAGS_RECOLA) \
$(KINDS) $(top_builddir)/omega/src/libomega_core.la
run_compare_recola: compare_amplitude_recola
./compare_amplitude_recola
endif
########################################################################
installcheck-local:
PATH=$(DESTDIR)$(bindir):$$PATH; export PATH; \
LD_LIBRARY_PATH=$(DESTDIR)$(libdir):$(DESTDIR)$(pkglibdir):$$LD_LIBRARY_PATH; \
export LD_LIBRARY_PATH; \
omega_QED.opt $(OMEGA_QED_OPTS) -scatter "e+ e- -> m+ m-" \
-target:module amplitude_qed_eemm > amplitude_qed_eemm.f90; \
$(FC) $(AM_FCFLAGS) $(FCFLAGS) -I$(pkgincludedir) \
-L$(DESTDIR)$(libdir) -L$(DESTDIR)$(pkglibdir) \
$(srcdir)/parameters_QED.f90 amplitude_qed_eemm.f90 \
$(srcdir)/test_qed_eemm.f90 -lomega_core; \
./a.out
########################################################################
### Remove DWARF debug information on MAC OS X
clean-macosx:
-rm -rf a.out.dSYM
-rm -rf compare_amplitude_UFO.dSYM
-rm -rf compare_amplitude_VM.dSYM
-rm -rf compare_split_function.dSYM
-rm -rf compare_split_module.dSYM
-rm -rf ects.dSYM
-rm -rf test_omega95.dSYM
-rm -rf test_omega95_bispinors.dSYM
-rm -rf test_qed_eemm.dSYM
-rm -rf ward.dSYM
.PHONY: clean-macosx
clean-local: clean-macosx
rm -f a.out gmon.out *.$(FCMOD) \
*.o *.cmi *.cmo *.cmx amplitude_*.f90 \
$(EXTRA_PROGRAMS) ects.f90 ward.f90 ward_UFO.f90 \
fermi.f90 fermi_UFO.f90 compare_*.f90 \
parameters_SM_UFO.f90 keystones_omegalib.f90 keystones_UFO.f90 \
keystones_UFO_bispinors.f90 keystones_omegalib_bispinors.f90 \
omega_testtools.f90 test_omega95*.f90 benchmark*.f90 \
parameters_UFO_SMEFT.f90 \
- *.hbc *wrappers.f90 cascade phase_space \
- output.rcl recola.log
+ *.hbc *wrappers.f90 cascade exotic_color phase_space \
+ output.rcl recola.log \
+ *.exotic_color.expected *.exotic_color.result
rm -fr output_cll
if FC_SUBMODULES
-rm -f *.smod
endif
########################################################################
## The End.
########################################################################
Index: trunk/omega/src/omega_parameters_tool.nw
===================================================================
--- trunk/omega/src/omega_parameters_tool.nw (revision 8899)
+++ trunk/omega/src/omega_parameters_tool.nw (revision 8900)
@@ -1,160 +0,0 @@
-% omega_parameters_tool.nw --
-%
-% Copyright (C) 1999-2023 by
-% Wolfgang Kilian <kilian@physik.uni-siegen.de>
-% Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
-% Juergen Reuter <juergen.reuter@desy.de>
-% Christian Speckner <cnspeckn@googlemail.com>
-%
-% 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 Genel Public License for more details.
-%
-% You shou have received a copy of the GNU General Public License
-% along wi this program; if not, write to the Free Software
-% Foundati, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
-%
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-@
-<<[[omega_aux_functions.f90]]>>=
-<<Copyleft>
-module omega_aux_function
- use kinds
- use omega_constants
- use omega_parameters
-
- implicit none
- private
-
- integer, parameter, public :: &
- n0 = 5, nloop = 2
- real(kind=default), parameter :: &
- acc = 1.e-12_default
- real(kind=default), parameter :: &
- asmz = 0.118_default
- type(parameter_set) :: par
-
- function faux (x) result (y)
- real(kind=default) :: x
- complex(kind=default) :: y
- if (1 <= x) then
- y = asin(sqrt(1/x))**2
- else
- y = - 1/4.0_default * (log((1 + sqrt(1 - x))/ &
- (1 - sqrt(1 - x))) - cmplx (0.0_default, PI))**2
- end if
- end function faux
-
- function fonehalf (x) result (y)
- real(kind=default), intent(in) :: x
- complex(kind=default) :: y
- if (x==0) then
- y = 0
- else
- y = - 2.0_default * x * (1 + (1 - x) * faux(x))
- end if
- end function fonehalf
-
- function fone (x) result (y)
- real(kind=default), intent(in) :: x
- complex(kind=default) :: y
- if (x==0) then
- y = 2.0_default
- else
- y = 2.0_default + 3.0_default * x + &
- 3.0_default * x * (2.0_default - x) * &
- faux(x)
- end if
- end function fone
-
- function gaux (x) result (y)
- real(kind=default), intent(in) :: x
- complex(kind=default) :: y
- if (1 <= x) then
- y = sqrt(x - 1) * asin(sqrt(1/x))
- else
- y = sqrt(1 - x) * (log((1 + sqrt(1 - x)) / &
- (1 - sqrt(1 - x))) - cmplx (0.0_default, PI)) / 2
- end if
- end function gaux
-
- function i1 (a,b) result (y)
- real(kind=default), intent(in) :: a,b
- complex(kind=default) :: y
- y = a*b/2.0_default/(a-b) + a**2 * b**2/2.0_default/(a-b)**2 * &
- (faux(a) - faux(b)) + &
- a**2 * b/(a-b)**2 * (gaux(a) - gaux(b))
- end function i1
-
- function i2 (a,b) result (y)
- real(kind=default), intent(in) :: a,b
- complex(kind=default) :: y
- y = - a * b / 2.0_default / (a-b) * (faux(a) - faux(b))
- end function i2
-
- function b0 (nf) result (bnull)
- integer, intent(in) :: nf
- real(kind=default) :: bnull
- bnull = 33.0_default - 2.0_default * nf
- end function b0
-
- function b1 (nf) result (bone)
- integer, intent(in) :: nf
- real(kind=default) :: bone
- bone = 6.0_default * (153.0_default - 19.0_default * nf)/b0(nf)**2
- end function b1
-
- function aa (nf) result (aaa)
- integer, intent(in) :: nf
- real(kind=default) :: aaa
- aaa = 12.0_default * PI / b0(nf)
- end function aa
-
- function bb (nf) result (bbb)
- integer, intent(in) :: nf
- real(kind=default) :: bbb
- bbb = b1(nf) / aa(nf)
- end function bb
-
-end module omega_aux_functions
-@
-
-
-@ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-<<Copyleft>>=
-! omega_parameters_tool.nw --
-!
-! Copyright (C) 1999-2009 by
-! Wolfgang Kilian <kilian@physik.uni-siegen.de>
-! Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
-! Juergen Reuter <juergen.reuter@desy.de>
-!
-! 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.
-!
-!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
-@ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-% Local Variables:
-% mode:noweb
-% noweb-doc-mode:latex-mode
-% noweb-code-mode:f90-mode
-% indent-tabs-mode:nil
-% page-delimiter:"^@ %%%.*\n"
-% End:
Index: trunk/omega/src/bundle.mli
===================================================================
--- trunk/omega/src/bundle.mli (revision 8899)
+++ trunk/omega/src/bundle.mli (revision 8900)
@@ -1,138 +1,124 @@
(* bundle.mli --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
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. *)
+(* \label{sec:bundle} *)
+
(* \begin{figure}
\begin{center}
\begin{emp}(80,80)
ahlength := 3mm;
ahangle := 20;
pickup pencircle scaled 1.5pt;
pair nw, ne, sw, se;
nw = (.4w,.9h);
ne = (.9w,.9h);
sw = (.1w,.1h);
se = (.6w,.1h);
for i = 0 step 0.2 until 1:
draw (i*sw+(1-i)*se){up}..{up}(i*nw+(1-i)*ne);
endfor
path base, fiber;
base = (0,.5h){right}..{right}(w,.4h);
fiber = (.6*sw+(1-.6)*se){up}..{up}(.6*nw+(1-.6)*ne);
pickup pencircle scaled 3pt;
draw base;
pickup pencircle scaled 2pt;
draw fiber;
pickup pencircle scaled 1.5pt;
drawarrow (.9w,.3h){up} .. {up}point .8 of base;
label.bot (btex $B=\pi(E)$ etex, (.9w,.3h));
drawarrow (.7w,.2h){up} .. {-1,1}(base intersectionpoint fiber);
label.bot (btex $x\in B$ etex, (.7w,.2h));
drawarrow (.2w,.8h){right} .. point .8 of fiber;
- label.lft (btex $\pi^{-1}(x)$ etex, (.2w,.8h));
- label.lft (btex $E = \pi^{-1}(b)$ etex, (.2w,.6h));
+ label.lft (btex $\pi^{-1}(x) \subset E$ etex, (.2w,.8h));
+ label.lft (btex $\pi^{-1}(B) = \bigcup_{x\in B}\pi^{-1}(x) \subset 2^E$ etex, (.2w,.6h));
setbounds currentpicture to (0,0)--(w,0)--(w,h)--(0,h)--cycle;
\end{emp}
\end{center}
\caption{\label{fig:bundle}
The bundle structure implemented by [Bundle.T]}
\end{figure}
\label{Bundle}
See figure~\ref{fig:bundle} for the geometric intuition behind the bundle structure.
\begin{dubious}
Does the current implementation support faithful projections with a forgetful
comparison in the base?
\end{dubious}
*)
module type Elt_Base =
sig
type elt
type base
val compare_elt : elt -> elt -> int
val compare_base : base -> base -> int
end
module type Projection =
sig
include Elt_Base
-
- (* $\pi: E \to B$ *)
- val pi : elt -> base
-
+ val pi : elt -> base (* projection $\pi: E \to B$ *)
end
+(* Note that writing $\pi^{-1}$ for the ``inverse'' is an \textit{abuse-de-langage},
+ because $\pi^{-1}\circ\pi$ is \emph{not} the identity. It does not map each element
+ to itself but to the fiber that contains it. It is not an
+ automorphism of~$E$, but a map from~$E$ to its power set~$2^E$. *)
module type T =
sig
-
type t
-
type elt
type fiber = elt list
type base
-
- val add : elt -> t -> t
+ val empty : t
+ val add : t -> elt -> t
val of_list : elt list -> t
-
- (* $\pi: E \to B$ *)
- val pi : elt -> base
-
- (* $\pi^{-1}: B \to E$ *)
- val inv_pi : base -> t -> fiber
-
+ val pi : elt -> base (* projection $\pi: E \to B$ *)
+ val inv_pi : t -> base -> fiber (*``inverse'' projection $\pi^{-1}:B\to 2^E$*)
val base : t -> base list
-
- (* $\pi^{-1}\circ\pi$ *)
- val fiber : elt -> t -> fiber
-
+ val fiber : t -> elt -> fiber (* $\pi^{-1}\circ\pi: E\to 2^E$ *)
val fibers : t -> (base * fiber) list
end
module Make (P : Projection) : T with type elt = P.elt and type base = P.base
(* The same thing again, but with a projection that is not hardcoded, but passed
as an argument at runtime. *)
module type Dyn =
sig
type t
type elt
type fiber = elt list
type base
- val add : (elt -> base) -> elt -> t -> t
+ val empty : t
+ val add : (elt -> base) -> t -> elt -> t
val of_list : (elt -> base) -> elt list -> t
- val inv_pi : base -> t -> fiber
+ val inv_pi : t -> base -> fiber
val base : t -> base list
- val fiber : (elt -> base) -> elt -> t -> fiber
+ val fiber : (elt -> base) -> t -> elt -> fiber
val fibers : t -> (base * fiber) list
end
module Dyn (P : Elt_Base) : Dyn with type elt = P.elt and type base = P.base
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/omega_UED.ml
===================================================================
--- trunk/omega/src/omega_UED.ml (revision 8899)
+++ trunk/omega/src/omega_UED.ml (revision 8900)
@@ -1,35 +1,26 @@
(* omega_UED.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.Fortran)
- (Modellib_BSM.UED(Modellib_BSM.BSM_bsm))
+module O = Omega.Mixed23(Target_Fortran.Make)(Modellib_BSM.UED(Modellib_BSM.BSM_bsm))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/colorize.ml
===================================================================
--- trunk/omega/src/colorize.ml (revision 8899)
+++ trunk/omega/src/colorize.ml (revision 8900)
@@ -1,1849 +1,2029 @@
(* colorize.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
Marco Sekulla <marco.sekulla@kit.edu>
So Young Shim <soyoung.shim@desy.de>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
(* \thocwmodulesection{Auxiliary functions} *)
(* \thocwmodulesubsection{Exceptions} *)
let incomplete s =
failwith ("Colorize." ^ s ^ " not done yet!")
let invalid s =
invalid_arg ("Colorize." ^ s ^ " must not be evaluated!")
let impossible s =
invalid_arg ("Colorize." ^ s ^ " can't happen! (but just did ...)")
let mismatch s =
invalid_arg ("Colorize." ^ s ^ " mismatch of representations!")
let su0 s =
invalid_arg ("Colorize." ^ s ^ ": found SU(0)!")
let colored_vertex s =
invalid_arg ("Colorize." ^ s ^ ": colored vertex!")
+let non_legacy_color s cp =
+ invalid_arg ("Colorize." ^ s ^ ": non legacy color in legacy code: " ^
+ Color_Propagator.to_string cp)
+
let baryonic_vertex s =
invalid_arg ("Colorize." ^ s ^
": baryonic (i.e. eps_ijk) vertices not supported yet!")
let color_flow_ambiguous s =
invalid_arg ("Colorize." ^ s ^ ": ambiguous color flow!")
let color_flow_of_string s =
let c = int_of_string s in
if c < 1 then
invalid_arg ("Colorize." ^ s ^ ": color flow # < 1!")
else
c
+let young_tableaux s =
+ failwith ("Colorize." ^ s ^ " classic colorizer can't support Young tableaux!")
+
(* \thocwmodulesubsection{Multiplying Vertices by a Constant Factor} *)
module Q = Algebra.Q
module QC = Algebra.QC
let of_int n =
QC.make (Q.make n 1) Q.null
let integer z =
- if Q.is_null (QC.imag z) then
- let x = QC.real z in
+ if Q.is_null (QC.im z) then
+ let x = QC.re z in
try
Some (Q.to_integer x)
with
| _ -> None
else
None
let mult_vertex3 x v =
let open Coupling in
match v with
| FBF (c, fb, coup, f) ->
FBF ((x * c), fb, coup, f)
| PBP (c, fb, coup, f) ->
PBP ((x * c), fb, coup, f)
| BBB (c, fb, coup, f) ->
BBB ((x * c), fb, coup, f)
| GBG (c, fb, coup, f) ->
GBG ((x * c), fb, coup, f)
| Gauge_Gauge_Gauge c ->
Gauge_Gauge_Gauge (x * c)
| I_Gauge_Gauge_Gauge c ->
I_Gauge_Gauge_Gauge (x * c)
| Aux_Gauge_Gauge c ->
Aux_Gauge_Gauge (x * c)
| Scalar_Vector_Vector c ->
Scalar_Vector_Vector (x * c)
| Aux_Vector_Vector c ->
Aux_Vector_Vector (x * c)
| Aux_Scalar_Vector c ->
Aux_Scalar_Vector (x * c)
| Scalar_Scalar_Scalar c ->
Scalar_Scalar_Scalar (x * c)
| Aux_Scalar_Scalar c ->
Aux_Scalar_Scalar (x * c)
| Vector_Scalar_Scalar c ->
Vector_Scalar_Scalar (x * c)
| Graviton_Scalar_Scalar c ->
Graviton_Scalar_Scalar (x * c)
| Graviton_Vector_Vector c ->
Graviton_Vector_Vector (x * c)
| Graviton_Spinor_Spinor c ->
Graviton_Spinor_Spinor (x * c)
| Dim4_Vector_Vector_Vector_T c ->
Dim4_Vector_Vector_Vector_T (x * c)
| Dim4_Vector_Vector_Vector_L c ->
Dim4_Vector_Vector_Vector_L (x * c)
| Dim4_Vector_Vector_Vector_T5 c ->
Dim4_Vector_Vector_Vector_T5 (x * c)
| Dim4_Vector_Vector_Vector_L5 c ->
Dim4_Vector_Vector_Vector_L5 (x * c)
| Dim6_Gauge_Gauge_Gauge c ->
Dim6_Gauge_Gauge_Gauge (x * c)
| Dim6_Gauge_Gauge_Gauge_5 c ->
Dim6_Gauge_Gauge_Gauge_5 (x * c)
| Aux_DScalar_DScalar c ->
Aux_DScalar_DScalar (x * c)
| Aux_Vector_DScalar c ->
Aux_Vector_DScalar (x * c)
| Dim5_Scalar_Gauge2 c ->
Dim5_Scalar_Gauge2 (x * c)
| Dim5_Scalar_Gauge2_Skew c ->
Dim5_Scalar_Gauge2_Skew (x * c)
| Dim5_Scalar_Vector_Vector_T c ->
Dim5_Scalar_Vector_Vector_T (x * c)
| Dim5_Scalar_Vector_Vector_U c ->
Dim5_Scalar_Vector_Vector_U (x * c)
| Dim5_Scalar_Vector_Vector_TU c ->
Dim5_Scalar_Vector_Vector_TU (x * c)
| Dim5_Scalar_Scalar2 c ->
Dim5_Scalar_Scalar2 (x * c)
| Scalar_Vector_Vector_t c ->
Scalar_Vector_Vector_t (x * c)
| Dim6_Vector_Vector_Vector_T c ->
Dim6_Vector_Vector_Vector_T (x * c)
| Tensor_2_Vector_Vector c ->
Tensor_2_Vector_Vector (x * c)
| Tensor_2_Vector_Vector_cf c ->
Tensor_2_Vector_Vector_cf (x * c)
| Tensor_2_Scalar_Scalar c ->
Tensor_2_Scalar_Scalar (x * c)
| Tensor_2_Scalar_Scalar_cf c ->
Tensor_2_Scalar_Scalar_cf (x * c)
| Tensor_2_Vector_Vector_1 c ->
Tensor_2_Vector_Vector_1 (x * c)
| Tensor_2_Vector_Vector_t c ->
Tensor_2_Vector_Vector_t (x * c)
| Dim5_Tensor_2_Vector_Vector_1 c ->
Dim5_Tensor_2_Vector_Vector_1 (x * c)
| Dim5_Tensor_2_Vector_Vector_2 c ->
Dim5_Tensor_2_Vector_Vector_2 (x * c)
| TensorVector_Vector_Vector c ->
TensorVector_Vector_Vector (x * c)
| TensorVector_Vector_Vector_cf c ->
TensorVector_Vector_Vector_cf (x * c)
| TensorVector_Scalar_Scalar c ->
TensorVector_Scalar_Scalar (x * c)
| TensorVector_Scalar_Scalar_cf c ->
TensorVector_Scalar_Scalar_cf (x * c)
| TensorScalar_Vector_Vector c ->
TensorScalar_Vector_Vector (x * c)
| TensorScalar_Vector_Vector_cf c ->
TensorScalar_Vector_Vector_cf (x * c)
| TensorScalar_Scalar_Scalar c ->
TensorScalar_Scalar_Scalar (x * c)
| TensorScalar_Scalar_Scalar_cf c ->
TensorScalar_Scalar_Scalar_cf (x * c)
| Dim7_Tensor_2_Vector_Vector_T c ->
Dim7_Tensor_2_Vector_Vector_T (x * c)
| Dim6_Scalar_Vector_Vector_D c ->
Dim6_Scalar_Vector_Vector_D (x * c)
| Dim6_Scalar_Vector_Vector_DP c ->
Dim6_Scalar_Vector_Vector_DP (x * c)
| Dim6_HAZ_D c ->
Dim6_HAZ_D (x * c)
| Dim6_HAZ_DP c ->
Dim6_HAZ_DP (x * c)
| Gauge_Gauge_Gauge_i c ->
Gauge_Gauge_Gauge_i (x * c)
| Dim6_GGG c ->
Dim6_GGG (x * c)
| Dim6_AWW_DP c ->
Dim6_AWW_DP (x *c)
| Dim6_AWW_DW c ->
Dim6_AWW_DW (x * c)
| Dim6_Gauge_Gauge_Gauge_i c ->
Dim6_Gauge_Gauge_Gauge_i (x * c)
| Dim6_HHH c ->
Dim6_HHH (x * c)
| Dim6_WWZ_DPWDW c ->
Dim6_WWZ_DPWDW (x * c)
| Dim6_WWZ_DW c ->
Dim6_WWZ_DW (x * c)
| Dim6_WWZ_D c ->
Dim6_WWZ_D (x * c)
let cmult_vertex3 z v =
match integer z with
| None -> invalid_arg "cmult_vertex3"
| Some x -> mult_vertex3 x v
let mult_vertex4 x v =
let open Coupling in
match v with
| Scalar4 c ->
Scalar4 (x * c)
| Scalar2_Vector2 c ->
Scalar2_Vector2 (x * c)
| Vector4 ic4_list ->
Vector4 (List.map (fun (c, icl) -> (x * c, icl)) ic4_list)
| DScalar4 ic4_list ->
DScalar4 (List.map (fun (c, icl) -> (x * c, icl)) ic4_list)
| DScalar2_Vector2 ic4_list ->
DScalar2_Vector2 (List.map (fun (c, icl) -> (x * c, icl)) ic4_list)
| GBBG (c, fb, b2, f) ->
GBBG ((x * c), fb, b2, f)
| Vector4_K_Matrix_tho (c, ic4_list) ->
Vector4_K_Matrix_tho ((x * c), ic4_list)
| Vector4_K_Matrix_jr (c, ch2_list) ->
Vector4_K_Matrix_jr ((x * c), ch2_list)
| Vector4_K_Matrix_cf_t0 (c, ch2_list) ->
Vector4_K_Matrix_cf_t0 ((x * c), ch2_list)
| Vector4_K_Matrix_cf_t1 (c, ch2_list) ->
Vector4_K_Matrix_cf_t1 ((x * c), ch2_list)
| Vector4_K_Matrix_cf_t2 (c, ch2_list) ->
Vector4_K_Matrix_cf_t2 ((x * c), ch2_list)
| Vector4_K_Matrix_cf_t_rsi (c, ch2_list) ->
Vector4_K_Matrix_cf_t_rsi ((x * c), ch2_list)
| Vector4_K_Matrix_cf_m0 (c, ch2_list) ->
Vector4_K_Matrix_cf_m0 ((x * c), ch2_list)
| Vector4_K_Matrix_cf_m1 (c, ch2_list) ->
Vector4_K_Matrix_cf_m1 ((x * c), ch2_list)
| Vector4_K_Matrix_cf_m7 (c, ch2_list) ->
Vector4_K_Matrix_cf_m7 ((x * c), ch2_list)
| DScalar2_Vector2_K_Matrix_ms (c, ch2_list) ->
DScalar2_Vector2_K_Matrix_ms ((x * c), ch2_list)
| DScalar2_Vector2_m_0_K_Matrix_cf (c, ch2_list) ->
DScalar2_Vector2_m_0_K_Matrix_cf ((x * c), ch2_list)
| DScalar2_Vector2_m_1_K_Matrix_cf (c, ch2_list) ->
DScalar2_Vector2_m_1_K_Matrix_cf ((x * c), ch2_list)
| DScalar2_Vector2_m_7_K_Matrix_cf (c, ch2_list) ->
DScalar2_Vector2_m_7_K_Matrix_cf ((x * c), ch2_list)
| DScalar4_K_Matrix_ms (c, ch2_list) ->
DScalar4_K_Matrix_ms ((x * c), ch2_list)
| Dim8_Scalar2_Vector2_1 c ->
Dim8_Scalar2_Vector2_1 (x * c)
| Dim8_Scalar2_Vector2_2 c ->
Dim8_Scalar2_Vector2_1 (x * c)
| Dim8_Scalar2_Vector2_m_0 c ->
Dim8_Scalar2_Vector2_m_0 (x * c)
| Dim8_Scalar2_Vector2_m_1 c ->
Dim8_Scalar2_Vector2_m_1 (x * c)
| Dim8_Scalar2_Vector2_m_7 c ->
Dim8_Scalar2_Vector2_m_7 (x * c)
| Dim8_Scalar4 c ->
Dim8_Scalar4 (x * c)
| Dim8_Vector4_t_0 ic4_list ->
Dim8_Vector4_t_0 (List.map (fun (c, icl) -> (x * c, icl)) ic4_list)
| Dim8_Vector4_t_1 ic4_list ->
Dim8_Vector4_t_1 (List.map (fun (c, icl) -> (x * c, icl)) ic4_list)
| Dim8_Vector4_t_2 ic4_list ->
Dim8_Vector4_t_2 (List.map (fun (c, icl) -> (x * c, icl)) ic4_list)
| Dim8_Vector4_m_0 ic4_list ->
Dim8_Vector4_m_0 (List.map (fun (c, icl) -> (x * c, icl)) ic4_list)
| Dim8_Vector4_m_1 ic4_list ->
Dim8_Vector4_m_1 (List.map (fun (c, icl) -> (x * c, icl)) ic4_list)
| Dim8_Vector4_m_7 ic4_list ->
Dim8_Vector4_m_7 (List.map (fun (c, icl) -> (x * c, icl)) ic4_list)
| Dim6_H4_P2 c ->
Dim6_H4_P2 (x * c)
| Dim6_AHWW_DPB c ->
Dim6_AHWW_DPB (x * c)
| Dim6_AHWW_DPW c ->
Dim6_AHWW_DPW (x * c)
| Dim6_AHWW_DW c ->
Dim6_AHWW_DW (x * c)
| Dim6_Vector4_DW c ->
Dim6_Vector4_DW (x * c)
| Dim6_Vector4_W c ->
Dim6_Vector4_W (x * c)
| Dim6_Scalar2_Vector2_PB c ->
Dim6_Scalar2_Vector2_PB (x * c)
| Dim6_Scalar2_Vector2_D c ->
Dim6_Scalar2_Vector2_D (x * c)
| Dim6_Scalar2_Vector2_DP c ->
Dim6_Scalar2_Vector2_DP (x * c)
| Dim6_HHZZ_T c ->
Dim6_HHZZ_T (x * c)
| Dim6_HWWZ_DW c ->
Dim6_HWWZ_DW (x * c)
| Dim6_HWWZ_DPB c ->
Dim6_HWWZ_DPB (x * c)
| Dim6_HWWZ_DDPW c ->
Dim6_HWWZ_DDPW (x * c)
| Dim6_HWWZ_DPW c ->
Dim6_HWWZ_DPW (x * c)
| Dim6_AHHZ_D c ->
Dim6_AHHZ_D (x * c)
| Dim6_AHHZ_DP c ->
Dim6_AHHZ_DP (x * c)
| Dim6_AHHZ_PB c ->
Dim6_AHHZ_PB (x * c)
let cmult_vertex4 z v =
match integer z with
| None -> invalid_arg "cmult_vertex4"
| Some x -> mult_vertex4 x v
let mult_vertexn x = function
| _ -> incomplete "mult_vertexn"
let cmult_vertexn z v =
let open Coupling in
match v with
| UFO (c, v, s, fl, col) ->
UFO (QC.mul z c, v, s, fl, col)
let mult_vertex x v =
let open Coupling in
match v with
| V3 (v, fuse, c) -> V3 (mult_vertex3 x v, fuse, c)
| V4 (v, fuse, c) -> V4 (mult_vertex4 x v, fuse, c)
| Vn (v, fuse, c) -> Vn (mult_vertexn x v, fuse, c)
let cmult_vertex z v =
let open Coupling in
match v with
| V3 (v, fuse, c) -> V3 (cmult_vertex3 z v, fuse, c)
| V4 (v, fuse, c) -> V4 (cmult_vertex4 z v, fuse, c)
| Vn (v, fuse, c) -> Vn (cmult_vertexn z v, fuse, c)
(* \thocwmodulesection{Flavors Adorned with Colorflows} *)
module Flavor (M : Model.T) =
struct
type cf_in = int
type cf_out = int
+ (* \begin{dubious}
+ The legacy types [CF_in], etc, are not orthogonal
+ to [Color_Propagator.t], unfortunately, but we will
+ have to life with this for a while.
+ \end{dubious} *)
+
+ module CP = Color_Propagator
+
type t =
| White of M.flavor
| CF_in of M.flavor * cf_in
| CF_out of M.flavor * cf_out
| CF_io of M.flavor * cf_in * cf_out
| CF_aux of M.flavor
+ | CF of M.flavor * CP.t
let flavor_sans_color = function
| White f -> f
| CF_in (f, _) -> f
| CF_out (f, _) -> f
| CF_io (f, _, _) -> f
| CF_aux f -> f
+ | CF (f, _) -> f
let pullback f arg1 =
f (flavor_sans_color arg1)
+ (* Since the alternatives in the sum type [t] are not orthogonal,
+ we have make sure that we don't produce false negatives.
+ In addition, non trivial color flows of type [Color_Propagator.t]
+ need a special equality.
+ \begin{dubious}
+ Converting everything to [CF (f, cp)] first is the most concise,
+ but not the most efficient approach. However, it's probably not
+ worth the effort to cook up an optimized comparison before
+ we retire the other alternatives in [t].
+ \end{dubious} *)
+
+ let to_cp = function
+ | White f -> (f, CP.white)
+ | CF_in (f, cfi) -> (f, CP.of_lists [cfi] [])
+ | CF_out (f, cfo) -> (f, CP.of_lists [] [cfo])
+ | CF_io (f, cfi, cfo) -> (f, CP.of_lists [cfi] [cfo])
+ | CF_aux f -> (f, CP.Ghost)
+ | CF (f, cp) -> (f, cp)
+
+ let equal f1 f2 =
+ let f1, cp1 = to_cp f1
+ and f2, cp2 = to_cp f2 in
+ f1 = f2 && CP.equal cp1 cp2
+
end
(* \thocwmodulesection{The Legacy Implementation} *)
(* We have to keep this legacy implementation around,
because it infers the color flows from the $\mathrm{SU}(3)$
representations of a particle in vertices with three and four
legs (except for four triplets, where the connections are
ambiguous). The new implementation is already used for UFO
models exclusively, since they don't use [Coupling.V2]
and [Coupling.V3] at all. *)
module Legacy_Implementation (M : Model.T) =
struct
module C = Color
module Colored_Flavor = Flavor(M)
open Colored_Flavor
open Coupling
let nc = M.nc
(* \thocwmodulesubsection{Auxiliary functions} *)
(* Below, we will need to permute Lorentz structures. The following
permutes the three possible contractions of four vectors. We permute
the first three indices, as they correspond to the particles entering
the fusion. *)
type permutation4 =
| P123 | P231 | P312
| P213 | P321 | P132
let permute_contract4 = function
| P123 ->
begin function
| C_12_34 -> C_12_34
| C_13_42 -> C_13_42
| C_14_23 -> C_14_23
end
| P231 ->
begin function
| C_12_34 -> C_14_23
| C_13_42 -> C_12_34
| C_14_23 -> C_13_42
end
| P312 ->
begin function
| C_12_34 -> C_13_42
| C_13_42 -> C_14_23
| C_14_23 -> C_12_34
end
| P213 ->
begin function
| C_12_34 -> C_12_34
| C_13_42 -> C_14_23
| C_14_23 -> C_13_42
end
| P321 ->
begin function
| C_12_34 -> C_14_23
| C_13_42 -> C_13_42
| C_14_23 -> C_12_34
end
| P132 ->
begin function
| C_12_34 -> C_13_42
| C_13_42 -> C_12_34
| C_14_23 -> C_14_23
end
let permute_contract4_list perm ic4_list =
List.map (fun (i, c4) -> (i, permute_contract4 perm c4)) ic4_list
let permute_vertex4' perm = function
| Scalar4 c ->
Scalar4 c
| Vector4 ic4_list ->
Vector4 (permute_contract4_list perm ic4_list)
| Vector4_K_Matrix_jr (c, ic4_list) ->
Vector4_K_Matrix_jr (c, permute_contract4_list perm ic4_list)
| Vector4_K_Matrix_cf_t0 (c, ic4_list) ->
Vector4_K_Matrix_cf_t0 (c, permute_contract4_list perm ic4_list)
| Vector4_K_Matrix_cf_t1 (c, ic4_list) ->
Vector4_K_Matrix_cf_t1 (c, permute_contract4_list perm ic4_list)
| Vector4_K_Matrix_cf_t2 (c, ic4_list) ->
Vector4_K_Matrix_cf_t2 (c, permute_contract4_list perm ic4_list)
| Vector4_K_Matrix_cf_t_rsi (c, ic4_list) ->
Vector4_K_Matrix_cf_t_rsi (c, permute_contract4_list perm ic4_list)
| Vector4_K_Matrix_cf_m0 (c, ic4_list) ->
Vector4_K_Matrix_cf_m0 (c, permute_contract4_list perm ic4_list)
| Vector4_K_Matrix_cf_m1 (c, ic4_list) ->
Vector4_K_Matrix_cf_m1 (c, permute_contract4_list perm ic4_list)
| Vector4_K_Matrix_cf_m7 (c, ic4_list) ->
Vector4_K_Matrix_cf_m7 (c, permute_contract4_list perm ic4_list)
| DScalar2_Vector2_K_Matrix_ms (c, ic4_list) ->
DScalar2_Vector2_K_Matrix_ms (c, permute_contract4_list perm ic4_list)
| DScalar2_Vector2_m_0_K_Matrix_cf (c, ic4_list) ->
DScalar2_Vector2_m_0_K_Matrix_cf (c, permute_contract4_list perm ic4_list)
| DScalar2_Vector2_m_1_K_Matrix_cf (c, ic4_list) ->
DScalar2_Vector2_m_1_K_Matrix_cf (c, permute_contract4_list perm ic4_list)
| DScalar2_Vector2_m_7_K_Matrix_cf (c, ic4_list) ->
DScalar2_Vector2_m_7_K_Matrix_cf (c, permute_contract4_list perm ic4_list)
| DScalar4_K_Matrix_ms (c, ic4_list) ->
DScalar4_K_Matrix_ms (c, permute_contract4_list perm ic4_list)
| Scalar2_Vector2 c ->
incomplete "permute_vertex4' Scalar2_Vector2"
| DScalar4 ic4_list ->
incomplete "permute_vertex4' DScalar4"
| DScalar2_Vector2 ic4_list ->
incomplete "permute_vertex4' DScalar2_Vector2"
| GBBG (c, fb, b2, f) ->
incomplete "permute_vertex4' GBBG"
| Vector4_K_Matrix_tho (c, ch2_list) ->
incomplete "permute_vertex4' Vector4_K_Matrix_tho"
| Dim8_Scalar2_Vector2_1 ic4_list ->
incomplete "permute_vertex4' Dim8_Scalar2_Vector2_1"
| Dim8_Scalar2_Vector2_2 ic4_list ->
incomplete "permute_vertex4' Dim8_Scalar2_Vector2_2"
| Dim8_Scalar2_Vector2_m_0 ic4_list ->
incomplete "permute_vertex4' Dim8_Scalar2_Vector2_m_0"
| Dim8_Scalar2_Vector2_m_1 ic4_list ->
incomplete "permute_vertex4' Dim8_Scalar2_Vector2_m_1"
| Dim8_Scalar2_Vector2_m_7 ic4_list ->
incomplete "permute_vertex4' Dim8_Scalar2_Vector2_m_7"
| Dim8_Scalar4 ic4_list ->
incomplete "permute_vertex4' Dim8_Scalar4"
| Dim8_Vector4_t_0 ic4_list ->
incomplete "permute_vertex4' Dim8_Vector4_t_0"
| Dim8_Vector4_t_1 ic4_list ->
incomplete "permute_vertex4' Dim8_Vector4_t_1"
| Dim8_Vector4_t_2 ic4_list ->
incomplete "permute_vertex4' Dim8_Vector4_t_2"
| Dim8_Vector4_m_0 ic4_list ->
incomplete "permute_vertex4' Dim8_Vector4_m_0"
| Dim8_Vector4_m_1 ic4_list ->
incomplete "permute_vertex4' Dim8_Vector4_m_1"
| Dim8_Vector4_m_7 ic4_list ->
incomplete "permute_vertex4' Dim8_Vector4_m_7"
| Dim6_H4_P2 ic4_list ->
incomplete "permute_vertex4' Dim6_H4_P2"
| Dim6_AHWW_DPB ic4_list ->
incomplete "permute_vertex4' Dim6_AHWW_DPB"
| Dim6_AHWW_DPW ic4_list ->
incomplete "permute_vertex4' Dim6_AHWW_DPW"
| Dim6_AHWW_DW ic4_list ->
incomplete "permute_vertex4' Dim6_AHWW_DW"
| Dim6_Vector4_DW ic4_list ->
incomplete "permute_vertex4' Dim6_Vector4_DW"
| Dim6_Vector4_W ic4_list ->
incomplete "permute_vertex4' Dim6_Vector4_W"
| Dim6_Scalar2_Vector2_D ic4_list ->
incomplete "permute_vertex4' Dim6_Scalar2_Vector2_D"
| Dim6_Scalar2_Vector2_DP ic4_list ->
incomplete "permute_vertex4' Dim6_Scalar2_Vector2_DP"
| Dim6_Scalar2_Vector2_PB ic4_list ->
incomplete "permute_vertex4' Dim6_Scalar2_Vector2_PB"
| Dim6_HHZZ_T ic4_list ->
incomplete "permute_vertex4' Dim6_HHZZ_T"
| Dim6_HWWZ_DW ic4_list ->
incomplete "permute_vertex4' Dim6_HWWZ_DW"
| Dim6_HWWZ_DPB ic4_list ->
incomplete "permute_vertex4' Dim6_HWWZ_DPB"
| Dim6_HWWZ_DDPW ic4_list ->
incomplete "permute_vertex4' Dim6_HWWZ_DDPW"
| Dim6_HWWZ_DPW ic4_list ->
incomplete "permute_vertex4' Dim6_HWWZ_DPW"
| Dim6_AHHZ_D ic4_list ->
incomplete "permute_vertex4' Dim6_AHHZ_D"
| Dim6_AHHZ_DP ic4_list ->
incomplete "permute_vertex4' Dim6_AHHZ_DP"
| Dim6_AHHZ_PB ic4_list ->
incomplete "permute_vertex4' Dim6_AHHZ_PB"
let permute_vertex4 perm = function
| V3 (v, fuse, c) -> V3 (v, fuse, c)
| V4 (v, fuse, c) -> V4 (permute_vertex4' perm v, fuse, c)
| Vn (v, fuse, c) -> Vn (v, fuse, c)
(* \thocwmodulesubsection{Cubic Vertices} *)
(* \begin{dubious}
The following pattern matches could eventually become quite long.
The O'Caml compiler will (hopefully) optimize them aggressively
(\url{http://pauillac.inria.fr/~maranget/papers/opat/}).
\end{dubious} *)
let colorize_fusion2 f1 f2 (f, v) =
match M.color f with
| C.Singlet ->
begin match f1, f2 with
| White _, White _ ->
[White f, v]
| CF_in (_, c1), CF_out (_, c2')
| CF_out (_, c1), CF_in (_, c2') ->
if c1 = c2' then
[White f, v]
else
[]
| CF_io (f1, c1, c1'), CF_io (f2, c2, c2') ->
if c1 = c2' && c2 = c1' then
[White f, v]
else
[]
| CF_aux f1, CF_aux f2 ->
[White f, mult_vertex (- (nc ())) v]
| CF_aux _, CF_io _ | CF_io _, CF_aux _ ->
[]
| (CF_in _ | CF_out _ | CF_io _ | CF_aux _), White _
| White _, (CF_in _ | CF_out _ | CF_io _ | CF_aux _)
| (CF_io _ | CF_aux _), (CF_in _ | CF_out _)
| (CF_in _ | CF_out _), (CF_io _ | CF_aux _)
| CF_in _, CF_in _ | CF_out _, CF_out _ ->
colored_vertex "colorize_fusion2"
+ | CF (_, c), _ | _, CF (_, c) -> non_legacy_color "colorize_fusion2" c
end
| C.SUN nc1 ->
begin match f1, f2 with
| CF_in (_, c1), (White _ | CF_aux _)
| (White _ | CF_aux _), CF_in (_, c1) ->
if nc1 > 0 then
[CF_in (f, c1), v]
else
colored_vertex "colorize_fusion2"
| CF_out (_, c1'), (White _ | CF_aux _)
| (White _ | CF_aux _), CF_out (_, c1') ->
if nc1 < 0 then
[CF_out (f, c1'), v]
else
colored_vertex "colorize_fusion2"
| CF_in (_, c1), CF_io (_, c2, c2')
| CF_io (_, c2, c2'), CF_in (_, c1) ->
if nc1 > 0 then begin
if c1 = c2' then
[CF_in (f, c2), v]
else
[]
end else
colored_vertex "colorize_fusion2"
| CF_out (_, c1'), CF_io (_, c2, c2')
| CF_io (_, c2, c2'), CF_out (_, c1') ->
if nc1 < 0 then begin
if c1' = c2 then
[CF_out (f, c2'), v]
else
[]
end else
colored_vertex "colorize_fusion2"
| CF_in _, CF_in _ ->
if nc1 > 0 then
baryonic_vertex "colorize_fusion2"
else
colored_vertex "colorize_fusion2"
| CF_out _, CF_out _ ->
if nc1 < 0 then
baryonic_vertex "colorize_fusion2"
else
colored_vertex "colorize_fusion2"
| CF_in _, CF_out _ | CF_out _, CF_in _
| (White _ | CF_io _ | CF_aux _),
(White _ | CF_io _ | CF_aux _) ->
colored_vertex "colorize_fusion2"
+ | CF (_, c), _ | _, CF (_, c) -> non_legacy_color "colorize_fusion2" c
end
| C.AdjSUN _ ->
begin match f1, f2 with
| White _, CF_io (_, c1, c2') | CF_io (_, c1, c2'), White _ ->
[CF_io (f, c1, c2'), v]
+ (* Note that for $\tr(F_{mu\nu}F^{\mu\nu})$ couplings, like
+ the effective $Hgg$ coupling, we can't inplement the
+ rules derived in~\cite{Kilian:2012pz}. fusing [White]
+ with [CF_aux] would have to produce a [CF_io], but there
+ is canonical source for a fresh color flow index! If the
+ gluons are not connected via an inbroken string of such
+ couplings to an external line, we can use the
+ considerations in~\eqref{eq:qqqqH} to replace the
+ factor~$N_C$ by $-N_C$. In order to account for the
+ gluons that are connected via an inbroken string of such
+ couplings to an external line, we apply a correction
+ factor $1-2/N_C^2$ for each gluon loop in the very end. *)
+
| White _, CF_aux _ | CF_aux _, White _ ->
[CF_aux f, mult_vertex (- (nc ())) v]
| CF_in (_, c1), CF_out (_, c2')
| CF_out (_, c2'), CF_in (_, c1) ->
if c1 <> c2' then
[CF_io (f, c1, c2'), v]
else
[CF_aux f, v]
(* In the adjoint representation
\begin{subequations}
\begin{equation}
\parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,24)
\fmfsurround{d1,e1,d2,e2,d3,e3}
\fmf{gluon}{v,e1}
\fmf{gluon}{v,e2}
\fmf{gluon}{v,e3}
\fmflabel{1}{e1}
\fmflabel{2}{e2}
\fmflabel{3}{e3}
\fmfdot{v}
\fmffreeze
\fmf{warrow_right}{v,e1}
\fmf{warrow_right}{v,e2}
\fmf{warrow_right}{v,e3}
\end{fmfgraph*}}} \,=
%begin{split}
g f_{a_1a_2a_3} C^{\mu_1\mu_2\mu_3} (k_1,k_2,k_3)
%end{split}
\end{equation}
with
\begin{multline}
\label{eq:C123}
C^{\mu_1\mu_2\mu_3}(k_1,k_2,k_3) = \\
( g^{\mu_1\mu_2} (k_1^{\mu_3}-k_2^{\mu_3})
+ g^{\mu_2\mu_3} (k_2^{\mu_1}-k_3^{\mu_1})
+ g^{\mu_3\mu_1} (k_3^{\mu_2}-k_1^{\mu_2}) )
\end{multline}
\end{subequations}
while in the color flow basis find from
\begin{equation}
\label{eq:f=tr(TTT)}
\ii f_{a_1a_2a_3}
= \tr\left(T_{a_1}\left\lbrack T_{a_2},T_{a_3}\right\rbrack\right)
= \tr\left(T_{a_1}T_{a_2}T_{a_3}\right)
- \tr\left(T_{a_1}T_{a_3}T_{a_2}\right)
\end{equation}
the decomposition
\begin{equation}
\label{eq:fTTT}
\ii f_{a_1a_2a_3} T_{a_1}^{i_1j_1}T_{a_2}^{i_2j_2}T_{a_3}^{i_3j_3}
= \delta^{i_1j_2}\delta^{i_2j_3}\delta^{i_3j_1}
- \delta^{i_1j_3}\delta^{i_3j_2}\delta^{i_2j_1}\,.
\end{equation}
The resulting Feynman rule is
\begin{equation}
\parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,24)
\fmfsurround{d1,e1,d2,e2,d3,e3}
\fmf{phantom}{v,e1}
\fmf{phantom}{v,e2}
\fmf{phantom}{v,e3}
\fmflabel{1}{e1}
\fmflabel{2}{e2}
\fmflabel{3}{e3}
\fmffreeze
\fmfi{phantom_arrow}{(reverse vpath (__e1, __v) sideways -thick)}
\fmfi{phantom_arrow}{( vpath (__e2, __v) sideways -thick)}
\fmfi{phantom_arrow}{(reverse vpath (__e2, __v) sideways -thick)}
\fmfi{phantom_arrow}{( vpath (__e3, __v) sideways -thick)}
\fmfi{phantom_arrow}{(reverse vpath (__e3, __v) sideways -thick)}
\fmfi{phantom_arrow}{( vpath (__e1, __v) sideways -thick)}
\fmfi{plain}{%
(reverse vpath (__e1, __v) sideways -thick)
join ( vpath (__e2, __v) sideways -thick)}
\fmfi{plain}{%
(reverse vpath (__e2, __v) sideways -thick)
join ( vpath (__e3, __v) sideways -thick)}
\fmfi{plain}{%
(reverse vpath (__e3, __v) sideways -thick)
join ( vpath (__e1, __v) sideways -thick)}
\end{fmfgraph*}}} \,=
\ii g
\left( \delta^{i_1j_3}\delta^{i_2j_1}\delta^{i_3j_2}
- \delta^{i_1j_2}\delta^{i_2j_3}\delta^{i_3j_1} \right)
C^{\mu_1\mu_2\mu_3} (k_1,k_2,k_3)
\end{equation} *)
(* \begin{dubious}
We have to generalize this for cases of three particles
in the adjoint that are not all gluons (gluinos, scalar octets):
\begin{itemize}
\item scalar-scalar-scalar
\item scalar-scalar-vector
\item scalar-vector-vector
\item scalar-fermion-fermion
\item vector-fermion-fermion
\end{itemize}
\end{dubious} *)
(* \begin{dubious}
We could use a better understanding of the signs for the
gaugino-gaugino-gaugeboson couplings!!!
\end{dubious} *)
| CF_io (f1, c1, c1'), CF_io (f2, c2, c2') ->
let phase =
begin match v with
| V3 (Gauge_Gauge_Gauge _, _, _)
| V3 (I_Gauge_Gauge_Gauge _, _, _)
| V3 (Aux_Gauge_Gauge _, _, _) -> of_int 1
| V3 (FBF (_, _, _, _), fuse2, _) ->
begin match fuse2 with
| F12 -> of_int 1 (* works, needs underpinning *)
| F21 -> of_int (-1) (* dto. *)
| F31 -> of_int 1 (* dto. *)
| F32 -> of_int (-1) (* transposition of [F12] *)
| F23 -> of_int 1 (* transposition of [F21] *)
| F13 -> of_int (-1) (* transposition of [F12] *)
end
| V3 _ -> incomplete "colorize_fusion2 (V3 _)"
| V4 _ -> impossible "colorize_fusion2 (V4 _)"
| Vn _ -> impossible "colorize_fusion2 (Vn _)"
end in
if c1' = c2 then
[CF_io (f, c1, c2'), cmult_vertex (QC.neg phase) v]
else if c2' = c1 then
[CF_io (f, c2, c1'), cmult_vertex ( phase) v]
else
[]
| CF_aux _ , CF_io _
| CF_io _ , CF_aux _
| CF_aux _ , CF_aux _ ->
[]
| White _, White _
| (White _ | CF_io _ | CF_aux _), (CF_in _ | CF_out _)
| (CF_in _ | CF_out _), (White _ | CF_io _ | CF_aux _)
| CF_in _, CF_in _ | CF_out _, CF_out _ ->
colored_vertex "colorize_fusion2"
+ | CF (_, c), _ | _, CF (_, c) -> non_legacy_color "colorize_fusion2" c
end
+ | C.YT _ | C.YTC _ -> young_tableaux "colorize_fusion2"
+
(* \thocwmodulesubsection{Quartic Vertices} *)
let colorize_fusion3 f1 f2 f3 (f, v) =
match M.color f with
| C.Singlet ->
begin match f1, f2, f3 with
| White _, White _, White _ ->
[White f, v]
| (White _ | CF_aux _), CF_in (_, c1), CF_out (_, c2')
| (White _ | CF_aux _), CF_out (_, c1), CF_in (_, c2')
| CF_in (_, c1), (White _ | CF_aux _), CF_out (_, c2')
| CF_out (_, c1), (White _ | CF_aux _), CF_in (_, c2')
| CF_in (_, c1), CF_out (_, c2'), (White _ | CF_aux _)
| CF_out (_, c1), CF_in (_, c2'), (White _ | CF_aux _) ->
if c1 = c2' then
[White f, v]
else
[]
| White _, CF_io (_, c1, c1'), CF_io (_, c2, c2')
| CF_io (_, c1, c1'), White _, CF_io (_, c2, c2')
| CF_io (_, c1, c1'), CF_io (_, c2, c2'), White _ ->
if c1 = c2' && c2 = c1' then
[White f, v]
else
[]
| White _, CF_aux _, CF_aux _
| CF_aux _, White _, CF_aux _
| CF_aux _, CF_aux _, White _ ->
[White f, mult_vertex (- (nc ())) v]
| White _, CF_io _, CF_aux _
| White _, CF_aux _, CF_io _
| CF_io _, White _, CF_aux _
| CF_aux _, White _, CF_io _
| CF_io _, CF_aux _, White _
| CF_aux _, CF_io _, White _ ->
[]
| CF_io (_, c1, c1'), CF_in (_, c2), CF_out (_, c3')
| CF_io (_, c1, c1'), CF_out (_, c3'), CF_in (_, c2)
| CF_in (_, c2), CF_io (_, c1, c1'), CF_out (_, c3')
| CF_out (_, c3'), CF_io (_, c1, c1'), CF_in (_, c2)
| CF_in (_, c2), CF_out (_, c3'), CF_io (_, c1, c1')
| CF_out (_, c3'), CF_in (_, c2), CF_io (_, c1, c1') ->
if c1 = c3' && c1' = c2 then
[White f, v]
else
[]
| CF_io (_, c1, c1'), CF_io (_, c2, c2'), CF_io (_, c3, c3') ->
if c1' = c2 && c2' = c3 && c3' = c1 then
[White f, mult_vertex (-1) v]
else if c1' = c3 && c2' = c1 && c3' = c2 then
[White f, mult_vertex ( 1) v]
else
[]
| CF_io _, CF_io _, CF_aux _
| CF_io _, CF_aux _, CF_io _
| CF_aux _, CF_io _, CF_io _
| CF_io _, CF_aux _, CF_aux _
| CF_aux _, CF_io _, CF_aux _
| CF_aux _, CF_aux _, CF_io _
| CF_aux _, CF_aux _, CF_aux _ ->
[]
| CF_in _, CF_in _, CF_in _
| CF_out _, CF_out _, CF_out _ ->
baryonic_vertex "colorize_fusion3"
| CF_in _, CF_in _, CF_out _
| CF_in _, CF_out _, CF_in _
| CF_out _, CF_in _, CF_in _
| CF_in _, CF_out _, CF_out _
| CF_out _, CF_in _, CF_out _
| CF_out _, CF_out _, CF_in _
| White _, White _, (CF_io _ | CF_aux _)
| White _, (CF_io _ | CF_aux _), White _
| (CF_io _ | CF_aux _), White _, White _
| (White _ | CF_io _ | CF_aux _), CF_in _, CF_in _
| CF_in _, (White _ | CF_io _ | CF_aux _), CF_in _
| CF_in _, CF_in _, (White _ | CF_io _ | CF_aux _)
| (White _ | CF_io _ | CF_aux _), CF_out _, CF_out _
| CF_out _, (White _ | CF_io _ | CF_aux _), CF_out _
| CF_out _, CF_out _, (White _ | CF_io _ | CF_aux _)
| (CF_in _ | CF_out _),
(White _ | CF_io _ | CF_aux _),
(White _ | CF_io _ | CF_aux _)
| (White _ | CF_io _ | CF_aux _),
(CF_in _ | CF_out _),
(White _ | CF_io _ | CF_aux _)
| (White _ | CF_io _ | CF_aux _),
(White _ | CF_io _ | CF_aux _),
(CF_in _ | CF_out _) ->
colored_vertex "colorize_fusion3"
+ | CF (_, c), _, _ | _, CF (_, c), _ | _, _, CF (_, c) ->
+ non_legacy_color "colorize_fusion3" c
end
| C.SUN nc1 ->
begin match f1, f2, f3 with
| CF_in (_, c1), CF_io (_, c2, c2'), CF_io (_, c3, c3')
| CF_io (_, c2, c2'), CF_in (_, c1), CF_io (_, c3, c3')
| CF_io (_, c2, c2'), CF_io (_, c3, c3'), CF_in (_, c1) ->
if nc1 > 0 then
if c1 = c2' && c2 = c3' then
[CF_in (f, c3), v]
else if c1 = c3' && c3 = c2' then
[CF_in (f, c2), v]
else
[]
else
colored_vertex "colorize_fusion3"
| CF_out (_, c1'), CF_io (_, c2, c2'), CF_io (_, c3, c3')
| CF_io (_, c2, c2'), CF_out (_, c1'), CF_io (_, c3, c3')
| CF_io (_, c2, c2'), CF_io (_, c3, c3'), CF_out (_, c1') ->
if nc1 < 0 then
if c1' = c2 && c2' = c3 then
[CF_out (f, c3'), v]
else if c1' = c3 && c3' = c2 then
[CF_out (f, c2'), v]
else
[]
else
colored_vertex "colorize_fusion3"
| CF_aux _, CF_in (_, c1), CF_io (_, c2, c2')
| CF_aux _, CF_io (_, c2, c2'), CF_in (_, c1)
| CF_in (_, c1), CF_aux _, CF_io (_, c2, c2')
| CF_io (_, c2, c2'), CF_aux _, CF_in (_, c1)
| CF_in (_, c1), CF_io (_, c2, c2'), CF_aux _
| CF_io (_, c2, c2'), CF_in (_, c1), CF_aux _ ->
if nc1 > 0 then
if c1 = c2' then
[CF_in (f, c2), mult_vertex ( 2) v]
else
[]
else
colored_vertex "colorize_fusion3"
| CF_aux _, CF_out (_, c1'), CF_io (_, c2, c2')
| CF_aux _, CF_io (_, c2, c2'), CF_out (_, c1')
| CF_out (_, c1'), CF_aux _, CF_io (_, c2, c2')
| CF_io (_, c2, c2'), CF_aux _, CF_out (_, c1')
| CF_out (_, c1'), CF_io (_, c2, c2'), CF_aux _
| CF_io (_, c2, c2'), CF_out (_, c1'), CF_aux _ ->
if nc1 < 0 then
if c1' = c2 then
[CF_out (f, c2'), mult_vertex ( 2) v]
else
[]
else
colored_vertex "colorize_fusion3"
| White _, CF_in (_, c1), CF_io (_, c2, c2')
| White _, CF_io (_, c2, c2'), CF_in (_, c1)
| CF_in (_, c1), White _, CF_io (_, c2, c2')
| CF_io (_, c2, c2'), White _, CF_in (_, c1)
| CF_in (_, c1), CF_io (_, c2, c2'), White _
| CF_io (_, c2, c2'), CF_in (_, c1), White _ ->
if nc1 > 0 then
if c1 = c2' then
[CF_in (f, c2), v]
else
[]
else
colored_vertex "colorize_fusion3"
| White _, CF_out (_, c1'), CF_io (_, c2, c2')
| White _, CF_io (_, c2, c2'), CF_out (_, c1')
| CF_out (_, c1'), White _, CF_io (_, c2, c2')
| CF_io (_, c2, c2'), White _, CF_out (_, c1')
| CF_out (_, c1'), CF_io (_, c2, c2'), White _
| CF_io (_, c2, c2'), CF_out (_, c1'), White _ ->
if nc1 < 0 then
if c2 = c1' then
[CF_out (f, c2'), v]
else
[]
else
colored_vertex "colorize_fusion3"
| CF_in (_, c1), CF_aux _, CF_aux _
| CF_aux _, CF_in (_, c1), CF_aux _
| CF_aux _, CF_aux _, CF_in (_, c1) ->
if nc1 > 0 then
[CF_in (f, c1), mult_vertex ( 2) v]
else
colored_vertex "colorize_fusion3"
| CF_in (_, c1), CF_aux _, White _
| CF_in (_, c1), White _, CF_aux _
| CF_in (_, c1), White _, White _
| CF_aux _, CF_in (_, c1), White _
| White _, CF_in (_, c1), CF_aux _
| White _, CF_in (_, c1), White _
| CF_aux _, White _, CF_in (_, c1)
| White _, CF_aux _, CF_in (_, c1)
| White _, White _, CF_in (_, c1) ->
if nc1 > 0 then
[CF_in (f, c1), v]
else
colored_vertex "colorize_fusion3"
| CF_out (_, c1'), CF_aux _, CF_aux _
| CF_aux _, CF_out (_, c1'), CF_aux _
| CF_aux _, CF_aux _, CF_out (_, c1') ->
if nc1 < 0 then
[CF_out (f, c1'), mult_vertex ( 2) v]
else
colored_vertex "colorize_fusion3"
| CF_out (_, c1'), CF_aux _, White _
| CF_out (_, c1'), White _, CF_aux _
| CF_out (_, c1'), White _, White _
| CF_aux _, CF_out (_, c1'), White _
| White _, CF_out (_, c1'), CF_aux _
| White _, CF_out (_, c1'), White _
| CF_aux _, White _, CF_out (_, c1')
| White _, CF_aux _, CF_out (_, c1')
| White _, White _, CF_out (_, c1') ->
if nc1 < 0 then
[CF_out (f, c1'), v]
else
colored_vertex "colorize_fusion3"
| CF_in _, CF_in _, CF_out _
| CF_in _, CF_out _, CF_in _
| CF_out _, CF_in _, CF_in _ ->
if nc1 > 0 then
color_flow_ambiguous "colorize_fusion3"
else
colored_vertex "colorize_fusion3"
| CF_in _, CF_out _, CF_out _
| CF_out _, CF_in _, CF_out _
| CF_out _, CF_out _, CF_in _ ->
if nc1 < 0 then
color_flow_ambiguous "colorize_fusion3"
else
colored_vertex "colorize_fusion3"
| CF_in _, CF_in _, CF_in _
| CF_out _, CF_out _, CF_out _
| (White _ | CF_io _ | CF_aux _),
(White _ | CF_io _ | CF_aux _),
(White _ | CF_io _ | CF_aux _)
| (CF_in _ | CF_out _),
(CF_in _ | CF_out _),
(White _ | CF_io _ | CF_aux _)
| (CF_in _ | CF_out _),
(White _ | CF_io _ | CF_aux _),
(CF_in _ | CF_out _)
| (White _ | CF_io _ | CF_aux _),
(CF_in _ | CF_out _),
(CF_in _ | CF_out _) ->
colored_vertex "colorize_fusion3"
+ | CF (_, c), _, _ | _, CF (_, c), _ | _, _, CF (_, c) ->
+ non_legacy_color "colorize_fusion3" c
end
| C.AdjSUN nc ->
begin match f1, f2, f3 with
| CF_in (_, c1), CF_out (_, c1'), White _
| CF_out (_, c1'), CF_in (_, c1), White _
| CF_in (_, c1), White _, CF_out (_, c1')
| CF_out (_, c1'), White _, CF_in (_, c1)
| White _, CF_in (_, c1), CF_out (_, c1')
| White _, CF_out (_, c1'), CF_in (_, c1) ->
if c1 <> c1' then
[CF_io (f, c1, c1'), v]
else
[CF_aux f, v]
| CF_in (_, c1), CF_out (_, c1'), CF_aux _
| CF_out (_, c1'), CF_in (_, c1), CF_aux _
| CF_in (_, c1), CF_aux _, CF_out (_, c1')
| CF_out (_, c1'), CF_aux _, CF_in (_, c1)
| CF_aux _, CF_in (_, c1), CF_out (_, c1')
| CF_aux _, CF_out (_, c1'), CF_in (_, c1) ->
if c1 <> c1' then
[CF_io (f, c1, c1'), mult_vertex ( 2) v]
else
[CF_aux f, mult_vertex ( 2) v]
| CF_in (_, c1), CF_out (_, c1'), CF_io (_, c2, c2')
| CF_out (_, c1'), CF_in (_, c1), CF_io (_, c2, c2')
| CF_in (_, c1), CF_io (_, c2, c2'), CF_out (_, c1')
| CF_out (_, c1'), CF_io (_, c2, c2'), CF_in (_, c1)
| CF_io (_, c2, c2'), CF_in (_, c1), CF_out (_, c1')
| CF_io (_, c2, c2'), CF_out (_, c1'), CF_in (_, c1) ->
if c1 = c2' && c2 = c1' then
[CF_aux f, mult_vertex ( 2) v]
else if c1 = c2' then
[CF_io (f, c2, c1'), v]
else if c2 = c1' then
[CF_io (f, c1, c2'), v]
else
[]
(* \begin{equation}
\parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,24)
\fmfsurround{d1,e1,d2,e2,d3,e3,d4,e4}
\fmf{gluon}{v,e1}
\fmf{gluon}{v,e2}
\fmf{gluon}{v,e3}
\fmf{gluon}{v,e4}
\fmflabel{1}{e1}
\fmflabel{2}{e2}
\fmflabel{3}{e3}
\fmflabel{4}{e4}
\fmfdot{v}
\fmffreeze
\fmf{warrow_right}{v,e1}
\fmf{warrow_right}{v,e2}
\fmf{warrow_right}{v,e3}
\fmf{warrow_right}{v,e4}
\end{fmfgraph*}}} \,=
\begin{split}
\mbox{} - & \ii g^2 f_{a_1a_2b}f_{a_3a_4b}
(g_{\mu_1\mu_3} g_{\mu_4\mu_2} - g_{\mu_1\mu_4} g_{\mu_2\mu_3}) \\
\mbox{} - & \ii g^2 f_{a_1a_3b}f_{a_4a_2b}
(g_{\mu_1\mu_4} g_{\mu_2\mu_3} - g_{\mu_1\mu_2} g_{\mu_3\mu_4}) \\
\mbox{} - & \ii g^2 f_{a_1a_4b}f_{a_2a_3b}
(g_{\mu_1\mu_2} g_{\mu_3\mu_4} - g_{\mu_1\mu_3} g_{\mu_4\mu_2})
\end{split}
\end{equation} *)
(* Using
\begin{equation}
\label{eq:P4}
\mathcal{P}_4 = \left\{\{1,2,3,4\},\{1,3,4,2\},\{1,4,2,3\},
\{1,2,4,3\},\{1,4,3,2\},\{1,3,2,4\}\right\}
\end{equation}
as the set of permutations of~$\{1,2,3,4\}$ with the cyclic permutations
factored out, we have:
\begin{equation}
\label{eq:4GV}
\parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,24)
\fmfsurround{d1,e1,d2,e2,d3,e3,d4,e4}
\fmf{phantom}{v,e1}
\fmf{phantom}{v,e2}
\fmf{phantom}{v,e3}
\fmf{phantom}{v,e4}
\fmflabel{1}{e1}
\fmflabel{2}{e2}
\fmflabel{3}{e3}
\fmflabel{4}{e4}
\fmffreeze
\fmfi{phantom_arrow}{(reverse vpath (__e1, __v) sideways -thick)}
\fmfi{phantom_arrow}{( vpath (__e2, __v) sideways -thick)}
\fmfi{phantom_arrow}{(reverse vpath (__e2, __v) sideways -thick)}
\fmfi{phantom_arrow}{( vpath (__e3, __v) sideways -thick)}
\fmfi{phantom_arrow}{(reverse vpath (__e3, __v) sideways -thick)}
\fmfi{phantom_arrow}{( vpath (__e4, __v) sideways -thick)}
\fmfi{phantom_arrow}{(reverse vpath (__e4, __v) sideways -thick)}
\fmfi{phantom_arrow}{( vpath (__e1, __v) sideways -thick)}
\fmfi{plain}{%
(reverse vpath (__e1, __v) sideways -thick)
join ( vpath (__e2, __v) sideways -thick)}
\fmfi{plain}{%
(reverse vpath (__e2, __v) sideways -thick)
join ( vpath (__e3, __v) sideways -thick)}
\fmfi{plain}{%
(reverse vpath (__e3, __v) sideways -thick)
join ( vpath (__e4, __v) sideways -thick)}
\fmfi{plain}{%
(reverse vpath (__e4, __v) sideways -thick)
join ( vpath (__e1, __v) sideways -thick)}
\end{fmfgraph*}}} \,=
\begin{aligned}
\ii g^2 \sum_{\{\alpha_k\}_{k=1,2,3,4}\in\mathcal{P}_4}
\delta^{i_{\alpha_1}j_{\alpha_2}}\delta^{i_{\alpha_2}j_{\alpha_3}}
\delta^{i_{\alpha_3}j_{\alpha_4}}\delta^{i_{\alpha_4}j_{\alpha_1}}\qquad\qquad\\
\left( 2g_{\mu_{\alpha_1}\mu_{\alpha_3}} g_{\mu_{\alpha_4}\mu_{\alpha_2}}
- g_{\mu_{\alpha_1}\mu_{\alpha_4}} g_{\mu_{\alpha_2}\mu_{\alpha_3}}
- g_{\mu_{\alpha_1}\mu_{\alpha_2}} g_{\mu_{\alpha_3}\mu_{\alpha_4}}\right)
\end{aligned}
\end{equation} *)
(* The different color connections correspond to permutations of the
particles entering the fusion and have to be matched by a corresponding
permutation of the Lorentz structure: *)
(* \begin{dubious}
We have to generalize this for cases of four particles
in the adjoint that are not all gluons:
\begin{itemize}
\item scalar-scalar-scalar-scalar
\item scalar-scalar-vector-vector
\end{itemize}
and even ones including fermions (gluinos) if higher dimensional
operators are involved.
\end{dubious} *)
| CF_io (_, c1, c1'), CF_io (_, c2, c2'), CF_io (_, c3, c3') ->
if c1' = c2 && c2' = c3 then
[CF_io (f, c1, c3'), permute_vertex4 P123 v]
else if c1' = c3 && c3' = c2 then
[CF_io (f, c1, c2'), permute_vertex4 P132 v]
else if c2' = c3 && c3' = c1 then
[CF_io (f, c2, c1'), permute_vertex4 P231 v]
else if c2' = c1 && c1' = c3 then
[CF_io (f, c2, c3'), permute_vertex4 P213 v]
else if c3' = c1 && c1' = c2 then
[CF_io (f, c3, c2'), permute_vertex4 P312 v]
else if c3' = c2 && c2' = c1 then
[CF_io (f, c3, c1'), permute_vertex4 P321 v]
else
[]
| CF_io _, CF_io _, CF_aux _
| CF_io _, CF_aux _, CF_io _
| CF_aux _, CF_io _, CF_io _
| CF_io _, CF_aux _, CF_aux _
| CF_aux _, CF_aux _, CF_io _
| CF_aux _, CF_io _, CF_aux _
| CF_aux _, CF_aux _, CF_aux _ ->
[]
| CF_io (_, c1, c1'), CF_io (_, c2, c2'), White _
| CF_io (_, c1, c1'), White _, CF_io (_, c2, c2')
| White _, CF_io (_, c1, c1'), CF_io (_, c2, c2') ->
if c1' = c2 then
[CF_io (f, c1, c2'), mult_vertex (-1) v]
else if c2' = c1 then
[CF_io (f, c2, c1'), mult_vertex ( 1) v]
else
[]
| CF_io (_, c1, c1'), CF_aux _, White _
| CF_aux _, CF_io (_, c1, c1'), White _
| CF_io (_, c1, c1'), White _, CF_aux _
| CF_aux _, White _, CF_io (_, c1, c1')
| White _, CF_io (_, c1, c1'), CF_aux _
| White _, CF_aux _, CF_io (_, c1, c1') ->
[]
| CF_aux _, CF_aux _, White _
| CF_aux _, White _, CF_aux _
| White _, CF_aux _, CF_aux _ ->
[]
| White _, White _, CF_io (_, c1, c1')
| White _, CF_io (_, c1, c1'), White _
| CF_io (_, c1, c1'), White _, White _ ->
[CF_io (f, c1, c1'), v]
| White _, White _, CF_aux _
| White _, CF_aux _, White _
| CF_aux _, White _, White _ ->
[]
| White _, White _, White _
| (White _ | CF_io _ | CF_aux _),
(White _ | CF_io _ | CF_aux _),
(CF_in _ | CF_out _)
| (White _ | CF_io _ | CF_aux _),
(CF_in _ | CF_out _),
(White _ | CF_io _ | CF_aux _)
| (CF_in _ | CF_out _),
(White _ | CF_io _ | CF_aux _),
(White _ | CF_io _ | CF_aux _)
| CF_in _, CF_in _, (White _ | CF_io _ | CF_aux _)
| CF_in _, (White _ | CF_io _ | CF_aux _), CF_in _
| (White _ | CF_io _ | CF_aux _), CF_in _, CF_in _
| CF_out _, CF_out _, (White _ | CF_io _ | CF_aux _)
| CF_out _, (White _ | CF_io _ | CF_aux _), CF_out _
| (White _ | CF_io _ | CF_aux _), CF_out _, CF_out _
| (CF_in _ | CF_out _),
(CF_in _ | CF_out _),
(CF_in _ | CF_out _) ->
colored_vertex "colorize_fusion3"
+ | CF (_, c), _, _ | _, CF (_, c), _ | _, _, CF (_, c) ->
+ non_legacy_color "colorize_fusion3" c
end
+ | C.YT _ | C.YTC _ -> young_tableaux "colorize_fusion3"
+
(* \thocwmodulesubsection{Quintic and Higher Vertices} *)
let is_white = function
| White _ -> true
| _ -> false
let colorize_fusionn flist (f, v) =
let incomplete_match () =
incomplete
("colorize_fusionn { " ^
String.concat ", " (List.map (pullback M.flavor_to_string) flist) ^
" } -> " ^ M.flavor_to_string f) in
match M.color f with
| C.Singlet ->
if List.for_all is_white flist then
[White f, v]
else
incomplete_match ()
| C.SUN _ ->
if List.for_all is_white flist then
colored_vertex "colorize_fusionn"
else
incomplete_match ()
| C.AdjSUN _ ->
if List.for_all is_white flist then
colored_vertex "colorize_fusionn"
else
incomplete_match ()
+ | C.YT _ | C.YTC _ -> young_tableaux "colorize_fusionn"
+
end
(* \thocwmodulesection{Colorizing a Monochrome Model} *)
module It (M : Model.T) =
struct
open Coupling
module C = Color
+ module CA = Arrow
+ module CV = Color.Vertex
module Colored_Flavor = Flavor(M)
type flavor = Colored_Flavor.t
type flavor_sans_color = M.flavor
let flavor_sans_color = Colored_Flavor.flavor_sans_color
type gauge = M.gauge
type constant = M.constant
let options = M.options
let caveats = M.caveats
+ type coupling_order = M.coupling_order
+ let all_coupling_orders = M.all_coupling_orders
+ let coupling_orders = M.coupling_orders
+ let coupling_order_to_string = M.coupling_order_to_string
+
open Colored_Flavor
+ let flavor_equal = Colored_Flavor.equal
+
let color = pullback M.color
let nc = M.nc
let pdg = pullback M.pdg
let lorentz = pullback M.lorentz
module Ch = M.Ch
let charges = pullback M.charges
(* For the propagator we cannot use pullback because we have to add the case
of the color singlet propagator by hand. *)
let cf_aux_propagator = function
| Prop_Scalar -> Prop_Col_Scalar (* Spin 0 octets. *)
| Prop_Majorana -> Prop_Col_Majorana (* Spin 1/2 octets. *)
| Prop_Feynman -> Prop_Col_Feynman (* Spin 1 states, massless. *)
| Prop_Unitarity -> Prop_Col_Unitarity (* Spin 1 states, massive. *)
| Aux_Scalar -> Aux_Col_Scalar (* constant colored scalar propagator *)
| Aux_Vector -> Aux_Col_Vector (* constant colored vector propagator *)
| Aux_Tensor_1 -> Aux_Col_Tensor_1 (* constant colored tensor propagator *)
| Prop_Col_Scalar | Prop_Col_Feynman
| Prop_Col_Majorana | Prop_Col_Unitarity
| Aux_Col_Scalar | Aux_Col_Vector | Aux_Col_Tensor_1
-> failwith ("Colorize.It().colorize_propagator: already colored particle!")
| _ -> failwith ("Colorize.It().colorize_propagator: impossible!")
let propagator = function
| CF_aux f -> cf_aux_propagator (M.propagator f)
| White f -> M.propagator f
| CF_in (f, _) -> M.propagator f
| CF_out (f, _) -> M.propagator f
| CF_io (f, _, _) -> M.propagator f
+ | CF (f, c) ->
+ begin match c with
+ | CP.Flow _ | CP.Flow_with_Epsilons _ | CP.Flow_with_Epsilon_Bars _->
+ M.propagator f
+ | CP.Ghost | CP.Ghost_with_Epsilons _ | CP.Ghost_with_Epsilon_Bars _ ->
+ cf_aux_propagator (M.propagator f)
+ end
let width = pullback M.width
let goldstone = function
| White f ->
begin match M.goldstone f with
| None -> None
| Some (f', g) -> Some (White f', g)
end
| CF_in (f, c) ->
begin match M.goldstone f with
| None -> None
| Some (f', g) -> Some (CF_in (f', c), g)
end
| CF_out (f, c) ->
begin match M.goldstone f with
| None -> None
| Some (f', g) -> Some (CF_out (f', c), g)
end
| CF_io (f, c1, c2) ->
begin match M.goldstone f with
| None -> None
| Some (f', g) -> Some (CF_io (f', c1, c2), g)
end
| CF_aux f ->
begin match M.goldstone f with
| None -> None
| Some (f', g) -> Some (CF_aux f', g)
end
+ | CF (f, c) ->
+ begin match M.goldstone f with
+ | None -> None
+ | Some (f', g) -> Some (CF (f', c), g)
+ end
let conjugate = function
| White f -> White (M.conjugate f)
| CF_in (f, c) -> CF_out (M.conjugate f, c)
| CF_out (f, c) -> CF_in (M.conjugate f, c)
| CF_io (f, c1, c2) -> CF_io (M.conjugate f, c2, c1)
| CF_aux f -> CF_aux (M.conjugate f)
+ | CF (f, c) -> CF (M.conjugate f, CP.conjugate c)
let conjugate_sans_color = M.conjugate
let fermion = pullback M.fermion
let max_degree = M.max_degree
let flavors () =
invalid "flavors"
let external_flavors () =
invalid "external_flavors"
let parameters = M.parameters
let split_color_string s =
try
let i1 = String.index s '/' in
let i2 = String.index_from s (succ i1) '/' in
let sf = String.sub s 0 i1
and sc1 = String.sub s (succ i1) (i2 - i1 - 1)
and sc2 = String.sub s (succ i2) (String.length s - i2 - 1) in
(sf, sc1, sc2)
with
| Not_found -> (s, "", "")
let flavor_of_string s =
try
let sf, sc1, sc2 = split_color_string s in
let f = M.flavor_of_string sf in
match M.color f with
| C.Singlet -> White f
| C.SUN nc ->
if nc > 0 then
CF_in (f, color_flow_of_string sc1)
else
CF_out (f, color_flow_of_string sc2)
| C.AdjSUN _ ->
begin match sc1, sc2 with
| "", "" -> CF_aux f
| _, _ -> CF_io (f, color_flow_of_string sc1, color_flow_of_string sc2)
end
+ | C.YT _ | C.YTC _ ->
+ incomplete "flavor_of_string: Young tableaux"
with
| Failure s ->
if s = "int_of_string" then
invalid_arg "Colorize().flavor_of_string: expecting integer"
else
failwith ("Colorize().flavor_of_string: unexpected Failure(" ^ s ^ ")")
let flavor_to_string = function
| White f ->
M.flavor_to_string f
| CF_in (f, c) ->
M.flavor_to_string f ^ "/" ^ string_of_int c ^ "/"
| CF_out (f, c) ->
M.flavor_to_string f ^ "//" ^ string_of_int c
| CF_io (f, c1, c2) ->
M.flavor_to_string f ^ "/" ^ string_of_int c1 ^ "/" ^ string_of_int c2
| CF_aux f ->
- M.flavor_to_string f ^ "//"
-
+ M.flavor_to_string f ^ "//"
+ | CF (f, cp) ->
+ M.flavor_to_string f ^ "/" ^ CP.to_string cp
+
+ (* \begin{dubious}
+ [CP.to_string] need to be replaced!
+ \end{dubious} *)
let flavor_to_TeX = function
| White f ->
M.flavor_to_TeX f
| CF_in (f, c) ->
"{" ^ M.flavor_to_TeX f ^ "}_{\\mathstrut " ^ string_of_int c ^ "}"
| CF_out (f, c) ->
"{" ^ M.flavor_to_TeX f ^ "}_{\\mathstrut\\overline{" ^
string_of_int c ^ "}}"
| CF_io (f, c1, c2) ->
"{" ^ M.flavor_to_TeX f ^ "}_{\\mathstrut " ^
string_of_int c1 ^ "\\overline{" ^ string_of_int c2 ^ "}}"
| CF_aux f ->
"{" ^ M.flavor_to_TeX f ^ "}_{\\mathstrut 0}"
+ | CF (f, cp) ->
+ "{" ^ M.flavor_to_TeX f ^ "}_{\\mathstrut " ^ CP.to_string cp ^ "}"
let flavor_symbol = function
| White f ->
- M.flavor_symbol f
+ "f" ^ M.flavor_symbol f
| CF_in (f, c) ->
- M.flavor_symbol f ^ "_" ^ string_of_int c ^ "_"
+ "f" ^ M.flavor_symbol f ^ "_i" ^ string_of_int c
| CF_out (f, c) ->
- M.flavor_symbol f ^ "__" ^ string_of_int c
+ "f" ^ M.flavor_symbol f ^ "_o" ^ string_of_int c
| CF_io (f, c1, c2) ->
- M.flavor_symbol f ^ "_" ^ string_of_int c1 ^ "_" ^ string_of_int c2
+ "f" ^ M.flavor_symbol f ^ "_i" ^ string_of_int c1 ^ "o" ^ string_of_int c2
| CF_aux f ->
- M.flavor_symbol f ^ "__"
+ "f" ^ M.flavor_symbol f ^ "_g"
+ | CF (f, cp) ->
+ "f" ^ M.flavor_symbol f ^ "_" ^ CP.to_symbol cp
let gauge_symbol = M.gauge_symbol
(* Masses and widths must not depend on the colors anyway! *)
let mass_symbol = pullback M.mass_symbol
let width_symbol = pullback M.width_symbol
let constant_symbol = M.constant_symbol
(* \thocwmodulesubsection{Vertices} *)
(* [vertices] are \emph{only} used by functor applications and
for indexing a cache of precomputed fusion rules, which is not
used for colorized models. *)
let vertices () =
invalid "vertices"
module Legacy = Legacy_Implementation (M)
let colorize_fusion2 f1 f2 (f, v) =
match v with
| V3 _ -> Legacy.colorize_fusion2 f1 f2 (f, v)
| _ -> []
let colorize_fusion3 f1 f2 f3 (f, v) =
match v with
| V4 _ -> Legacy.colorize_fusion3 f1 f2 f3 (f, v)
| _ -> []
(* In order to match the \emph{correct} positions of the fields
in the vertices, we have to undo the permutation effected by
the fusion according to [Coupling.fusen]. *)
module PosMap =
Partial.Make (struct type t = int let compare = compare end)
(* Note that due to the [inverse], the list [l'] can be
interpreted here as a map reshuffling the indices.
E.\,g., [inverse (Permutation.Default.list [2;0;1])]
applied to [[1;2;3]] gives [[3;1;2]]. *)
let partial_map_redoing_permutation l l' =
let module P = Permutation.Default in
let p = P.inverse (P.of_list (List.map pred l')) in
PosMap.of_lists l (P.list p l)
(* Note that, the list [l'] can not be
interpreted as a map reshuffling the indices,
but gives the new order of the argument.
E.\,g., [Permutation.Default.list [2;0;1]]
applied to [[1;2;3]] gives [[2;3;1]]. *)
let partial_map_undoing_permutation l l' =
let module P = Permutation.Default in
let p = P.of_list (List.map pred l') in
PosMap.of_lists l (P.list p l)
- module CA = Color.Arrow
- module CV = Color.Vertex
- module CP = Color.Propagator
-
let color_sans_flavor = function
- | White _ -> CP.W
- | CF_in (_, cfi) -> CP.I cfi
- | CF_out (_, cfo) -> CP.O cfo
- | CF_io (_, cfi, cfo) -> CP.IO (cfi, cfo)
- | CF_aux _ -> CP.G
+ | White _ -> CP.white
+ | CF_in (_, cfi) -> CP.of_lists [cfi] []
+ | CF_out (_, cfo) -> CP.of_lists [] [cfo]
+ | CF_io (_, cfi, cfo) -> CP.of_lists [cfi] [cfo]
+ | CF_aux _ -> CP.Ghost
+ | CF (f, cp) -> cp
+
+ (* \begin{dubious}
+ Should we continue to translate the flows back and forth?
+ \end{dubious} *)
let color_with_flavor f = function
- | CP.W -> White f
- | CP.I cfi -> CF_in (f, cfi)
- | CP.O cfo -> CF_out (f, cfo)
- | CP.IO (cfi, cfo) -> CF_io (f, cfi, cfo)
- | CP.G -> CF_aux f
+ | CP.Flow (cfis, cfos) as cp ->
+ begin match PArray.to_option_list cfis, PArray.to_option_list cfos with
+ | [], [] -> White f
+ | [Some cfi], [] -> CF_in (f, cfi)
+ | [], [Some cfo] -> CF_out (f, cfo)
+ | [Some cfi], [Some cfo] -> CF_io (f, cfi, cfo)
+ | _, _ -> CF (f, cp)
+ end
+ | CP.Flow_with_Epsilons (_, _) ->
+ failwith "Colorize.color_with_flavor: unexpected epsilon"
+ | CP.Flow_with_Epsilon_Bars (_, _) ->
+ failwith "Colorize.color_with_flavor: unexpected epsilon bar"
+ | CP.Ghost -> CF_aux f
+ | CP.Ghost_with_Epsilons _ ->
+ failwith "Colorize.color_with_flavor: unexpected epsilon"
+ | CP.Ghost_with_Epsilon_Bars _ ->
+ failwith "Colorize.color_with_flavor: unexpected epsilon bar"
let colorize vertex_list flavors f v =
List.map
(fun (coef, cf) -> (color_with_flavor f cf, cmult_vertex coef v))
- (CV.fuse (nc ()) vertex_list (List.map color_sans_flavor flavors))
+ (Color_Fusion.fuse (nc ()) vertex_list (List.map color_sans_flavor flavors))
let partial_map_undoing_fusen fusen =
partial_map_undoing_permutation
(ThoList.range 1 (List.length fusen))
fusen
let undo_permutation_of_fusen fusen =
PosMap.apply_with_fallback
(fun _ -> invalid_arg "permutation_of_fusen")
(partial_map_undoing_fusen fusen)
let colorize_fusionn_ufo flist f c v spins flines color fuse xtra =
- let v = Vn (UFO (c, v, spins, flines, Color.Vertex.one), fuse, xtra) in
+ let v = Vn (UFO (c, v, spins, flines, Birdtracks.one), fuse, xtra) in
let p = undo_permutation_of_fusen fuse in
- colorize (CV.relocate p color) flist f v
+ colorize (Birdtracks.relocate p color) flist f v
let colorize_fusionn flist (f, v) =
match v with
| Vn (UFO (c, v, spins, flines, color), fuse, xtra) ->
colorize_fusionn_ufo flist f c v spins flines color fuse xtra
| _ -> []
let fuse_list flist =
ThoList.flatmap
(colorize_fusionn flist)
(M.fuse (List.map flavor_sans_color flist))
let fuse2 f1 f2 =
List.rev_append
(fuse_list [f1; f2])
(ThoList.flatmap
(colorize_fusion2 f1 f2)
(M.fuse2
(flavor_sans_color f1)
(flavor_sans_color f2)))
let fuse3 f1 f2 f3 =
List.rev_append
(fuse_list [f1; f2; f3])
(ThoList.flatmap
(colorize_fusion3 f1 f2 f3)
(M.fuse3
(flavor_sans_color f1)
(flavor_sans_color f2)
(flavor_sans_color f3)))
let fuse = function
| [] | [_] -> invalid_arg "Colorize.It().fuse"
| [f1; f2] -> fuse2 f1 f2
| [f1; f2; f3] -> fuse3 f1 f2 f3
| flist -> fuse_list flist
let max_degree = M.max_degree
(* \thocwmodulesubsection{Adding Color to External Particles} *)
+(* Count the color strings in [f_list]: one incoming each quark and
+ gluon, one outgoing for each antiquark and gluon. Keep track
+ of the number of gluons separately. *)
+
+(* Count the number of color lines for a given combination of flavors,
+ assuming that the incoming lines have been crossed. Returns a
+ pair $(n_{\text{in}},n_{\text{out}})$, corresponding to the number
+ of incoming and outgoing lines respectively.
+ Note that the two lines of gluons are included
+ in~$n_{\text{in}}$ and~$n_{\text{out}}$. *)
+
let count_color_strings f_list =
- let rec count_color_strings' n_in n_out n_glue = function
+ let rec count_color_strings' n_in n_out = function
| f :: rest ->
begin match M.color f with
- | C.Singlet -> count_color_strings' n_in n_out n_glue rest
+ | C.Singlet -> count_color_strings' n_in n_out rest
| C.SUN nc ->
if nc > 0 then
- count_color_strings' (succ n_in) n_out n_glue rest
+ count_color_strings' (succ n_in) n_out rest
else if nc < 0 then
- count_color_strings' n_in (succ n_out) n_glue rest
+ count_color_strings' n_in (succ n_out) rest
else
su0 "count_color_strings"
| C.AdjSUN _ ->
- count_color_strings' (succ n_in) (succ n_out) (succ n_glue) rest
+ count_color_strings' (succ n_in) (succ n_out) rest
+ | C.YT y ->
+ count_color_strings' (Young.num_cells_tableau y + n_in) n_out rest
+ | C.YTC y ->
+ count_color_strings' n_in (Young.num_cells_tableau y + n_out) rest
end
- | [] -> (n_in, n_out, n_glue)
+ | [] -> (n_in, n_out)
in
- count_color_strings' 0 0 0 f_list
+ count_color_strings' 0 0 f_list
+
+(* Return a list of all permutations of outgoing color lines.
+ \begin{dubious}
+ Currently, this assumes that there are an equal number of
+ incoming and outgoing lines. This has to change, since we
+ want to support $\epsilon$- and $\bar\epsilon$-couplings that
+ act as sources and sinks of lines.
+ \end{dubious}
+ \begin{dubious}
+ For efficiency, we could check whether the model contains
+ $\epsilon$- or $\bar\epsilon$-couplings and produce only
+ conserved color lines if not.
+ \end{dubious}
+ \begin{dubious}
+ We can do even better if we add an optional parameter that
+ contains the number of $\epsilon$- and $\bar\epsilon$-couplings
+ appearing in the amplitude. This can be computed
+ from the still uncolorized [DAG.t] by the calling function.
+ \end{dubious} *)
+
+(* If there are an equal number of incoming and outgoing color strings,
+ generate all permutations, e.\,g.~for $n=2$ we get
+ [([1,2],[1,2]);([1,2],[2,1])]. *)
let external_color_flows f_list =
- let n_in, n_out, n_glue = count_color_strings f_list in
+ let n_in, n_out = count_color_strings f_list in
if n_in <> n_out then
[]
else
let color_strings = ThoList.range 1 n_in in
List.rev_map
(fun permutation -> (color_strings, permutation))
(Combinatorics.permute color_strings)
(* If there are only adjoints \emph{and} there are no couplings of
adjoints to singlets, we can ignore the $\mathrm{U}(1)$-ghosts. *)
let pure_adjoints f_list =
List.for_all (fun f -> match M.color f with C.AdjSUN _ -> true | _ -> false) f_list
let two_adjoints_couple_to_singlets () =
let vertices3, vertices4, verticesn = M.vertices () in
List.exists (fun ((f1, f2, f3), _, _) ->
match M.color f1, M.color f2, M.color f3 with
| C.AdjSUN _, C.AdjSUN _, C.Singlet
| C.AdjSUN _, C.Singlet, C.AdjSUN _
| C.Singlet, C.AdjSUN _, C.AdjSUN _ -> true
| _ -> false) vertices3 ||
List.exists (fun ((f1, f2, f3, f4), _, _) ->
match M.color f1, M.color f2, M.color f3, M.color f4 with
| C.AdjSUN _, C.AdjSUN _, C.Singlet, C.Singlet
| C.AdjSUN _, C.Singlet, C.AdjSUN _, C.Singlet
| C.Singlet, C.AdjSUN _, C.AdjSUN _, C.Singlet
| C.AdjSUN _, C.Singlet, C.Singlet, C.AdjSUN _
| C.Singlet, C.AdjSUN _, C.Singlet, C.AdjSUN _
| C.Singlet, C.Singlet, C.AdjSUN _, C.AdjSUN _ -> true
| _ -> false) vertices4 ||
List.exists (fun (flist, _, g) -> true) verticesn
+ (* [colorize_crossed_amplitude_opt ghosts flavors (cfi, cfo)] attempts to join the
+ [flavors] with the external color flow [(cfi, cfo)].
+ Includes $\mathrm{U}(1)$ ghosts iff [ghosts] is [true] (i.\,e.~iff there are
+ \emph{only} external gluons).
+ Note that, despite the name, this only maps the external states and not yet
+ the [DAG.t] describing the scattering amplitude. This will
+ happen in [Fusion] (chapter~\ref{sec:fusion}). *)
+
let external_ghosts f_list =
if pure_adjoints f_list then
two_adjoints_couple_to_singlets ()
else
true
-(* We use [List.hd] and [List.tl] instead of pattern matching, because we
- consume [ecf_in] and [ecf_out] at a different pace. *)
+ let snoc = function
+ | [] -> invalid_arg "Colorize.It().snoc: not enough color flow lines"
+ | a :: alist -> (a, alist)
- let tail_opt = function
- | [] -> []
- | _ :: tail -> tail
-
- let head_req = function
- | [] ->
- invalid_arg "Colorize.It().colorize_crossed_amplitude1: insufficient flows"
- | x :: _ -> x
+ let snoc_n n alist =
+ try
+ ThoList.splitn n alist
+ with
+ | Invalid_argument _ ->
+ invalid_arg "Colorize.It().snoc_n: not enough color flow lines"
- let rec colorize_crossed_amplitude1 ghosts acc f_list (ecf_in, ecf_out) =
+ let rec cca_opt ghosts acc f_list (ecf_in, ecf_out) =
match f_list, ecf_in, ecf_out with
- | [], [], [] -> [List.rev acc]
+ | [], [], [] -> Some (List.rev acc)
| [], _, _ ->
- invalid_arg "Colorize.It().colorize_crossed_amplitude1: leftover flows"
+ invalid_arg "Colorize.It().colorize_crossed_amplitude_opt: leftover color flow lines"
| f :: rest, _, _ ->
begin match M.color f with
- | C.Singlet ->
- colorize_crossed_amplitude1 ghosts
- (White f :: acc)
- rest (ecf_in, ecf_out)
+ | C.Singlet -> cca_opt ghosts (White f :: acc) rest (ecf_in, ecf_out)
| C.SUN nc ->
if nc > 0 then
- colorize_crossed_amplitude1 ghosts
- (CF_in (f, head_req ecf_in) :: acc)
- rest (tail_opt ecf_in, ecf_out)
+ let cfi, ecf_in = snoc ecf_in in
+ cca_opt ghosts (CF_in (f, cfi) :: acc) rest (ecf_in, ecf_out)
else if nc < 0 then
- colorize_crossed_amplitude1 ghosts
- (CF_out (f, head_req ecf_out) :: acc)
- rest (ecf_in, tail_opt ecf_out)
+ let cfo, ecf_out = snoc ecf_out in
+ cca_opt ghosts (CF_out (f, cfo) :: acc) rest (ecf_in, ecf_out)
else
su0 "colorize_flavor"
| C.AdjSUN _ ->
- let ecf_in' = head_req ecf_in
- and ecf_out' = head_req ecf_out in
- if ecf_in' = ecf_out' then begin
+ let cfi, ecf_in = snoc ecf_in
+ and cfo, ecf_out = snoc ecf_out in
+ if cfi = cfo then begin
if ghosts then
- colorize_crossed_amplitude1 ghosts
- (CF_aux f :: acc)
- rest (tail_opt ecf_in, tail_opt ecf_out)
+ cca_opt ghosts (CF_aux f :: acc) rest (ecf_in, ecf_out)
else
- []
+ None
end else
- colorize_crossed_amplitude1 ghosts
- (CF_io (f, ecf_in', ecf_out') :: acc)
- rest (tail_opt ecf_in, tail_opt ecf_out)
+ cca_opt ghosts (CF_io (f, cfi, cfo) :: acc) rest (ecf_in, ecf_out)
+ | C.YT y ->
+ let cfi, ecf_in = snoc_n (Young.num_cells_tableau y) ecf_in in
+ cca_opt ghosts (CF (f, CP.of_lists cfi []) :: acc) rest (ecf_in, ecf_out)
+ | C.YTC y ->
+ let cfo, ecf_out = snoc_n (Young.num_cells_tableau y) ecf_out in
+ cca_opt ghosts (CF (f, CP.of_lists [] cfo) :: acc) rest (ecf_in, ecf_out)
end
- let colorize_crossed_amplitude1 ghosts f_list (ecf_in, ecf_out) =
- colorize_crossed_amplitude1 ghosts [] f_list (ecf_in, ecf_out)
+ let colorize_crossed_amplitude_opt ghosts f_list (ecf_in, ecf_out) =
+ cca_opt ghosts [] f_list (ecf_in, ecf_out)
let colorize_crossed_amplitude f_list =
- ThoList.rev_flatmap
- (colorize_crossed_amplitude1 (external_ghosts f_list) f_list)
- (external_color_flows f_list)
+ let ghosts = external_ghosts f_list in
+ List.fold_left
+ (fun ca_list ecf ->
+ match colorize_crossed_amplitude_opt ghosts f_list ecf with
+ | None -> ca_list
+ | Some ca -> ca :: ca_list)
+ [] (external_color_flows f_list)
+
+ let colorize_crossed_amplitude_logging f_list =
+ let amplitudes = colorize_crossed_amplitude f_list in
+ List.iter (fun a -> Printf.eprintf "%s\n" (ThoList.to_string flavor_to_string a)) amplitudes;
+ amplitudes
let cross_uncolored p_in p_out =
(List.map M.conjugate p_in) @ p_out
let uncross_colored n_in p_lists_colorized =
let p_in_out_colorized = List.map (ThoList.splitn n_in) p_lists_colorized in
List.map
(fun (p_in_colored, p_out_colored) ->
(List.map conjugate p_in_colored, p_out_colored))
p_in_out_colorized
let amplitude p_in p_out =
uncross_colored
(List.length p_in)
(colorize_crossed_amplitude (cross_uncolored p_in p_out))
(* The $-$-sign in the second component is redundant, but a Whizard convention. *)
+
+ (* \begin{dubious}
+ The case [CF (f, cp)] needs to be handled properly!
+ \end{dubious} *)
let indices = function
| White _ -> Color.Flow.of_list [0; 0]
| CF_in (_, c) -> Color.Flow.of_list [c; 0]
| CF_out (_, c) -> Color.Flow.of_list [0; -c]
| CF_io (_, c1, c2) -> Color.Flow.of_list [c1; -c2]
- | CF_aux f -> Color.Flow.ghost ()
+ | CF_aux _ -> Color.Flow.ghost ()
+ | CF (f, cp) ->
+ Printf.eprintf
+ "Colorize.indices: color flow `%s' not handled yet\n"
+ (CP.to_string cp);
+ Color.Flow.of_list [-42; -42]
let flow p_in p_out =
(List.map indices p_in, List.map indices p_out)
end
(* \thocwmodulesection{Colorizing a Monochrome Gauge Model} *)
module Gauge (M : Model.Gauge) =
struct
module CM = It(M)
type flavor = CM.flavor
type flavor_sans_color = CM.flavor_sans_color
type gauge = CM.gauge
type constant = CM.constant
+ type coupling_order = CM.coupling_order
module Ch = CM.Ch
+ let all_coupling_orders = CM.all_coupling_orders
+ let coupling_orders = CM.coupling_orders
+ let coupling_order_to_string = CM.coupling_order_to_string
let charges = CM.charges
let flavor_sans_color = CM.flavor_sans_color
+ let flavor_equal = CM.flavor_equal
let color = CM.color
let pdg = CM.pdg
let lorentz = CM.lorentz
let propagator = CM.propagator
let width = CM.width
let conjugate = CM.conjugate
let conjugate_sans_color = CM.conjugate_sans_color
let fermion = CM.fermion
let max_degree = CM.max_degree
let vertices = CM.vertices
let fuse2 = CM.fuse2
let fuse3 = CM.fuse3
let fuse = CM.fuse
let flavors = CM.flavors
let nc = CM.nc
let external_flavors = CM.external_flavors
let goldstone = CM.goldstone
let parameters = CM.parameters
let flavor_of_string = CM.flavor_of_string
let flavor_to_string = CM.flavor_to_string
let flavor_to_TeX = CM.flavor_to_TeX
let flavor_symbol = CM.flavor_symbol
let gauge_symbol = CM.gauge_symbol
let mass_symbol = CM.mass_symbol
let width_symbol = CM.width_symbol
let constant_symbol = CM.constant_symbol
let options = CM.options
let caveats = CM.caveats
let incomplete s =
failwith ("Colorize.Gauge()." ^ s ^ " not done yet!")
type matter_field = M.matter_field
type gauge_boson = M.gauge_boson
type other = M.other
type field =
| Matter of matter_field
| Gauge of gauge_boson
| Other of other
let field f =
incomplete "field"
let matter_field f =
incomplete "matter_field"
let gauge_boson f =
incomplete "gauge_boson"
let other f =
incomplete "other"
let amplitude = CM.amplitude
let flow = CM.flow
end
Index: trunk/omega/src/modellib_BSM.ml
===================================================================
--- trunk/omega/src/modellib_BSM.ml (revision 8899)
+++ trunk/omega/src/modellib_BSM.ml (revision 8900)
@@ -1,15261 +1,15309 @@
(* modellib_BSM.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
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. *)
(* \thocwmodulesection{Littlest Higgs Model} *)
module type BSM_flags =
sig
val u1_gauged : bool
val anom_ferm_ass : bool
end
module BSM_bsm : BSM_flags =
struct
let u1_gauged = true
let anom_ferm_ass = false
end
module BSM_ungauged : BSM_flags =
struct
let u1_gauged = false
let anom_ferm_ass = false
end
module BSM_anom : BSM_flags =
struct
let u1_gauged = false
let anom_ferm_ass = true
end
module Littlest (Flags : BSM_flags) =
struct
open Coupling
let default_width = ref Timelike
let use_fudged_width = ref false
let options = Options.create
[ "constant_width", Arg.Unit (fun () -> default_width := Constant),
"use constant width (also in t-channel)";
"fudged_width", Arg.Set use_fudged_width,
"use fudge factor for charge particle width";
"custom_width", Arg.String (fun f -> default_width := Custom f),
"use custom width";
"cancel_widths", Arg.Unit (fun () -> default_width := Vanishing),
"use vanishing width";
"cms_width", Arg.Unit (fun () -> default_width := Complex_Mass),
"use complex mass scheme" ;
"running_width", Arg.Unit (fun () -> default_width := Running),
"use running width" ]
let caveats () = []
let gauge_symbol () =
failwith "Modellib_BSM.Littlest.gauge_symbol: internal error"
type matter_field = L of int | N of int | U of int | D of int
| TopH | TopHb
type gauge_boson = Ga | Wp | Wm | Z | Gl | WHp | WHm
| ZH | AH
type other = Phip | Phim | Phi0 | H | Eta | Psi0
| Psi1 | Psip | Psim | Psipp | Psimm
type flavor = M of matter_field | G of gauge_boson | O of other
let matter_field f = M f
let gauge_boson f = G f
let other f = O f
type field =
| Matter of matter_field
| Gauge of gauge_boson
| Other of other
let field = function
| M f -> Matter f
| G f -> Gauge f
| O f -> Other f
type gauge = unit
let gauge_symbol () =
failwith "Modellib_BSM.Littlest.gauge_symbol: internal error"
let family n = List.map matter_field [ L n; N n; U n; D n ]
(* Since [Phi] already belongs to the EW Goldstone bosons we use [Psi]
for the TeV scale complex triplet. *)
let external_flavors () =
[ "1st Generation", ThoList.flatmap family [1; -1];
"2nd Generation", ThoList.flatmap family [2; -2];
"3rd Generation", ThoList.flatmap family [3; -3];
"Heavy Quarks", List.map matter_field [TopH; TopHb];
"Heavy Scalars", List.map other
[Psi0; Psi1; Psip; Psim; Psipp; Psimm];
"Gauge Bosons", List.map gauge_boson
(if Flags.u1_gauged then
[Ga; Z; Wp; Wm; Gl; WHp; WHm; ZH; AH]
else
[Ga; Z; Wp; Wm; Gl; WHp; WHm; ZH]);
"Higgs", List.map other
(if Flags.u1_gauged then [H]
else [H; Eta]);
"Goldstone Bosons", List.map other [Phip; Phim; Phi0] ]
let flavors () = ThoList.flatmap snd (external_flavors ())
let spinor n =
if n >= 0 then
Spinor
else
ConjSpinor
let lorentz = function
| M f ->
begin match f with
| L n -> spinor n | N n -> spinor n
| U n -> spinor n | D n -> spinor n
| TopH -> Spinor | TopHb -> ConjSpinor
end
| G f ->
begin match f with
| Ga | Gl -> Vector
| Wp | Wm | Z | WHp | WHm | ZH | AH -> Massive_Vector
end
| O f ->
begin match f with
| Phip | Phim | Phi0 | H | Eta | Psi0
| Psi1 | Psip | Psim | Psipp | Psimm -> Scalar
end
- let color = function
+ let color = function
| M (U n) -> Color.SUN (if n > 0 then 3 else -3)
| M (D n) -> Color.SUN (if n > 0 then 3 else -3)
| M TopH -> Color.SUN 3 | M TopHb -> Color.SUN (-3)
| G Gl -> Color.AdjSUN 3
| _ -> Color.Singlet
let nc () = 3
let prop_spinor n =
if n >= 0 then
Prop_Spinor
else
Prop_ConjSpinor
let propagator = function
| M f ->
begin match f with
| L n -> prop_spinor n | N n -> prop_spinor n
| U n -> prop_spinor n | D n -> prop_spinor n
| TopH -> Prop_Spinor | TopHb -> Prop_ConjSpinor
end
| G f ->
begin match f with
| Ga | Gl -> Prop_Feynman
| Wp | Wm | Z | WHp | WHm | ZH | AH -> Prop_Unitarity
end
| O f ->
begin match f with
| Phip | Phim | Phi0 -> Only_Insertion
| H | Eta | Psi0 | Psi1 | Psip | Psim
| Psipp | Psimm -> Prop_Scalar
end
(* Optionally, ask for the fudge factor treatment for the widths of
charged particles. Currently, this only applies to $W^\pm$ and top. *)
let width f =
if !use_fudged_width then
match f with
| G Wp | G Wm | M (U 3) | M (U (-3))
| G WHp | G WHm | G ZH | G AH
| M TopH | M TopHb -> Fudged
| _ -> !default_width
else
!default_width
let goldstone = function
| G f ->
begin match f with
| Wp -> Some (O Phip, Coupling.Integer 1)
| Wm -> Some (O Phim, Coupling.Integer 1)
| Z -> Some (O Phi0, Coupling.Integer 1)
| _ -> None
end
| _ -> None
let conjugate = function
| M f ->
M (begin match f with
| L n -> L (-n) | N n -> N (-n)
| U n -> U (-n) | D n -> D (-n)
| TopH -> TopHb | TopHb -> TopH
end)
| G f ->
G (begin match f with
| Gl -> Gl | Ga -> Ga | Z -> Z
| Wp -> Wm | Wm -> Wp | WHm -> WHp
| WHp -> WHm | ZH -> ZH | AH -> AH
end)
| O f ->
O (begin match f with
| Psi0 -> Psi0 | Psi1 -> Psi1 | Psip -> Psim
| Psim -> Psip | Psipp -> Psimm | Psimm -> Psipp
| Phip -> Phim | Phim -> Phip | Phi0 -> Phi0
| H -> H | Eta -> Eta
end)
let fermion = function
| M f ->
begin match f with
| L n -> if n > 0 then 1 else -1
| N n -> if n > 0 then 1 else -1
| U n -> if n > 0 then 1 else -1
| D n -> if n > 0 then 1 else -1
| TopH -> 1 | TopHb -> -1
end
| G f ->
begin match f with
| Gl | Ga | Z | Wp | Wm | WHp
| WHm | AH | ZH -> 0
end
| O f ->
begin match f with
| Psi0 | Psi1 | Psip | Psim | Psipp | Psimm
| Phip | Phim | Phi0 | H | Eta -> 0
end
(* This model does NOT have a conserved generation charge
even in absence of CKM mixing because of the heavy top
admixture. *)
module Ch = Charges.QQ
let ( // ) = Algebra.Small_Rational.make
let charge = function
| M f ->
begin match f with
| L n -> if n > 0 then -1//1 else 1//1
| N n -> 0//1
| U n -> if n > 0 then 2//3 else -2//3
| D n -> if n > 0 then -1//3 else 1//3
| TopH -> 2//3
| TopHb -> -2//3
end
| G f ->
begin match f with
| Gl | Ga | Z | AH | ZH -> 0//1
| Wp | WHp -> 1//1
| Wm | WHm -> -1//1
end
| O f ->
begin match f with
| H | Phi0 | Eta | Psi1 | Psi0 -> 0//1
| Phip | Psip -> 1//1
| Phim | Psim -> -1//1
| Psipp -> 2//1
| Psimm -> -2//1
end
let lepton = function
| M f ->
begin match f with
| L n | N n -> if n > 0 then 1//1 else -1//1
| U _ | D _ | _ -> 0//1
end
| G _ | O _ -> 0//1
let baryon = function
| M f ->
begin match f with
| L _ | N _ -> 0//1
| U n | D n -> if n > 0 then 1//1 else -1//1
| TopH -> 1//1
| TopHb -> -1//1
end
| G _ | O _ -> 0//1
let charges f =
[ charge f; lepton f; baryon f]
type constant =
| Unit | Pi | Alpha_QED | Sin2thw
| Sinthw | Costhw | E | G_weak | Vev | VHeavy
| Supp | Supp2
| Sinpsi | Cospsi | Atpsi | Sccs (* Mixing angles of SU(2) *)
| Q_lepton | Q_up | Q_down | Q_Z_up | G_CC | G_CCtop
| G_NC_neutrino | G_NC_lepton | G_NC_up | G_NC_down | G_NC_heavy
| G_NC_h_neutrino | G_NC_h_lepton | G_NC_h_up | G_NC_h_down
| G_CC_heavy | G_ZHTHT | G_ZTHT | G_AHTHTH | G_AHTHT | G_AHTT
| G_CC_WH | G_CC_W
| I_Q_W | I_G_ZWW | I_G_WWW
| I_G_AHWW | I_G_ZHWW | I_G_ZWHW | I_G_AHWHWH | I_G_ZHWHWH
| I_G_AHWHW | I_Q_H
| G_WWWW | G_ZZWW | G_AZWW | G_AAWW
| G_WH4 | G_WHWHWW | G_WHWWW | G_WH3W
| G_WWAAH | G_WWAZH | G_WWZZH | G_WWZAH | G_WHWHAAH
| G_WHWHAZH | G_WHWHZZH | G_WHWHZAH | G_WWZHAH
| G_WHWHZHAH | G_WHWZZ | G_WHWAZ | G_WHWAAH | G_WHWZAH
| G_WHWZHZH | G_WHWZHAH | G_WHWAZH | G_WHWZZH
| G_HWW | G_HHWW | G_HZZ | G_HHZZ
| G_PsiWW | G_PsiWHW | G_PsiZZ | G_PsiZHZH
| G_PsiZHZ | G_PsiZAH | G_PsiZHAH | G_PsiAHAH
| G_PsiZW | G_PsiZWH | G_PsiAHW | G_PsiAHWH
| G_PsiZHW | G_PsiZHWH
| G_PsippWW | G_PsippWHW | G_PsippWHWH
| G_PsiHW | G_PsiHWH | G_Psi0W | G_Psi0WH
| G_Psi1W | G_Psi1WH | G_PsiPPW | G_PsiPPWH
| G_Psi1HAH | G_Psi01AH | G_AHPsip | G_Psi1HZ
| G_Psi1HZH | G_Psi01Z | G_Psi01ZH | G_ZPsip | G_ZPsipp | G_ZHPsipp
| G_HHAA | G_HHWHW | G_HHZHZ | G_HHAHZ | G_HHZHAH
| G_HPsi0WW | G_HPsi0WHW | G_HPsi0ZZ
| G_HPsi0ZHZH | G_HPsi0ZHZ | G_HPsi0AHAH | G_HPsi0ZAH | G_HPsi0ZHAH
| G_HPsipWA | G_HPsipWHA | G_HPsipWZ | G_HPsipWHZ | G_HPsipWAH
| G_HPsipWHAH | G_HPsipWZH | G_HPsipWHZH | G_HPsippWW | G_HPsippWHWH
| G_HPsippWHW | G_Psi00ZH | G_Psi00AH | G_Psi00ZHAH
| G_Psi0pWA | G_Psi0pWHA | G_Psi0pWZ | G_Psi0pWHZ | G_Psi0pWAH
| G_Psi0pWHAH | G_Psi0pWZH | G_Psi0pWHZH | G_Psi0ppWW | G_Psi0ppWHWH
| G_Psi0ppWHW | I_G_Psi0pWA | I_G_Psi0pWHA | I_G_Psi0pWZ | I_G_Psi0pWHZ
| I_G_Psi0pWAH | I_G_Psi0pWHAH | I_G_Psi0pWZH | I_G_Psi0pWHZH
| I_G_Psi0ppWW | I_G_Psi0ppWHWH | I_G_Psi0ppWHW
| G_PsippZZ | G_PsippZHZH | G_PsippAZ | G_PsippAAH | G_PsippZAH
| G_PsippWA | G_PsippWHA | G_PsippWZ | G_PsippWHZ | G_PsippWAH
| G_PsippWHAH | G_PsippWZH | G_PsippWHZH
| G_PsiccZZ | G_PsiccAZ | G_PsiccAAH | G_PsiccZZH | G_PsiccAZH
| G_PsiccZAH
| G_Htt | G_Hbb | G_Hcc | G_Htautau | G_H3 | G_H4
| G_Hthth | G_Htht | G_Ethth | G_Etht | G_Ett
| G_HHtt | G_HHthth | G_HHtht
| G_Psi0tt | G_Psi0bb | G_Psi0cc | G_Psi0tautau
| G_Psi1tt | G_Psi1bb | G_Psi1cc | G_Psi1tautau
| G_Psipq3 | G_Psipq2 | G_Psipl3 | G_Psi0tth | G_Psi1tth
| G_Psipbth | G_Ebb
| G_HGaGa | G_HGaZ | G_EGaGa | G_EGaZ | G_EGlGl
| Gs | I_Gs | G2
| G_HWHW | G_HWHWH | G_HAHAH | G_HZHZ | G_HZHAH | G_HAHZ
| Mass of flavor | Width of flavor
(* Two integer counters for the QCD and EW order of the couplings. *)
- type orders = int * int
+ type coupling_order = QCD | EW
+ let all_coupling_orders () = [QCD; EW]
+ let coupling_order_to_string = function
+ | QCD -> "QCD"
+ | EW -> "EW"
- let orders = function
- | _ -> (0,0)
+ let coupling_orders = function
+ | _ -> failwith "Modellib_BSM.Littlest.orders: not implemented yet!"
let input_parameters =
[]
let derived_parameters =
[]
let g_over_2_costh =
Quot (Neg (Atom G_weak), Prod [Integer 2; Atom Costhw])
let nc_coupling c t3 q =
(Real_Array c,
[Prod [g_over_2_costh; Diff (t3, Prod [Integer 2; q; Atom Sin2thw])];
Prod [g_over_2_costh; t3]])
let half = Quot (Integer 1, Integer 2)
let derived_parameter_arrays =
[ nc_coupling G_NC_neutrino half (Integer 0);
nc_coupling G_NC_lepton (Neg half) (Integer (-1));
nc_coupling G_NC_up half (Quot (Integer 2, Integer 3));
nc_coupling G_NC_down (Neg half) (Quot (Integer (-1), Integer 3));
nc_coupling G_NC_h_neutrino half (Integer 0);
nc_coupling G_NC_h_lepton (Neg half) (Integer (-1));
nc_coupling G_NC_h_up half (Quot (Integer 2, Integer 3));
nc_coupling G_NC_h_down (Neg half) (Quot (Integer (-1), Integer 3)) ]
let parameters () =
{ input = input_parameters;
derived = derived_parameters;
derived_arrays = derived_parameter_arrays }
module F = Modeltools.Fusions (struct
type f = flavor
type c = constant
let compare = compare
let conjugate = conjugate
end)
let mgm ((m1, g, m2), fbf, c) = ((M m1, G g, M m2), fbf, c)
let mhm ((m1, h, m2), fbf, c) = ((M m1, O h, M m2), fbf, c)
let tgc ((g1, g2, g3), t, c) = ((G g1, G g2, G g3), t, c)
let qgc ((g1, g2, g3, g4), t, c) = ((G g1, G g2, G g3, G g4), t, c)
let hgg ((h, g1, g2), coup, c) = ((O h, G g1, G g2), coup, c)
let ghh ((g, h1, h2), coup, c) = ((G g, O h1, O h2), coup, c)
let hhgg ((h1, h2, g1, g2), coup, c) = ((O h1, O h2, G g1, G g2), coup, c)
let electromagnetic_currents n =
List.map mgm
[ ((L (-n), Ga, L n), FBF (1, Psibar, V, Psi), Q_lepton);
((U (-n), Ga, U n), FBF (1, Psibar, V, Psi), Q_up);
((D (-n), Ga, D n), FBF (1, Psibar, V, Psi), Q_down) ]
let neutral_currents n =
List.map mgm
[ ((L (-n), Z, L n), FBF (1, Psibar, VA, Psi), G_NC_lepton);
((N (-n), Z, N n), FBF (1, Psibar, VA, Psi), G_NC_neutrino);
((U (-n), Z, U n), FBF (1, Psibar, VA, Psi), G_NC_up);
((D (-n), Z, D n), FBF (1, Psibar, VA, Psi), G_NC_down) ]
(* The sign of this coupling is just the one of the T3, being -(1/2) for
leptons and down quarks, and +(1/2) for neutrinos and up quarks. *)
let neutral_heavy_currents n =
List.map mgm
([ ((L (-n), ZH, L n), FBF ((-1), Psibar, VL, Psi), G_NC_heavy);
((N (-n), ZH, N n), FBF (1, Psibar, VL, Psi), G_NC_heavy);
((U (-n), ZH, U n), FBF (1, Psibar, VL, Psi), G_NC_heavy);
((D (-n), ZH, D n), FBF ((-1), Psibar, VL, Psi), G_NC_heavy)]
@
(if Flags.u1_gauged then
[ ((L (-n), AH, L n), FBF (1, Psibar, VA, Psi), G_NC_h_lepton);
((N (-n), AH, N n), FBF (1, Psibar, VA, Psi), G_NC_h_neutrino);
((D (-n), AH, D n), FBF (1, Psibar, VA, Psi), G_NC_h_down)]
else
[]))
let color_currents n =
List.map mgm
[ ((D (-n), Gl, D n), FBF ((-1), Psibar, V, Psi), Gs);
((U (-n), Gl, U n), FBF ((-1), Psibar, V, Psi), Gs)]
let heavy_top_currents =
List.map mgm
([ ((TopHb, Ga, TopH), FBF (1, Psibar, V, Psi), Q_up);
((TopHb, Z, TopH), FBF (1, Psibar, V, Psi), Q_Z_up);
((TopHb, Gl, TopH), FBF (1, Psibar, V, Psi), Gs);
((TopHb, Z, U 3), FBF (1, Psibar, VL, Psi), G_ZTHT);
((U (-3), Z, TopH), FBF (1, Psibar, VL, Psi), G_ZTHT);
((TopHb, ZH, U 3), FBF (1, Psibar, VL, Psi), G_ZHTHT);
((U (-3), ZH, TopH), FBF (1, Psibar, VL, Psi), G_ZHTHT);
((U (-3), Wp, D 3), FBF (1, Psibar, VL, Psi), G_CCtop);
((D (-3), Wm, U 3), FBF (1, Psibar, VL, Psi), G_CCtop);
((TopHb, WHp, D 3), FBF (1, Psibar, VL, Psi), G_CC_WH);
((D (-3), WHm, TopH), FBF (1, Psibar, VL, Psi), G_CC_WH);
((TopHb, Wp, D 3), FBF (1, Psibar, VL, Psi), G_CC_W);
((D (-3), Wm, TopH), FBF (1, Psibar, VL, Psi), G_CC_W)]
@
(if Flags.u1_gauged then
[ ((U (-3), AH, U 3), FBF (1, Psibar, VA, Psi), G_AHTT);
((TopHb, AH, TopH), FBF (1, Psibar, VA, Psi), G_AHTHTH);
((TopHb, AH, U 3), FBF (1, Psibar, VR, Psi), G_AHTHT);
((U (-3), AH, TopH), FBF (1, Psibar, VR, Psi), G_AHTHT)]
else
[]))
(* \begin{equation}
\mathcal{L}_{\textrm{CC}} =
- \frac{g}{2\sqrt2} \sum_i \bar\psi_i
(T^+\fmslash{W}^+ + T^-\fmslash{W}^-)(1-\gamma_5)\psi_i
\end{equation} *)
let charged_currents n =
List.map mgm
[ ((L (-n), Wm, N n), FBF (1, Psibar, VL, Psi), G_CC);
((N (-n), Wp, L n), FBF (1, Psibar, VL, Psi), G_CC);
((D (-n), Wm, U n), FBF (1, Psibar, VL, Psi), G_CC);
((U (-n), Wp, D n), FBF (1, Psibar, VL, Psi), G_CC) ]
let charged_heavy_currents n =
List.map mgm
([ ((L (-n), WHm, N n), FBF (1, Psibar, VL, Psi), G_CC_heavy);
((N (-n), WHp, L n), FBF (1, Psibar, VL, Psi), G_CC_heavy);
((D (-n), WHm, U n), FBF (1, Psibar, VL, Psi), G_CC_heavy);
((U (-n), WHp, D n), FBF (1, Psibar, VL, Psi), G_CC_heavy)]
@
(if Flags.u1_gauged then
[ ((U (-n), AH, U n), FBF (1, Psibar, VA, Psi), G_NC_h_up)]
else
[]))
(* We specialize the third generation since there is an additional shift
coming from the admixture of the heavy top quark. The universal shift,
coming from the mixing in the non-Abelian gauge boson sector is
unobservable. (Redefinition of coupling constants by measured ones. *)
let yukawa =
List.map mhm
[ ((U (-3), H, U 3), FBF (1, Psibar, S, Psi), G_Htt);
((D (-3), H, D 3), FBF (1, Psibar, S, Psi), G_Hbb);
((U (-2), H, U 2), FBF (1, Psibar, S, Psi), G_Hcc);
((L (-3), H, L 3), FBF (1, Psibar, S, Psi), G_Htautau)]
let yukawa_add' =
List.map mhm
[ ((TopHb, H, TopH), FBF (1, Psibar, S, Psi), G_Hthth);
((TopHb, H, U 3), FBF (1, Psibar, SLR, Psi), G_Htht);
((U (-3), H, TopH), FBF (1, Psibar, SLR, Psi), G_Htht);
((U (-3), Psi0, U 3), FBF (1, Psibar, S, Psi), G_Psi0tt);
((D (-3), Psi0, D 3), FBF (1, Psibar, S, Psi), G_Psi0bb);
((U (-2), Psi0, U 2), FBF (1, Psibar, S, Psi), G_Psi0cc);
((L (-3), Psi0, L 3), FBF (1, Psibar, S, Psi), G_Psi0tautau);
((U (-3), Psi1, U 3), FBF (1, Psibar, P, Psi), G_Psi1tt);
((D (-3), Psi1, D 3), FBF (1, Psibar, P, Psi), G_Psi1bb);
((U (-2), Psi1, U 2), FBF (1, Psibar, P, Psi), G_Psi1cc);
((L (-3), Psi1, L 3), FBF (1, Psibar, P, Psi), G_Psi1tautau);
((U (-3), Psip, D 3), FBF (1, Psibar, SLR, Psi), G_Psipq3);
((U (-2), Psip, D 2), FBF (1, Psibar, SLR, Psi), G_Psipq2);
((N (-3), Psip, L 3), FBF (1, Psibar, SR, Psi), G_Psipl3);
((D (-3), Psim, U 3), FBF (1, Psibar, SLR, Psi), G_Psipq3);
((D (-2), Psim, U 2), FBF (1, Psibar, SLR, Psi), G_Psipq2);
((L (-3), Psim, N 3), FBF (1, Psibar, SL, Psi), G_Psipl3);
((TopHb, Psi0, U 3), FBF (1, Psibar, SL, Psi), G_Psi0tth);
((U (-3), Psi0, TopH), FBF (1, Psibar, SR, Psi), G_Psi0tth);
((TopHb, Psi1, U 3), FBF (1, Psibar, SL, Psi), G_Psi1tth);
((U (-3), Psi1, TopH), FBF (1, Psibar, SR, Psi), G_Psi1tth);
((TopHb, Psip, D 3), FBF (1, Psibar, SL, Psi), G_Psipbth);
((D (-3), Psim, TopH), FBF (1, Psibar, SR, Psi), G_Psipbth)]
let yukawa_add =
if Flags.u1_gauged then
yukawa_add'
else
yukawa_add' @
List.map mhm
[ ((U (-3), Eta, U 3), FBF (1, Psibar, P, Psi), G_Ett);
((TopHb, Eta, U 3), FBF (1, Psibar, SLR, Psi), G_Etht);
((D (-3), Eta, D 3), FBF (1, Psibar, P, Psi), G_Ebb);
((U (-3), Eta, TopH), FBF (1, Psibar, SLR, Psi), G_Etht)]
(* \begin{equation}
\mathcal{L}_{\textrm{TGC}} =
- e \partial_\mu A_\nu W_+^\mu W_-^\nu + \ldots
- e \cot\theta_w \partial_\mu Z_\nu W_+^\mu W_-^\nu + \ldots
\end{equation} *)
let standard_triple_gauge =
List.map tgc
[ ((Ga, Wm, Wp), Gauge_Gauge_Gauge 1, I_Q_W);
((Z, Wm, Wp), Gauge_Gauge_Gauge 1, I_G_ZWW);
((Gl, Gl, Gl), Gauge_Gauge_Gauge 1, I_Gs) ]
let heavy_triple_gauge =
List.map tgc
([ ((Ga, WHm, WHp), Gauge_Gauge_Gauge 1, I_Q_W);
((Z, WHm, WHp), Gauge_Gauge_Gauge 1, I_G_ZWW);
((ZH, Wm, Wp), Gauge_Gauge_Gauge 1, I_G_ZHWW);
((Z, WHm, Wp), Gauge_Gauge_Gauge 1, I_G_ZWHW);
((Z, Wm, WHp), Gauge_Gauge_Gauge (-1), I_G_ZWHW);
((ZH, WHm, Wp), Gauge_Gauge_Gauge 1, I_G_WWW);
((ZH, Wm, WHp), Gauge_Gauge_Gauge (-1), I_G_WWW);
((ZH, WHm, WHp), Gauge_Gauge_Gauge (-1), I_G_ZHWHWH)]
@
(if Flags.u1_gauged then
[ ((AH, Wm, Wp), Gauge_Gauge_Gauge 1, I_G_AHWW);
((AH, WHm, Wp), Gauge_Gauge_Gauge 1, I_G_AHWHW);
((AH, Wm, WHp), Gauge_Gauge_Gauge (-1), I_G_AHWHW);
((AH, WHm, WHp), Gauge_Gauge_Gauge 1, I_G_AHWHWH)]
else
[]))
let triple_gauge =
standard_triple_gauge @ heavy_triple_gauge
let gauge4 = Vector4 [(2, C_13_42); (-1, C_12_34); (-1, C_14_23)]
let minus_gauge4 = Vector4 [(-2, C_13_42); (1, C_12_34); (1, C_14_23)]
let standard_quartic_gauge =
List.map qgc
[ (Wm, Wp, Wm, Wp), gauge4, G_WWWW;
(Wm, Z, Wp, Z), minus_gauge4, G_ZZWW;
(Wm, Z, Wp, Ga), minus_gauge4, G_AZWW;
(Wm, Ga, Wp, Ga), minus_gauge4, G_AAWW;
(Gl, Gl, Gl, Gl), gauge4, G2 ]
let heavy_quartic_gauge =
List.map qgc
([ (WHm, Wp, WHm, Wp), gauge4, G_WWWW;
(Wm, WHp, Wm, WHp), gauge4, G_WWWW;
(WHm, WHp, WHm, WHp), gauge4, G_WH4;
(Wm, Wp, WHm, WHp), gauge4, G_WHWHWW;
(Wm, Wp, Wm, WHp), gauge4, G_WHWWW;
(Wm, Wp, WHm, Wp), gauge4, G_WHWWW;
(WHm, WHp, Wm, WHp), gauge4, G_WH3W;
(WHm, WHp, WHm, Wp), gauge4, G_WH3W;
(WHm, Z, WHp, Z), minus_gauge4, G_ZZWW;
(WHm, Z, WHp, Ga), minus_gauge4, G_AZWW;
(WHm, Ga, WHp, ZH), minus_gauge4, G_AAWW;
(WHm, Z, WHp, ZH), minus_gauge4, G_ZZWW;
(Wm, ZH, Wp, ZH), minus_gauge4, G_WWWW;
(Wm, Ga, Wp, ZH), minus_gauge4, G_WWAZH;
(Wm, Z, Wp, ZH), minus_gauge4, G_WWZZH;
(WHm, Ga, WHp, ZH), minus_gauge4, G_WHWHAZH;
(WHm, Z, WHp, ZH), minus_gauge4, G_WHWHZZH;
(WHm, ZH, WHp, ZH), minus_gauge4, G_WH4;
(WHm, Z, Wp, Z), minus_gauge4, G_WHWZZ;
(Wm, Z, WHp, Z), minus_gauge4, G_WHWZZ;
(WHm, Ga, Wp, Z), minus_gauge4, G_WHWAZ;
(Wm, Ga, WHp, Z), minus_gauge4, G_WHWAZ;
(WHm, ZH, Wp, ZH), minus_gauge4, G_WHWZHZH;
(Wm, ZH, WHp, ZH), minus_gauge4, G_WHWZHZH;
(WHm, Ga, Wp, ZH), minus_gauge4, G_WHWAZH;
(Wm, Ga, WHp, ZH), minus_gauge4, G_WHWAZH;
(WHm, Z, Wp, ZH), minus_gauge4, G_WHWZZH;
(Wm, Z, WHp, ZH), minus_gauge4, G_WHWZZH]
@
(if Flags.u1_gauged then
[ (Wm, Ga, Wp, AH), minus_gauge4, G_WWAAH;
(Wm, Z, Wp, AH), minus_gauge4, G_WWZAH;
(WHm, Ga, WHp, AH), minus_gauge4, G_WHWHAAH;
(WHm, Z, WHp, AH), minus_gauge4, G_WHWHZAH;
(Wm, ZH, Wp, AH), minus_gauge4, G_WWZHAH;
(WHm, ZH, WHp, AH), minus_gauge4, G_WHWHZHAH;
(WHm, Ga, Wp, AH), minus_gauge4, G_WHWAAH;
(Wm, Ga, WHp, AH), minus_gauge4, G_WHWAAH;
(WHm, Z, Wp, AH), minus_gauge4, G_WHWZAH;
(Wm, Z, WHp, AH), minus_gauge4, G_WHWZAH;
(WHm, ZH, Wp, AH), minus_gauge4, G_WHWZHAH;
(Wm, ZH, WHp, AH), minus_gauge4, G_WHWZHAH]
else
[]))
let quartic_gauge =
standard_quartic_gauge @ heavy_quartic_gauge
let standard_gauge_higgs' =
List.map hgg
[ ((H, Wp, Wm), Scalar_Vector_Vector 1, G_HWW);
((H, Z, Z), Scalar_Vector_Vector 1, G_HZZ) ]
let heavy_gauge_higgs =
List.map hgg
([ ((H, Wp, WHm), Scalar_Vector_Vector 1, G_HWHW);
((H, WHp, Wm), Scalar_Vector_Vector 1, G_HWHW);
((H, WHp, WHm), Scalar_Vector_Vector 1, G_HWHWH);
((H, ZH, ZH), Scalar_Vector_Vector 1, G_HWHWH);
((H, ZH, Z), Scalar_Vector_Vector 1, G_HZHZ);
((H, Wp, Wm), Scalar_Vector_Vector 1, G_HZHAH)]
@
(if Flags.u1_gauged then
[((H, AH, AH), Scalar_Vector_Vector 1, G_HAHAH);
((H, Z, AH), Scalar_Vector_Vector 1, G_HAHZ)]
else
[]))
let triplet_gauge_higgs =
List.map hgg
([ ((Psi0, Wp, Wm), Scalar_Vector_Vector 1, G_PsiWW);
((Psi0, WHp, WHm), Scalar_Vector_Vector (-1), G_PsiWW);
((Psi0, WHp, Wm), Scalar_Vector_Vector 1, G_PsiWHW);
((Psi0, WHm, Wp), Scalar_Vector_Vector 1, G_PsiWHW);
((Psi0, Z, Z), Scalar_Vector_Vector 1, G_PsiZZ);
((Psi0, ZH, ZH), Scalar_Vector_Vector 1, G_PsiZHZH);
((Psi0, ZH, Z), Scalar_Vector_Vector 1, G_PsiZHZ);
((Psim, Wp, Z), Scalar_Vector_Vector 1, G_PsiZW);
((Psip, Wm, Z), Scalar_Vector_Vector 1, G_PsiZW);
((Psim, WHp, Z), Scalar_Vector_Vector 1, G_PsiZWH);
((Psip, WHm, Z), Scalar_Vector_Vector 1, G_PsiZWH);
((Psim, Wp, ZH), Scalar_Vector_Vector 1, G_PsiZHW);
((Psip, Wm, ZH), Scalar_Vector_Vector 1, G_PsiZHW);
((Psim, WHp, ZH), Scalar_Vector_Vector 1, G_PsiZHWH);
((Psip, WHm, ZH), Scalar_Vector_Vector 1, G_PsiZHWH);
((Psimm, Wp, Wp), Scalar_Vector_Vector 1, G_PsippWW);
((Psipp, Wm, Wm), Scalar_Vector_Vector 1, G_PsippWW);
((Psimm, WHp, Wp), Scalar_Vector_Vector 1, G_PsippWHW);
((Psipp, WHm, Wm), Scalar_Vector_Vector 1, G_PsippWHW);
((Psimm, WHp, WHp), Scalar_Vector_Vector 1, G_PsippWHWH);
((Psipp, WHm, WHm), Scalar_Vector_Vector 1, G_PsippWHWH)]
@
(if Flags.u1_gauged then
[((Psi0, AH, Z), Scalar_Vector_Vector 1, G_PsiZAH);
((Psi0, AH, ZH), Scalar_Vector_Vector 1, G_PsiZHAH);
((Psi0, AH, AH), Scalar_Vector_Vector 1, G_PsiAHAH);
((Psim, Wp, AH), Scalar_Vector_Vector 1, G_PsiAHW);
((Psip, Wm, AH), Scalar_Vector_Vector 1, G_PsiAHW);
((Psim, WHp, AH), Scalar_Vector_Vector 1, G_PsiAHWH);
((Psip, WHm, AH), Scalar_Vector_Vector 1, G_PsiAHWH)]
else
[]))
let triplet_gauge2_higgs =
List.map ghh
([ ((Wp, H, Psim), Vector_Scalar_Scalar 1, G_PsiHW);
((Wm, H, Psip), Vector_Scalar_Scalar 1, G_PsiHW);
((WHp, H, Psim), Vector_Scalar_Scalar 1, G_PsiHWH);
((WHm, H, Psip), Vector_Scalar_Scalar 1, G_PsiHWH);
((Wp, Psi0, Psim), Vector_Scalar_Scalar 1, G_Psi0W);
((Wm, Psi0, Psip), Vector_Scalar_Scalar 1, G_Psi0W);
((WHp, Psi0, Psim), Vector_Scalar_Scalar 1, G_Psi0WH);
((WHm, Psi0, Psip), Vector_Scalar_Scalar 1, G_Psi0WH);
((Wp, Psi1, Psim), Vector_Scalar_Scalar 1, G_Psi1W);
((Wm, Psi1, Psip), Vector_Scalar_Scalar (-1), G_Psi1W);
((WHp, Psi1, Psim), Vector_Scalar_Scalar 1, G_Psi1WH);
((WHm, Psi1, Psip), Vector_Scalar_Scalar (-1), G_Psi1WH);
((Wp, Psip, Psimm), Vector_Scalar_Scalar 1, G_PsiPPW);
((Wm, Psim, Psipp), Vector_Scalar_Scalar 1, G_PsiPPW);
((WHp, Psip, Psimm), Vector_Scalar_Scalar 1, G_PsiPPWH);
((WHm, Psim, Psipp), Vector_Scalar_Scalar 1, G_PsiPPWH);
((Ga, Psip, Psim), Vector_Scalar_Scalar 1, Q_lepton);
((Ga, Psipp, Psimm), Vector_Scalar_Scalar 2, Q_lepton);
((Z, H, Psi1), Vector_Scalar_Scalar 1, G_Psi1HZ);
((ZH, H, Psi1), Vector_Scalar_Scalar 1, G_Psi1HZH);
((Z, Psi0, Psi1), Vector_Scalar_Scalar 1, G_Psi01Z);
((ZH, Psi0, Psi1), Vector_Scalar_Scalar 1, G_Psi01ZH);
((Z, Psip, Psim), Vector_Scalar_Scalar 1, G_ZPsip);
((Z, Psipp, Psimm), Vector_Scalar_Scalar 2, G_ZPsipp);
((ZH, Psipp, Psimm), Vector_Scalar_Scalar 2, G_ZHPsipp)]
@
(if Flags.u1_gauged then
[((AH, H, Psi1), Vector_Scalar_Scalar 1, G_Psi1HAH);
((AH, Psi0, Psi1), Vector_Scalar_Scalar 1, G_Psi01AH);
((AH, Psip, Psim), Vector_Scalar_Scalar 1, G_AHPsip);
((AH, Psipp, Psimm), Vector_Scalar_Scalar 2, G_AHPsip)]
else []))
let standard_gauge_higgs =
standard_gauge_higgs' @ heavy_gauge_higgs @ triplet_gauge_higgs @
triplet_gauge2_higgs
let standard_gauge_higgs4 =
List.map hhgg
[ (H, H, Wp, Wm), Scalar2_Vector2 1, G_HHWW;
(H, H, Z, Z), Scalar2_Vector2 1, G_HHZZ ]
let littlest_gauge_higgs4 =
List.map hhgg
([ (H, H, WHp, WHm), Scalar2_Vector2 (-1), G_HHWW;
(H, H, ZH, ZH), Scalar2_Vector2 (-1), G_HHWW;
(H, H, Wp, WHm), Scalar2_Vector2 1, G_HHWHW;
(H, H, WHp, Wm), Scalar2_Vector2 1, G_HHWHW;
(H, H, ZH, Z), Scalar2_Vector2 (-1), G_HHZHZ;
(H, Psi0, Wp, Wm), Scalar2_Vector2 1, G_HPsi0WW;
(H, Psi0, WHp, WHm), Scalar2_Vector2 (-1), G_HPsi0WW;
(H, Psi0, WHp, Wm), Scalar2_Vector2 1, G_HPsi0WHW;
(H, Psi0, Wp, WHm), Scalar2_Vector2 1, G_HPsi0WHW;
(H, Psi0, Z, Z), Scalar2_Vector2 1, G_HPsi0ZZ;
(H, Psi0, ZH, ZH), Scalar2_Vector2 1, G_HPsi0ZHZH;
(H, Psi0, ZH, Z), Scalar2_Vector2 1, G_HPsi0ZHZ;
(H, Psim, Wp, Ga), Scalar2_Vector2 1, G_HPsipWA;
(H, Psip, Wm, Ga), Scalar2_Vector2 1, G_HPsipWA;
(H, Psim, WHp, Ga), Scalar2_Vector2 1, G_HPsipWHA;
(H, Psip, WHm, Ga), Scalar2_Vector2 1, G_HPsipWHA;
(H, Psim, Wp, Z), Scalar2_Vector2 1, G_HPsipWZ;
(H, Psip, Wm, Z), Scalar2_Vector2 1, G_HPsipWZ;
(H, Psim, WHp, Z), Scalar2_Vector2 1, G_HPsipWHZ;
(H, Psip, WHm, Z), Scalar2_Vector2 1, G_HPsipWHZ;
(H, Psim, Wp, ZH), Scalar2_Vector2 1, G_HPsipWZH;
(H, Psip, Wm, ZH), Scalar2_Vector2 1, G_HPsipWZH;
(H, Psim, WHp, ZH), Scalar2_Vector2 1, G_HPsipWHZH;
(H, Psip, WHm, ZH), Scalar2_Vector2 1, G_HPsipWHZH;
(H, Psimm, Wp, Wp), Scalar2_Vector2 1, G_HPsippWW;
(H, Psipp, Wm, Wm), Scalar2_Vector2 1, G_HPsippWW;
(H, Psimm, WHp, WHp), Scalar2_Vector2 1, G_HPsippWHWH;
(H, Psipp, WHm, WHm), Scalar2_Vector2 1, G_HPsippWHWH;
(H, Psimm, WHp, Wp), Scalar2_Vector2 1, G_HPsippWHW;
(H, Psipp, WHm, Wm), Scalar2_Vector2 1, G_HPsippWHW;
(Psi0, Psi0, Wp, Wm), Scalar2_Vector2 2, G_HHWW;
(Psi0, Psi0, WHp, WHm), Scalar2_Vector2 (-2), G_HHWW;
(Psi0, Psi0, Z, Z), Scalar2_Vector2 4, G_HHZZ;
(Psi0, Psi0, ZH, ZH), Scalar2_Vector2 1, G_Psi00ZH;
(Psi0, Psi0, WHp, Wm), Scalar2_Vector2 2, G_HHWHW;
(Psi0, Psi0, Wp, WHm), Scalar2_Vector2 2, G_HHWHW;
(Psi0, Psi0, Z, ZH), Scalar2_Vector2 4, G_HHZHZ;
(Psi0, Psim, Wp, Ga), Scalar2_Vector2 1, G_Psi0pWA;
(Psi0, Psip, Wm, Ga), Scalar2_Vector2 1, G_Psi0pWA;
(Psi0, Psim, WHp, Ga), Scalar2_Vector2 1, G_Psi0pWHA;
(Psi0, Psip, WHm, Ga), Scalar2_Vector2 1, G_Psi0pWHA;
(Psi0, Psim, Wp, Z), Scalar2_Vector2 1, G_Psi0pWZ;
(Psi0, Psip, Wm, Z), Scalar2_Vector2 1, G_Psi0pWZ;
(Psi0, Psim, WHp, Z), Scalar2_Vector2 1, G_Psi0pWHZ;
(Psi0, Psip, WHm, Z), Scalar2_Vector2 1, G_Psi0pWHZ;
(Psi0, Psim, Wp, ZH), Scalar2_Vector2 1, G_Psi0pWZH;
(Psi0, Psip, Wm, ZH), Scalar2_Vector2 1, G_Psi0pWZH;
(Psi0, Psim, WHp, ZH), Scalar2_Vector2 1, G_Psi0pWHZH;
(Psi0, Psip, WHm, ZH), Scalar2_Vector2 1, G_Psi0pWHZH;
(Psi0, Psimm, Wp, Wp), Scalar2_Vector2 1, G_Psi0ppWW;
(Psi0, Psipp, Wm, Wm), Scalar2_Vector2 1, G_Psi0ppWW;
(Psi0, Psimm, WHp, WHp), Scalar2_Vector2 1, G_Psi0ppWHWH;
(Psi0, Psipp, WHm, WHm), Scalar2_Vector2 1, G_Psi0ppWHWH;
(Psi0, Psimm, WHp, Wp), Scalar2_Vector2 1, G_Psi0ppWHW;
(Psi0, Psipp, WHm, Wm), Scalar2_Vector2 1, G_Psi0ppWHW;
(Psi1, Psi1, Wp, Wm), Scalar2_Vector2 2, G_HHWW;
(Psi1, Psi1, WHp, WHm), Scalar2_Vector2 (-2), G_HHWW;
(Psi1, Psi1, Z, Z), Scalar2_Vector2 4, G_HHZZ;
(Psi1, Psi1, ZH, ZH), Scalar2_Vector2 1, G_Psi00ZH;
(Psi1, Psi1, WHp, Wm), Scalar2_Vector2 2, G_HHWHW;
(Psi1, Psi1, Wp, WHm), Scalar2_Vector2 2, G_HHWHW;
(Psi1, Psi1, Z, ZH), Scalar2_Vector2 4, G_HHZHZ;
(Psi1, Psim, Wp, Ga), Scalar2_Vector2 1, I_G_Psi0pWA;
(Psi1, Psip, Wm, Ga), Scalar2_Vector2 (-1), I_G_Psi0pWA;
(Psi1, Psim, WHp, Ga), Scalar2_Vector2 1, I_G_Psi0pWHA;
(Psi1, Psip, WHm, Ga), Scalar2_Vector2 (-1), I_G_Psi0pWHA;
(Psi1, Psim, Wp, Z), Scalar2_Vector2 1, I_G_Psi0pWZ;
(Psi1, Psip, Wm, Z), Scalar2_Vector2 (-1), I_G_Psi0pWZ;
(Psi1, Psim, WHp, Z), Scalar2_Vector2 1, I_G_Psi0pWHZ;
(Psi1, Psip, WHm, Z), Scalar2_Vector2 (-1), I_G_Psi0pWHZ;
(Psi1, Psim, Wp, ZH), Scalar2_Vector2 1, I_G_Psi0pWZH;
(Psi1, Psip, Wm, ZH), Scalar2_Vector2 (-1), I_G_Psi0pWZH;
(Psi1, Psim, WHp, ZH), Scalar2_Vector2 1, I_G_Psi0pWHZH;
(Psi1, Psip, WHm, ZH), Scalar2_Vector2 (-1), I_G_Psi0pWHZH;
(Psi1, Psimm, Wp, Wp), Scalar2_Vector2 1, I_G_Psi0ppWW;
(Psi1, Psipp, Wm, Wm), Scalar2_Vector2 (-1), I_G_Psi0ppWW;
(Psi1, Psimm, WHp, WHp), Scalar2_Vector2 1, I_G_Psi0ppWHWH;
(Psi1, Psipp, WHm, WHm), Scalar2_Vector2 (-1), I_G_Psi0ppWHWH;
(Psi1, Psimm, WHp, Wp), Scalar2_Vector2 1, I_G_Psi0ppWHW;
(Psi1, Psipp, WHm, Wm), Scalar2_Vector2 (-1), I_G_Psi0ppWHW;
(Psip, Psim, Wp, Wm), Scalar2_Vector2 4, G_HHWW;
(Psip, Psim, WHp, WHm), Scalar2_Vector2 1, G_Psi00ZH;
(Psip, Psim, WHp, Wm), Scalar2_Vector2 4, G_HHWHW;
(Psip, Psim, Wp, WHm), Scalar2_Vector2 4, G_HHWHW;
(Psip, Psim, Z, Z), Scalar2_Vector2 1, G_PsippZZ;
(Psip, Psim, Ga, Ga), Scalar2_Vector2 2, G_AAWW;
(Psip, Psim, ZH, ZH), Scalar2_Vector2 1, G_PsippZHZH;
(Psip, Psim, Ga, Z), Scalar2_Vector2 4, G_PsippAZ;
(Psip, Psimm, Wp, Ga), Scalar2_Vector2 1, G_PsippWA;
(Psim, Psipp, Wm, Ga), Scalar2_Vector2 1, G_PsippWA;
(Psip, Psimm, WHp, Ga), Scalar2_Vector2 1, G_PsippWHA;
(Psim, Psipp, WHm, Ga), Scalar2_Vector2 1, G_PsippWHA;
(Psip, Psimm, Wp, Z), Scalar2_Vector2 1, G_PsippWZ;
(Psim, Psipp, Wm, Z), Scalar2_Vector2 1, G_PsippWZ;
(Psip, Psimm, WHp, Z), Scalar2_Vector2 1, G_PsippWHZ;
(Psim, Psipp, WHm, Z), Scalar2_Vector2 1, G_PsippWHZ;
(Psip, Psimm, Wp, ZH), Scalar2_Vector2 1, G_PsippWZH;
(Psim, Psipp, Wm, ZH), Scalar2_Vector2 1, G_PsippWZH;
(Psip, Psimm, WHp, ZH), Scalar2_Vector2 1, G_PsippWHZH;
(Psim, Psipp, WHm, ZH), Scalar2_Vector2 1, G_PsippWHZH;
(Psipp, Psimm, Wp, Wm), Scalar2_Vector2 2, G_HHWW;
(Psipp, Psimm, WHp, WHm), Scalar2_Vector2 (-2), G_HHWW;
(Psipp, Psimm, WHp, Wm), Scalar2_Vector2 2, G_HHWHW;
(Psipp, Psimm, Wp, WHm), Scalar2_Vector2 2, G_HHWHW;
(Psipp, Psimm, Z, Z), Scalar2_Vector2 1, G_PsiccZZ;
(Psipp, Psimm, Ga, Ga), Scalar2_Vector2 8, G_AAWW;
(Psipp, Psimm, ZH, ZH), Scalar2_Vector2 1, G_Psi00ZH;
(Psipp, Psimm, Ga, Z), Scalar2_Vector2 1, G_PsiccAZ;
(Psipp, Psimm, Z, ZH), Scalar2_Vector2 4, G_PsiccZZH;
(Psipp, Psimm, Ga, ZH), Scalar2_Vector2 4, G_PsiccAZH]
@
(if Flags.u1_gauged then
[(H, H, AH, AH), Scalar2_Vector2 1, G_HHAA;
(H, H, AH, Z), Scalar2_Vector2 (-1), G_HHAHZ;
(H, H, ZH, AH), Scalar2_Vector2 (-1), G_HHZHAH;
(H, Psi0, AH, AH), Scalar2_Vector2 1, G_HPsi0AHAH;
(H, Psi0, Z, AH), Scalar2_Vector2 1, G_HPsi0ZAH;
(H, Psi0, ZH, AH), Scalar2_Vector2 1, G_HPsi0ZHAH;
(H, Psim, Wp, AH), Scalar2_Vector2 1, G_HPsipWAH;
(H, Psip, Wm, AH), Scalar2_Vector2 1, G_HPsipWAH;
(H, Psim, WHp, AH), Scalar2_Vector2 1, G_HPsipWHAH;
(H, Psip, WHm, AH), Scalar2_Vector2 1, G_HPsipWHAH;
(Psi0, Psi0, AH, AH), Scalar2_Vector2 1, G_Psi00AH;
(Psi0, Psi0, Z, AH), Scalar2_Vector2 4, G_HHAHZ;
(Psi0, Psi0, AH, ZH), Scalar2_Vector2 1, G_Psi00ZHAH;
(Psi0, Psim, Wp, AH), Scalar2_Vector2 1, G_Psi0pWAH;
(Psi0, Psip, Wm, AH), Scalar2_Vector2 1, G_Psi0pWAH;
(Psi0, Psim, WHp, AH), Scalar2_Vector2 1, G_Psi0pWHAH;
(Psi0, Psip, WHm, AH), Scalar2_Vector2 1, G_Psi0pWHAH;
(Psi1, Psi1, AH, AH), Scalar2_Vector2 1, G_Psi00AH;
(Psi1, Psi1, Z, AH), Scalar2_Vector2 4, G_HHAHZ;
(Psi1, Psi1, AH, ZH), Scalar2_Vector2 1, G_Psi00ZHAH;
(Psi1, Psim, Wp, AH), Scalar2_Vector2 1, I_G_Psi0pWAH;
(Psi1, Psip, Wm, AH), Scalar2_Vector2 (-1), I_G_Psi0pWAH;
(Psi1, Psim, WHp, AH), Scalar2_Vector2 1, I_G_Psi0pWHAH;
(Psi1, Psip, WHm, AH), Scalar2_Vector2 (-1), I_G_Psi0pWHAH;
(Psip, Psim, AH, AH), Scalar2_Vector2 1, G_Psi00AH;
(Psip, Psim, Ga, AH), Scalar2_Vector2 4, G_PsippAAH;
(Psip, Psim, Z, AH), Scalar2_Vector2 4, G_PsippZAH;
(Psip, Psimm, Wp, AH), Scalar2_Vector2 1, G_PsippWAH;
(Psim, Psipp, Wm, AH), Scalar2_Vector2 1, G_PsippWAH;
(Psip, Psimm, WHp, AH), Scalar2_Vector2 1, G_PsippWHAH;
(Psim, Psipp, WHm, AH), Scalar2_Vector2 1, G_PsippWHAH;
(Psipp, Psimm, AH, AH), Scalar2_Vector2 1, G_Psi00AH;
(Psipp, Psimm, AH, ZH), Scalar2_Vector2 (-1), G_Psi00ZHAH;
(Psipp, Psimm, Ga, AH), Scalar2_Vector2 4, G_PsiccAAH;
(Psipp, Psimm, Z, AH), Scalar2_Vector2 4, G_PsiccZAH]
else []))
let standard_higgs =
[ (O H, O H, O H), Scalar_Scalar_Scalar 1, G_H3 ]
let anomaly_higgs =
List.map hgg
[ (Eta, Gl, Gl), Dim5_Scalar_Gauge2_Skew 1, G_EGlGl;
(Eta, Ga, Ga), Dim5_Scalar_Gauge2_Skew 1, G_EGaGa;
(Eta, Ga, Z), Dim5_Scalar_Gauge2_Skew 1, G_EGaZ]
(* @ [ (H, Ga, Ga), Dim5_Scalar_Gauge2 1, G_HGaGa;
(H, Ga, Z), Dim5_Scalar_Gauge2 1, G_HGaZ ] *)
let standard_higgs4 =
[ (O H, O H, O H, O H), Scalar4 1, G_H4 ]
let gauge_higgs =
standard_gauge_higgs
let gauge_higgs4 =
standard_gauge_higgs4
let higgs =
standard_higgs
let higgs4 =
standard_higgs4
let top_quartic =
[ ((M (U (-3)), O H, O H, M (U 3)), GBBG (1, Psibar, S2, Psi), G_HHtt);
((M (TopHb), O H, O H, M TopH), GBBG (1, Psibar, S2, Psi), G_HHthth);
((M (U (-3)), O H, O H, M TopH), GBBG (1, Psibar, S2LR, Psi), G_HHtht);
((M (TopHb), O H, O H, M (U 3)), GBBG (1, Psibar, S2LR, Psi), G_HHtht)]
let goldstone_vertices =
List.map hgg
[ ((Phi0, Wm, Wp), Scalar_Vector_Vector 1, I_G_ZWW);
((Phip, Ga, Wm), Scalar_Vector_Vector 1, I_Q_W);
((Phip, Z, Wm), Scalar_Vector_Vector 1, I_G_ZWW);
((Phim, Wp, Ga), Scalar_Vector_Vector 1, I_Q_W);
((Phim, Wp, Z), Scalar_Vector_Vector 1, I_G_ZWW) ]
let vertices3 =
(ThoList.flatmap electromagnetic_currents [1;2;3] @
ThoList.flatmap color_currents [1;2;3] @
ThoList.flatmap neutral_currents [1;2;3] @
ThoList.flatmap neutral_heavy_currents [1;2;3] @
ThoList.flatmap charged_currents [1;2;3] @
ThoList.flatmap charged_heavy_currents [1;2;3] @
heavy_top_currents @
(if Flags.u1_gauged then []
else anomaly_higgs) @
yukawa @ yukawa_add @ triple_gauge @
gauge_higgs @ higgs @ goldstone_vertices)
let vertices4 =
quartic_gauge @ gauge_higgs4 @ higgs4 @ top_quartic
let vertices () = (vertices3, vertices4, [])
(* For efficiency, make sure that [F.of_vertices vertices] is
evaluated only once. *)
let table = F.of_vertices (vertices ())
let fuse2 = F.fuse2 table
let fuse3 = F.fuse3 table
let fuse = F.fuse table
let max_degree () = 4
let flavor_of_string = function
| "e-" -> M (L 1) | "e+" -> M (L (-1))
| "mu-" -> M (L 2) | "mu+" -> M (L (-2))
| "tau-" -> M (L 3) | "tau+" -> M (L (-3))
| "nue" -> M (N 1) | "nuebar" -> M (N (-1))
| "numu" -> M (N 2) | "numubar" -> M (N (-2))
| "nutau" -> M (N 3) | "nutaubar" -> M (N (-3))
| "u" -> M (U 1) | "ubar" -> M (U (-1))
| "c" -> M (U 2) | "cbar" -> M (U (-2))
| "t" -> M (U 3) | "tbar" -> M (U (-3))
| "d" -> M (D 1) | "dbar" -> M (D (-1))
| "s" -> M (D 2) | "sbar" -> M (D (-2))
| "b" -> M (D 3) | "bbar" -> M (D (-3))
| "th" -> M TopH | "thbar" -> M TopHb
| "g" | "gl" -> G Gl
| "A" -> G Ga | "Z" | "Z0" -> G Z
| "AH" | "AH0" | "Ah" | "Ah0" -> G AH
| "ZH" | "ZH0" | "Zh" | "Zh0" -> G ZH
| "W+" -> G Wp | "W-" -> G Wm
| "WH+" -> G WHp | "WH-" -> G WHm
| "H" | "h" -> O H | "eta" | "Eta" -> O Eta
| "Psi" | "Psi0" | "psi" | "psi0" -> O Psi0
| "Psi1" | "psi1" -> O Psi1
| "Psi+" | "psi+" | "Psip" | "psip" -> O Psip
| "Psi-" | "psi-" | "Psim" | "psim" -> O Psim
| "Psi++" | "psi++" | "Psipp" | "psipp" -> O Psipp
| "Psi--" | "psi--" | "Psimm" | "psimm" -> O Psimm
| _ -> invalid_arg "Modellib_BSM.Littlest.flavor_of_string"
let flavor_to_string = function
| M f ->
begin match f with
| L 1 -> "e-" | L (-1) -> "e+"
| L 2 -> "mu-" | L (-2) -> "mu+"
| L 3 -> "tau-" | L (-3) -> "tau+"
| L _ -> invalid_arg "Modellib_BSM.Littlest.flavor_to_string"
| N 1 -> "nue" | N (-1) -> "nuebar"
| N 2 -> "numu" | N (-2) -> "numubar"
| N 3 -> "nutau" | N (-3) -> "nutaubar"
| N _ -> invalid_arg "Modellib_BSM.Littlest.flavor_to_string"
| U 1 -> "u" | U (-1) -> "ubar"
| U 2 -> "c" | U (-2) -> "cbar"
| U 3 -> "t" | U (-3) -> "tbar"
| U _ -> invalid_arg "Modellib_BSM.Littlest.flavor_to_string"
| D 1 -> "d" | D (-1) -> "dbar"
| D 2 -> "s" | D (-2) -> "sbar"
| D 3 -> "b" | D (-3) -> "bbar"
| D _ -> invalid_arg "Modellib_BSM.Littlest.flavor_to_string"
| TopH -> "th" | TopHb -> "thbar"
end
| G f ->
begin match f with
| Gl -> "g"
| Ga -> "A" | Z -> "Z"
| Wp -> "W+" | Wm -> "W-"
| ZH -> "ZH" | AH -> "AH" | WHp -> "WHp" | WHm -> "WHm"
end
| O f ->
begin match f with
| Phip -> "phi+" | Phim -> "phi-" | Phi0 -> "phi0"
| H -> "H" | Eta -> "Eta"
| Psi0 -> "Psi0" | Psi1 -> "Psi1" | Psip -> "Psi+"
| Psim -> "Psi-" | Psipp -> "Psi++" | Psimm -> "Psi--"
end
let flavor_to_TeX = function
| M f ->
begin match f with
| L 1 -> "e^-" | L (-1) -> "e^+"
| L 2 -> "\\mu^-" | L (-2) -> "\\mu^+"
| L 3 -> "\\tau^-" | L (-3) -> "\\tau^+"
| L _ -> invalid_arg "Modellib_BSM.Littlest.flavor_to_TeX"
| N 1 -> "\\nu_e" | N (-1) -> "\\bar{\\nu}_e"
| N 2 -> "\\nu_\\mu" | N (-2) -> "\\bar{\\nu}_\\mu"
| N 3 -> "\\nu_\\tau" | N (-3) -> "\\bar{\\nu}_\\tau"
| N _ -> invalid_arg "Modellib_BSM.Littlest.flavor_to_TeX"
| U 1 -> "u" | U (-1) -> "\\bar{u}"
| U 2 -> "c" | U (-2) -> "\\bar{c}"
| U 3 -> "t" | U (-3) -> "\\bar{t}"
| U _ -> invalid_arg "Modellib_BSM.Littlest.flavor_to_TeX"
| D 1 -> "d" | D (-1) -> "\\bar{d}"
| D 2 -> "s" | D (-2) -> "\\bar{s}"
| D 3 -> "b" | D (-3) -> "\\bar{b}"
| D _ -> invalid_arg "Modellib_BSM.Littlest.flavor_to_TeX"
| TopH -> "T" | TopHb -> "\\bar{T}"
end
| G f ->
begin match f with
| Gl -> "g"
| Ga -> "\\gamma" | Z -> "Z"
| Wp -> "W^+" | Wm -> "W^-"
| ZH -> "Z_H" | AH -> "\\gamma_H" | WHp -> "W_H^+" | WHm -> "W_H^-"
end
| O f ->
begin match f with
| Phip -> "\\Phi^+" | Phim -> "\\Phi^-" | Phi0 -> "\\Phi^0"
| H -> "H" | Eta -> "\\eta"
| Psi0 -> "\\Psi_S" | Psi1 -> "\\Psi_P" | Psip -> "\\Psi^+"
| Psim -> "\\Psi^-" | Psipp -> "\\Psi^{++}" | Psimm -> "\\Psi^{--}"
end
let flavor_symbol = function
| M f ->
begin match f with
| L n when n > 0 -> "l" ^ string_of_int n
| L n -> "l" ^ string_of_int (abs n) ^ "b"
| N n when n > 0 -> "n" ^ string_of_int n
| N n -> "n" ^ string_of_int (abs n) ^ "b"
| U n when n > 0 -> "u" ^ string_of_int n
| U n -> "u" ^ string_of_int (abs n) ^ "b"
| D n when n > 0 -> "d" ^ string_of_int n
| D n -> "d" ^ string_of_int (abs n) ^ "b"
| TopH -> "th" | TopHb -> "thb"
end
| G f ->
begin match f with
| Gl -> "gl"
| Ga -> "a" | Z -> "z"
| Wp -> "wp" | Wm -> "wm"
| ZH -> "zh" | AH -> "ah" | WHp -> "whp" | WHm -> "whm"
end
| O f ->
begin match f with
| Phip -> "pp" | Phim -> "pm" | Phi0 -> "p0"
| H -> "h" | Eta -> "eta"
| Psi0 -> "psi0" | Psi1 -> "psi1" | Psip -> "psip"
| Psim -> "psim" | Psipp -> "psipp" | Psimm -> "psimm"
end
(* There are PDG numbers for Z', Z'', W', 32-34, respectively.
We just introduce a number 38 for Y0 as a Z'''.
As well, there is the number 8 for a t'. But we cheat a little bit and
take the number 35 which is reserved for a heavy scalar Higgs for the
Eta scalar.
For the heavy Higgs states we take 35 and 36 for the neutral ones, 37 for
the charged and 38 for the doubly-charged.
The pseudoscalar gets the 39.
*)
let pdg = function
| M f ->
begin match f with
| L n when n > 0 -> 9 + 2*n
| L n -> - 9 + 2*n
| N n when n > 0 -> 10 + 2*n
| N n -> - 10 + 2*n
| U n when n > 0 -> 2*n
| U n -> 2*n
| D n when n > 0 -> - 1 + 2*n
| D n -> 1 + 2*n
| TopH -> 8 | TopHb -> (-8)
end
| G f ->
begin match f with
| Gl -> 21
| Ga -> 22 | Z -> 23
| Wp -> 24 | Wm -> (-24)
| AH -> 32 | ZH -> 33 | WHp -> 34 | WHm -> (-34)
end
| O f ->
begin match f with
| Phip | Phim -> 27 | Phi0 -> 26
| Psi0 -> 35 | Psi1 -> 36 | Psip -> 37 | Psim -> (-37)
| Psipp -> 38 | Psimm -> (-38)
| H -> 25 | Eta -> 39
end
let mass_symbol f =
"mass(" ^ string_of_int (abs (pdg f)) ^ ")"
let width_symbol f =
"width(" ^ string_of_int (abs (pdg f)) ^ ")"
let constant_symbol = function
| Unit -> "unit" | Pi -> "PI" | VHeavy -> "vheavy"
| Alpha_QED -> "alpha" | E -> "e" | G_weak -> "g" | Vev -> "vev"
| Sin2thw -> "sin2thw" | Sinthw -> "sinthw" | Costhw -> "costhw"
| Sinpsi -> "sinpsi" | Cospsi -> "cospsi"
| Atpsi -> "atpsi" | Sccs -> "sccs"
| Supp -> "vF" | Supp2 -> "v2F2"
| Q_lepton -> "qlep" | Q_up -> "qup" | Q_down -> "qdwn"
| Q_Z_up -> "qzup"
| G_ZHTHT -> "gzhtht" | G_ZTHT -> "gztht"
| G_AHTHTH -> "gahthth" | G_AHTHT -> "gahtht" | G_AHTT -> "gahtt"
| G_NC_lepton -> "gnclep" | G_NC_neutrino -> "gncneu"
| G_NC_up -> "gncup" | G_NC_down -> "gncdwn"
| G_CC -> "gcc" | G_CCtop -> "gcctop" | G_CC_heavy -> "gcch"
| G_CC_WH -> "gccwh" | G_CC_W -> "gccw"
| G_NC_h_lepton -> "gnchlep" | G_NC_h_neutrino -> "gnchneu"
| G_NC_h_up -> "gnchup" | G_NC_h_down -> "gnchdwn"
| G_NC_heavy -> "gnch"
| I_Q_W -> "iqw" | I_G_ZWW -> "igzww" | I_G_WWW -> "igwww"
| I_G_AHWW -> "igahww" | I_G_ZHWW -> "igzhww" | I_G_ZWHW -> "igzwhw"
| I_G_AHWHWH -> "igahwhwh" | I_G_ZHWHWH -> "igzhwhwh"
| I_G_AHWHW -> "igahwhw"
| I_Q_H -> "iqh"
| G_WWWW -> "gw4" | G_ZZWW -> "gzzww"
| G_AZWW -> "gazww" | G_AAWW -> "gaaww"
| G_WH4 -> "gwh4" | G_WHWHWW -> "gwhwhww" | G_WHWWW -> "gwhwww"
| G_WH3W -> "gwh3w"
| G_WWAAH -> "gwwaah" | G_WWAZH -> "gwwazh" | G_WWZZH -> "gwwzzh"
| G_WWZAH -> "gwwzah" | G_WHWHAAH -> "gwhwhaah"
| G_WHWHAZH -> "gwhwhazh" | G_WHWHZZH -> "gwhwhzzh"
| G_WHWHZAH -> "gwhwhzah"
| G_WWZHAH -> "gwwzhah" | G_WHWHZHAH -> "gwhwhzhah"
| G_WHWZZ -> "gwhwzz" | G_WHWAZ -> "gwhwaz"
| G_WHWAAH -> "gwhwaah" | G_WHWZAH -> "gwhwzah"
| G_WHWZHZH -> "gwhwzhzh" | G_WHWZHAH -> "gwhwzhah"
| G_WHWAZH -> "gwhwazh" | G_WHWZZH -> "gwhwzzh"
| G_HWW -> "ghww" | G_HZZ -> "ghzz"
| G_HHWW -> "ghhww" | G_HHZZ -> "ghhzz"
| G_HWHW -> "ghwhw" | G_HWHWH -> "ghwhwh" | G_HAHAH -> "ghahah"
| G_HZHZ -> "ghzhz" | G_HZHAH -> "ghzhah"
| G_HAHZ -> "ghahz"
| G_Htt -> "ghtt" | G_Hbb -> "ghbb"
| G_Htautau -> "ghtautau" | G_Hcc -> "ghcc"
| G_Hthth -> "ghthth" | G_Htht -> "ghtht"
| G_HHtt -> "ghhtt" | G_HHthth -> "ghhthth" | G_HHtht -> "ghhtht"
| G_Psi0tt -> "gpsi0tt" | G_Psi0bb -> "gpsi0bb"
| G_Psi0cc -> "gpsi0cc" | G_Psi0tautau -> "gpsi0tautau"
| G_Psi1tt -> "gpsi1tt" | G_Psi1bb -> "gpsi1bb"
| G_Psi1cc -> "gpsi1cc" | G_Psi1tautau -> "gpsi1tautau"
| G_Psipq3 -> "gpsipq3" | G_Psipq2 -> "gpsipq2" | G_Psipl3 -> "gpsipl3"
| G_Psi0tth -> "gpsi0tth" | G_Psi1tth -> "gpsi1tth"
| G_Psipbth -> "gpsipbth"
| G_Ethth -> "gethth" | G_Etht -> "getht"
| G_Ett -> "gett" | G_Ebb -> "gebb"
| G_HGaGa -> "ghgaga" | G_HGaZ -> "ghgaz"
| G_EGaGa -> "geaa" | G_EGaZ -> "geaz" | G_EGlGl -> "gegg"
| G_H3 -> "gh3" | G_H4 -> "gh4"
| G_PsiWW -> "gpsiww" | G_PsiWHW -> "gpsiwhw"
| G_PsiZZ -> "gpsizz" | G_PsiZHZH -> "gpsizhzh"
| G_PsiZHZ -> "gpsizhz" | G_PsiZAH -> "gpsizah"
| G_PsiZHAH -> "gpsizhah" | G_PsiAHAH -> "gpsiahah"
| G_PsiZW -> "gpsizw" | G_PsiZWH -> "gpsizwh" | G_PsiAHW -> "gpsiahw"
| G_PsiAHWH -> "gpsiahwh" | G_PsiZHW -> "gpsizhw"
| G_PsiZHWH -> "gpsizhwh"
| G_PsippWW -> "gpsippww" | G_PsippWHW -> "gpsippwhw"
| G_PsippWHWH -> "gpsippwhwh"
| Gs -> "gs" | G2 -> "gs**2" | I_Gs -> "igs"
| G_PsiHW -> "gpsihw" | G_PsiHWH -> "gpsihwh"
| G_Psi0W -> "gpsi0w" | G_Psi0WH -> "gpsi0wh"
| G_Psi1W -> "gpsi1w" | G_Psi1WH -> "gpsi1wh"
| G_PsiPPW -> "gpsippw" | G_PsiPPWH -> "gpsippwh"
| G_Psi1HAH -> "gpsihah" | G_Psi01AH -> "gpsi0ah"
| G_AHPsip -> "gahpsip" | G_Psi1HZ -> "gpsi1hz"
| G_Psi1HZH -> "gpsi1hzh" | G_Psi01Z -> "gpsi01z"
| G_Psi01ZH -> "gpsi01zh" | G_ZPsip -> "gzpsip"
| G_ZPsipp -> "gzpsipp" | G_ZHPsipp -> "gzhpsipp"
| G_HHAA -> "ghhaa" | G_HHWHW -> "ghhwhw" | G_HHZHZ -> "ghhzhz"
| G_HHAHZ -> "ghhahz" | G_HHZHAH -> "ghhzhah"
| G_HPsi0WW -> "ghpsi0ww" | G_HPsi0WHW -> "ghpsi0whw"
| G_HPsi0ZZ -> "ghpsi0zz" | G_HPsi0ZHZH -> "ghpsi0zhzh"
| G_HPsi0ZHZ -> "ghpsi0zhz" | G_HPsi0AHAH -> "ghpsi0ahah"
| G_HPsi0ZAH -> "ghpsi0zah" | G_HPsi0ZHAH -> "ghpsi0zhah"
| G_HPsipWA -> "ghpsipwa" | G_HPsipWHA -> "ghpsipwha"
| G_HPsipWZ -> "ghpsipwz" | G_HPsipWHZ -> "ghpsiwhz"
| G_HPsipWAH -> "ghpsipwah" | G_HPsipWHAH -> "ghpsipwhah"
| G_HPsipWZH -> "ghpsipwzh" | G_HPsipWHZH -> "ghpsipwhzh"
| G_HPsippWW -> "ghpsippww" | G_HPsippWHWH -> "ghpsippwhwh"
| G_HPsippWHW -> "ghpsippwhw" | G_Psi00ZH -> "gpsi00zh"
| G_Psi00AH -> "gpsi00ah" | G_Psi00ZHAH -> "gpsi00zhah"
| G_Psi0pWA -> "gpsi0pwa" | G_Psi0pWHA -> "gpsi0pwha"
| G_Psi0pWZ -> "gpsi0pwz" | G_Psi0pWHZ -> "gpsi0pwhz"
| G_Psi0pWAH -> "gpsi0pwah" | G_Psi0pWHAH -> "gpsi0pwhah"
| G_Psi0pWZH -> "gpsi0pwzh" | G_Psi0pWHZH -> "gpsi0pwhzh"
| G_Psi0ppWW -> "gpsi0ppww" | G_Psi0ppWHWH -> "gpsi0ppwhwh"
| G_Psi0ppWHW -> "gpsi0ppwhw"
| I_G_Psi0pWA -> "i_gpsi0pwa" | I_G_Psi0pWHA -> "i_gpsi0pwha"
| I_G_Psi0pWZ -> "i_gpsi0pwz" | I_G_Psi0pWHZ -> "i_gpsi0pwhz"
| I_G_Psi0pWAH -> "i_gpsi0pwah" | I_G_Psi0pWHAH -> "i_gpsi0pwhah"
| I_G_Psi0pWZH -> "i_gpsi0pwzh" | I_G_Psi0pWHZH -> "i_gpsi0pwhzh"
| I_G_Psi0ppWW -> "i_gpsi0ppww" | I_G_Psi0ppWHWH -> "i_gpsi0ppwhwh"
| I_G_Psi0ppWHW -> "i_gpsi0ppwhw"
| G_PsippZZ -> "gpsippzz" | G_PsippZHZH -> "gpsippzhzh"
| G_PsippAZ -> "gpsippaz" | G_PsippAAH -> "gpsippaah"
| G_PsippZAH -> "gpsippzah"
| G_PsippWA -> "gpsippwa" | G_PsippWHA -> "gpsippwha"
| G_PsippWZ -> "gpsippwz" | G_PsippWHZ -> "gpsippwhz"
| G_PsippWAH -> "gpsippwah" | G_PsippWHAH -> "gpsippwhah"
| G_PsippWZH -> "gpsippwzh" | G_PsippWHZH -> "gpsippwhzh"
| G_PsiccZZ -> "gpsicczz" | G_PsiccAZ -> "gpsiccaz"
| G_PsiccAAH -> "gpsiccaah" | G_PsiccZZH -> "gpsicczzh"
| G_PsiccAZH -> "gpsiccazh" | G_PsiccZAH -> "gpsicczah"
| Mass f -> "mass" ^ flavor_symbol f
| Width f -> "width" ^ flavor_symbol f
end
module Littlest_Tpar (Flags : BSM_flags) =
struct
open Coupling
let default_width = ref Timelike
let use_fudged_width = ref false
let options = Options.create
[ "constant_width", Arg.Unit (fun () -> default_width := Constant),
"use constant width (also in t-channel)";
"fudged_width", Arg.Set use_fudged_width,
"use fudge factor for charge particle width";
"custom_width", Arg.String (fun f -> default_width := Custom f),
"use custom width";
"cancel_widths", Arg.Unit (fun () -> default_width := Vanishing),
"use vanishing width";
"cms_width", Arg.Unit (fun () -> default_width := Complex_Mass),
"use complex mass scheme";
"running_width", Arg.Unit (fun () -> default_width := Running),
"use running width"]
let caveats () = []
type flavor = L of int | N of int | U of int | D of int
| Topp | Toppb
| Ga | Wp | Wm | Z | Gl | Lodd of int | Nodd of int
| Uodd of int | Dodd of int
| WHp | WHm | ZH | AH | Phip | Phim | Phi0 | H | Eta | Psi0
| Psi1 | Psip | Psim | Psipp | Psimm
type gauge = unit
let gauge_symbol () =
failwith "Modellib_BSM.Littlest_Tpar.gauge_symbol: internal error"
let family n = [ L n; N n; U n; D n; Dodd n; Nodd n; Lodd n; Uodd n ]
(* Since [Phi] already belongs to the EW Goldstone bosons we use [Psi]
for the TeV scale complex triplet.
We use the notation Todd1 = Uodd 3, Todd2 = Uodd 4.
*)
let external_flavors () =
[ "1st Generation", ThoList.flatmap family [1; -1];
"2nd Generation", ThoList.flatmap family [2; -2];
"3rd Generation", ThoList.flatmap family [3; -3];
"Heavy Quarks", [Topp; Toppb; Uodd 4; Uodd (-4)];
"Heavy Scalars", [Psi0; Psi1; Psip; Psim; Psipp; Psimm];
"Gauge Bosons", if Flags.u1_gauged then
[Ga; Z; Wp; Wm; Gl; WHp; WHm; ZH; AH]
else
[Ga; Z; Wp; Wm; Gl; WHp; WHm; ZH];
"Higgs", if Flags.u1_gauged then [H]
else [H; Eta];
"Goldstone Bosons", [Phip; Phim; Phi0] ]
let flavors () = ThoList.flatmap snd (external_flavors ())
let spinor n =
if n >= 0 then
Spinor
else
ConjSpinor
let lorentz = function
| L n -> spinor n | N n -> spinor n
| U n -> spinor n | D n -> spinor n
| Topp -> Spinor | Toppb -> ConjSpinor
| Ga | Gl -> Vector
| Wp | Wm | Z | WHp | WHm | ZH | AH -> Massive_Vector
| _ -> Scalar
- let color = function
+ let color = function
| U n -> Color.SUN (if n > 0 then 3 else -3)
| Uodd n -> Color.SUN (if n > 0 then 3 else -3)
| D n -> Color.SUN (if n > 0 then 3 else -3)
| Dodd n -> Color.SUN (if n > 0 then 3 else -3)
| Topp -> Color.SUN 3 | Toppb -> Color.SUN (-3)
| Gl -> Color.AdjSUN 3
| _ -> Color.Singlet
let nc () = 3
let prop_spinor n =
if n >= 0 then
Prop_Spinor
else
Prop_ConjSpinor
let propagator = function
| L n -> prop_spinor n | N n -> prop_spinor n
| Lodd n -> prop_spinor n | Nodd n -> prop_spinor n
| U n -> prop_spinor n | D n -> prop_spinor n
| Uodd n -> prop_spinor n | Dodd n -> prop_spinor n
| Topp -> Prop_Spinor | Toppb -> Prop_ConjSpinor
| Ga | Gl -> Prop_Feynman
| Wp | Wm | Z | WHp | WHm | ZH | AH -> Prop_Unitarity
| Phip | Phim | Phi0 -> Only_Insertion
| H | Eta | Psi0 | Psi1 | Psip | Psim | Psipp | Psimm -> Prop_Scalar
(* Optionally, ask for the fudge factor treatment for the widths of
charged particles. Currently, this only applies to $W^\pm$ and top. *)
let width f =
if !use_fudged_width then
match f with
| Wp | Wm | U 3 | U (-3)
| WHp | WHm | ZH | AH
| Uodd _ | Dodd _ | Nodd _ | Lodd _
| Topp | Toppb -> Fudged
| _ -> !default_width
else
!default_width
let goldstone = function
| Wp -> Some (Phip, Coupling.Integer 1)
| Wm -> Some (Phim, Coupling.Integer 1)
| Z -> Some (Phi0, Coupling.Integer 1)
| _ -> None
let conjugate = function
| L n -> L (-n) | N n -> N (-n)
| Lodd n -> L (-n) | Nodd n -> N (-n)
| U n -> U (-n) | D n -> D (-n)
| Uodd n -> U (-n) | Dodd n -> D (-n)
| Topp -> Toppb | Toppb -> Topp
| Gl -> Gl | Ga -> Ga | Z -> Z
| Wp -> Wm | Wm -> Wp | WHm -> WHp
| WHp -> WHm | ZH -> ZH | AH -> AH
| Psi0 -> Psi0 | Psi1 -> Psi1 | Psip -> Psim
| Psim -> Psip | Psipp -> Psimm | Psimm -> Psipp
| Phip -> Phim | Phim -> Phip | Phi0 -> Phi0
| H -> H | Eta -> Eta
let fermion = function
| L n -> if n > 0 then 1 else -1
| N n -> if n > 0 then 1 else -1
| U n -> if n > 0 then 1 else -1
| D n -> if n > 0 then 1 else -1
| Lodd n -> if n > 0 then 1 else -1
| Nodd n -> if n > 0 then 1 else -1
| Uodd n -> if n > 0 then 1 else -1
| Dodd n -> if n > 0 then 1 else -1
| Topp -> 1 | Toppb -> -1
| Gl | Ga | Z | Wp | Wm | WHp | WHm | AH | ZH -> 0
| _ -> 0
module Ch = Charges.QQ
let ( // ) = Algebra.Small_Rational.make
let charge = function
| L n | Lodd n -> if n > 0 then -1//1 else 1//1
| N n | Nodd n -> 0//1
| U n | Uodd n -> if n > 0 then 2//3 else -2//3
| D n | Dodd n -> if n > 0 then -1//3 else 1//3
| Topp -> 2//3
| Toppb -> -2//3
| Gl | Ga | Z | AH | ZH -> 0//1
| Wp | WHp -> 1//1
| Wm | WHm -> -1//1
| H | Phi0 | Eta | Psi1 | Psi0 -> 0//1
| Phip | Psip -> 1//1
| Phim | Psim -> -1//1
| Psipp -> 2//1
| Psimm -> -2//1
let lepton = function
| L n | N n | Lodd n | Nodd n
-> if n > 0 then 1//1 else -1//1
| U _ | D _ | _ -> 0//1
let baryon = function
| L _ | N _ -> 0//1
| U n | D n | Uodd n | Dodd n
-> if n > 0 then 1//1 else -1//1
| Topp -> 1//1
| Toppb -> -1//1
| _ -> 0//1
let charges f =
[ charge f; lepton f; baryon f]
type constant =
| Unit | Pi | Alpha_QED | Sin2thw
| Sinthw | Costhw | E | G_weak | Vev | VHeavy
| Supp | Supp2
| Sinpsi | Cospsi | Atpsi | Sccs (* Mixing angles of SU(2) *)
| Q_lepton | Q_up | Q_down | Q_Z_up | G_CC | G_CCtop
| G_NC_neutrino | G_NC_lepton | G_NC_up | G_NC_down | G_NC_heavy
| G_NC_h_neutrino | G_NC_h_lepton | G_NC_h_up | G_NC_h_down
| G_CC_heavy | G_ZHTHT | G_ZTHT | G_AHTHTH | G_AHTHT | G_AHTT
| G_CC_WH | G_CC_W
| Gs | I_Gs | G2
| I_Q_W | I_G_ZWW | I_G_WWW
| I_G_AHWW | I_G_ZHWW | I_G_ZWHW | I_G_AHWHWH | I_G_ZHWHWH
| I_G_AHWHW | I_Q_H
| G_WWWW | G_ZZWW | G_AZWW | G_AAWW
| G_WH4 | G_WHWHWW | G_WHWWW | G_WH3W
| G_WWAAH | G_WWAZH | G_WWZZH | G_WWZAH | G_WHWHAAH
| G_WHWHAZH | G_WHWHZZH | G_WHWHZAH | G_WWZHAH
| G_WHWHZHAH | G_WHWZZ | G_WHWAZ | G_WHWAAH | G_WHWZAH
| G_WHWZHZH | G_WHWZHAH | G_WHWAZH | G_WHWZZH
| G_HWW | G_HHWW | G_HZZ | G_HHZZ
| G_PsiWW | G_PsiWHW | G_PsiZZ | G_PsiZHZH
| G_PsiZHZ | G_PsiZAH | G_PsiZHAH | G_PsiAHAH
| G_PsiZW | G_PsiZWH | G_PsiAHW | G_PsiAHWH
| G_PsiZHW | G_PsiZHWH
| G_PsippWW | G_PsippWHW | G_PsippWHWH
| G_PsiHW | G_PsiHWH | G_Psi0W | G_Psi0WH
| G_Psi1W | G_Psi1WH | G_PsiPPW | G_PsiPPWH
| G_Psi1HAH | G_Psi01AH | G_AHPsip | G_Psi1HZ
| G_Psi1HZH | G_Psi01Z | G_Psi01ZH | G_ZPsip | G_ZPsipp | G_ZHPsipp
| G_HHAA | G_HHWHW | G_HHZHZ | G_HHAHZ | G_HHZHAH
| G_HPsi0WW | G_HPsi0WHW | G_HPsi0ZZ
| G_HPsi0ZHZH | G_HPsi0ZHZ | G_HPsi0AHAH | G_HPsi0ZAH | G_HPsi0ZHAH
| G_HPsipWA | G_HPsipWHA | G_HPsipWZ | G_HPsipWHZ | G_HPsipWAH
| G_HPsipWHAH | G_HPsipWZH | G_HPsipWHZH | G_HPsippWW | G_HPsippWHWH
| G_HPsippWHW | G_Psi00ZH | G_Psi00AH | G_Psi00ZHAH
| G_Psi0pWA | G_Psi0pWHA | G_Psi0pWZ | G_Psi0pWHZ | G_Psi0pWAH
| G_Psi0pWHAH | G_Psi0pWZH | G_Psi0pWHZH | G_Psi0ppWW | G_Psi0ppWHWH
| G_Psi0ppWHW | I_G_Psi0pWA | I_G_Psi0pWHA | I_G_Psi0pWZ | I_G_Psi0pWHZ
| I_G_Psi0pWAH | I_G_Psi0pWHAH | I_G_Psi0pWZH | I_G_Psi0pWHZH
| I_G_Psi0ppWW | I_G_Psi0ppWHWH | I_G_Psi0ppWHW
| G_PsippZZ | G_PsippZHZH | G_PsippAZ | G_PsippAAH | G_PsippZAH
| G_PsippWA | G_PsippWHA | G_PsippWZ | G_PsippWHZ | G_PsippWAH
| G_PsippWHAH | G_PsippWZH | G_PsippWHZH
| G_PsiccZZ | G_PsiccAZ | G_PsiccAAH | G_PsiccZZH | G_PsiccAZH
| G_PsiccZAH
| G_Htt | G_Hbb | G_Hcc | G_Htautau | G_H3 | G_H4
| G_Hthth | G_Htht | G_Ethth | G_Etht | G_Ett
| G_HHtt | G_HHthth | G_HHtht
| G_Psi0tt | G_Psi0bb | G_Psi0cc | G_Psi0tautau
| G_Psi1tt | G_Psi1bb | G_Psi1cc | G_Psi1tautau
| G_Psipq3 | G_Psipq2 | G_Psipl3 | G_Psi0tth | G_Psi1tth
| G_Psipbth | G_Ebb
| G_HGaGa | G_HGaZ | G_EGaGa | G_EGaZ | G_EGlGl
| G_HWHW | G_HWHWH | G_HAHAH | G_HZHZ | G_HZHAH | G_HAHZ
| Mass of flavor | Width of flavor
(* Two integer counters for the QCD and EW order of the couplings. *)
- type orders = int * int
+ type coupling_order = QCD | EW
+ let all_coupling_orders () = [QCD; EW]
+ let coupling_order_to_string = function
+ | QCD -> "QCD"
+ | EW -> "EW"
- let orders = function
- | _ -> (0,0)
+ let coupling_orders = function
+ | _ -> failwith "Modellib_BSM.Littlest_Tpar.orders: not implemented yet!"
let input_parameters =
[]
let derived_parameters =
[]
let g_over_2_costh =
Quot (Neg (Atom G_weak), Prod [Integer 2; Atom Costhw])
let nc_coupling c t3 q =
(Real_Array c,
[Prod [g_over_2_costh; Diff (t3, Prod [Integer 2; q; Atom Sin2thw])];
Prod [g_over_2_costh; t3]])
let half = Quot (Integer 1, Integer 2)
let derived_parameter_arrays =
[ nc_coupling G_NC_neutrino half (Integer 0);
nc_coupling G_NC_lepton (Neg half) (Integer (-1));
nc_coupling G_NC_up half (Quot (Integer 2, Integer 3));
nc_coupling G_NC_down (Neg half) (Quot (Integer (-1), Integer 3));
nc_coupling G_NC_h_neutrino half (Integer 0);
nc_coupling G_NC_h_lepton (Neg half) (Integer (-1));
nc_coupling G_NC_h_up half (Quot (Integer 2, Integer 3));
nc_coupling G_NC_h_down (Neg half) (Quot (Integer (-1), Integer 3)) ]
let parameters () =
{ input = input_parameters;
derived = derived_parameters;
derived_arrays = derived_parameter_arrays }
module F = Modeltools.Fusions (struct
type f = flavor
type c = constant
let compare = compare
let conjugate = conjugate
end)
let electromagnetic_currents n =
[ ((L (-n), Ga, L n), FBF (1, Psibar, V, Psi), Q_lepton);
((U (-n), Ga, U n), FBF (1, Psibar, V, Psi), Q_up);
((D (-n), Ga, D n), FBF (1, Psibar, V, Psi), Q_down);
((Lodd (-n), Ga, Lodd n), FBF (1, Psibar, V, Psi), Q_lepton);
((Uodd (-n), Ga, Uodd n), FBF (1, Psibar, V, Psi), Q_up);
((Dodd (-n), Ga, Dodd n), FBF (1, Psibar, V, Psi), Q_down) ]
let color_currents n =
[ ((U (-n), Gl, U n), FBF ((-1), Psibar, V, Psi), Gs);
((D (-n), Gl, D n), FBF ((-1), Psibar, V, Psi), Gs);
((Uodd (-n), Gl, Uodd n), FBF ((-1), Psibar, V, Psi), Gs);
((Dodd (-n), Gl, Dodd n), FBF ((-1), Psibar, V, Psi), Gs) ]
let neutral_currents n =
[ ((L (-n), Z, L n), FBF (1, Psibar, VA, Psi), G_NC_lepton);
((N (-n), Z, N n), FBF (1, Psibar, VA, Psi), G_NC_neutrino);
((U (-n), Z, U n), FBF (1, Psibar, VA, Psi), G_NC_up);
((D (-n), Z, D n), FBF (1, Psibar, VA, Psi), G_NC_down) ]
(* The sign of this coupling is just the one of the T3, being -(1/2) for
leptons and down quarks, and +(1/2) for neutrinos and up quarks. *)
let neutral_heavy_currents n =
([ ((L (-n), ZH, L n), FBF ((-1), Psibar, VL, Psi), G_NC_heavy);
((N (-n), ZH, N n), FBF (1, Psibar, VL, Psi), G_NC_heavy);
((U (-n), ZH, U n), FBF (1, Psibar, VL, Psi), G_NC_heavy);
((D (-n), ZH, D n), FBF ((-1), Psibar, VL, Psi), G_NC_heavy)]
@
(if Flags.u1_gauged then
[ ((L (-n), AH, L n), FBF (1, Psibar, VA, Psi), G_NC_h_lepton);
((N (-n), AH, N n), FBF (1, Psibar, VA, Psi), G_NC_h_neutrino);
((D (-n), AH, D n), FBF (1, Psibar, VA, Psi), G_NC_h_down)]
else
[]))
let heavy_top_currents =
([ ((Toppb, Ga, Topp), FBF (1, Psibar, V, Psi), Q_up);
((Toppb, Z, Topp), FBF (1, Psibar, V, Psi), Q_Z_up);
((Toppb, Gl, Topp), FBF (1, Psibar, V, Psi), Gs);
((Toppb, Z, U 3), FBF (1, Psibar, VL, Psi), G_ZTHT);
((U (-3), Z, Topp), FBF (1, Psibar, VL, Psi), G_ZTHT);
((Toppb, ZH, U 3), FBF (1, Psibar, VL, Psi), G_ZHTHT);
((U (-3), ZH, Topp), FBF (1, Psibar, VL, Psi), G_ZHTHT);
((U (-3), Wp, D 3), FBF (1, Psibar, VL, Psi), G_CCtop);
((D (-3), Wm, U 3), FBF (1, Psibar, VL, Psi), G_CCtop);
((Toppb, WHp, D 3), FBF (1, Psibar, VL, Psi), G_CC_WH);
((D (-3), WHm, Topp), FBF (1, Psibar, VL, Psi), G_CC_WH);
((Toppb, Wp, D 3), FBF (1, Psibar, VL, Psi), G_CC_W);
((D (-3), Wm, Topp), FBF (1, Psibar, VL, Psi), G_CC_W)]
@
(if Flags.u1_gauged then
[ ((U (-3), AH, U 3), FBF (1, Psibar, VA, Psi), G_AHTT);
((Toppb, AH, Topp), FBF (1, Psibar, VA, Psi), G_AHTHTH);
((Toppb, AH, U 3), FBF (1, Psibar, VR, Psi), G_AHTHT);
((U (-3), AH, Topp), FBF (1, Psibar, VR, Psi), G_AHTHT)]
else
[]))
(* \begin{equation}
\mathcal{L}_{\textrm{CC}} =
- \frac{g}{2\sqrt2} \sum_i \bar\psi_i
(T^+\fmslash{W}^+ + T^-\fmslash{W}^-)(1-\gamma_5)\psi_i
\end{equation} *)
let charged_currents n =
[ ((L (-n), Wm, N n), FBF (1, Psibar, VL, Psi), G_CC);
((N (-n), Wp, L n), FBF (1, Psibar, VL, Psi), G_CC);
((L (-n), WHm, N n), FBF (1, Psibar, VL, Psi), G_CC_heavy);
((N (-n), WHp, L n), FBF (1, Psibar, VL, Psi), G_CC_heavy);
((D (-n), WHm, U n), FBF (1, Psibar, VL, Psi), G_CC_heavy);
((U (-n), WHp, D n), FBF (1, Psibar, VL, Psi), G_CC_heavy)]
let quark_currents n =
([ ((D (-n), Wm, U n), FBF (1, Psibar, VL, Psi), G_CC);
((U (-n), Wp, D n), FBF (1, Psibar, VL, Psi), G_CC)]
@
(if Flags.u1_gauged then
[ ((U (-n), AH, U n), FBF (1, Psibar, VA, Psi), G_NC_h_up)]
else
[]))
(* We specialize the third generation since there is an additional shift
coming from the admixture of the heavy top quark. The universal shift,
coming from the mixing in the non-Abelian gauge boson sector is
unobservable. (Redefinition of coupling constants by measured ones. *)
let yukawa =
[ ((U (-3), H, U 3), FBF (1, Psibar, S, Psi), G_Htt);
((D (-3), H, D 3), FBF (1, Psibar, S, Psi), G_Hbb);
((U (-2), H, U 2), FBF (1, Psibar, S, Psi), G_Hcc);
((L (-3), H, L 3), FBF (1, Psibar, S, Psi), G_Htautau)]
let yukawa_add' =
[ ((Toppb, H, Topp), FBF (1, Psibar, S, Psi), G_Hthth);
((Toppb, H, U 3), FBF (1, Psibar, SLR, Psi), G_Htht);
((U (-3), H, Topp), FBF (1, Psibar, SLR, Psi), G_Htht);
((U (-3), Psi0, U 3), FBF (1, Psibar, S, Psi), G_Psi0tt);
((D (-3), Psi0, D 3), FBF (1, Psibar, S, Psi), G_Psi0bb);
((U (-2), Psi0, U 2), FBF (1, Psibar, S, Psi), G_Psi0cc);
((L (-3), Psi0, L 3), FBF (1, Psibar, S, Psi), G_Psi0tautau);
((U (-3), Psi1, U 3), FBF (1, Psibar, P, Psi), G_Psi1tt);
((D (-3), Psi1, D 3), FBF (1, Psibar, P, Psi), G_Psi1bb);
((U (-2), Psi1, U 2), FBF (1, Psibar, P, Psi), G_Psi1cc);
((L (-3), Psi1, L 3), FBF (1, Psibar, P, Psi), G_Psi1tautau);
((U (-3), Psip, D 3), FBF (1, Psibar, SLR, Psi), G_Psipq3);
((U (-2), Psip, D 2), FBF (1, Psibar, SLR, Psi), G_Psipq2);
((N (-3), Psip, L 3), FBF (1, Psibar, SR, Psi), G_Psipl3);
((D (-3), Psim, U 3), FBF (1, Psibar, SLR, Psi), G_Psipq3);
((D (-2), Psim, U 2), FBF (1, Psibar, SLR, Psi), G_Psipq2);
((L (-3), Psim, N 3), FBF (1, Psibar, SL, Psi), G_Psipl3);
((Toppb, Psi0, U 3), FBF (1, Psibar, SL, Psi), G_Psi0tth);
((U (-3), Psi0, Topp), FBF (1, Psibar, SR, Psi), G_Psi0tth);
((Toppb, Psi1, U 3), FBF (1, Psibar, SL, Psi), G_Psi1tth);
((U (-3), Psi1, Topp), FBF (1, Psibar, SR, Psi), G_Psi1tth);
((Toppb, Psip, D 3), FBF (1, Psibar, SL, Psi), G_Psipbth);
((D (-3), Psim, Topp), FBF (1, Psibar, SR, Psi), G_Psipbth)]
let yukawa_add =
if Flags.u1_gauged then
yukawa_add'
else
yukawa_add' @
[ ((U (-3), Eta, U 3), FBF (1, Psibar, P, Psi), G_Ett);
((Toppb, Eta, U 3), FBF (1, Psibar, SLR, Psi), G_Etht);
((D (-3), Eta, D 3), FBF (1, Psibar, P, Psi), G_Ebb);
((U (-3), Eta, Topp), FBF (1, Psibar, SLR, Psi), G_Etht)]
(* \begin{equation}
\mathcal{L}_{\textrm{TGC}} =
- e \partial_\mu A_\nu W_+^\mu W_-^\nu + \ldots
- e \cot\theta_w \partial_\mu Z_\nu W_+^\mu W_-^\nu + \ldots
\end{equation} *)
(* Check. *)
let standard_triple_gauge =
[ ((Ga, Wm, Wp), Gauge_Gauge_Gauge 1, I_Q_W);
((Z, Wm, Wp), Gauge_Gauge_Gauge 1, I_G_ZWW);
((Gl, Gl, Gl), Gauge_Gauge_Gauge 1, I_Gs) ]
let heavy_triple_gauge =
([ ((Ga, WHm, WHp), Gauge_Gauge_Gauge 1, I_Q_W);
((Z, WHm, WHp), Gauge_Gauge_Gauge 1, I_G_ZWW);
((ZH, Wm, Wp), Gauge_Gauge_Gauge 1, I_G_ZHWW);
((Z, WHm, Wp), Gauge_Gauge_Gauge 1, I_G_ZWHW);
((Z, Wm, WHp), Gauge_Gauge_Gauge (-1), I_G_ZWHW);
((ZH, WHm, Wp), Gauge_Gauge_Gauge 1, I_G_WWW);
((ZH, Wm, WHp), Gauge_Gauge_Gauge (-1), I_G_WWW);
((ZH, WHm, WHp), Gauge_Gauge_Gauge (-1), I_G_ZHWHWH)]
@
(if Flags.u1_gauged then
[ ((AH, Wm, Wp), Gauge_Gauge_Gauge 1, I_G_AHWW);
((AH, WHm, Wp), Gauge_Gauge_Gauge 1, I_G_AHWHW);
((AH, Wm, WHp), Gauge_Gauge_Gauge (-1), I_G_AHWHW);
((AH, WHm, WHp), Gauge_Gauge_Gauge 1, I_G_AHWHWH)]
else
[]))
let triple_gauge =
standard_triple_gauge @ heavy_triple_gauge
let gauge4 = Vector4 [(2, C_13_42); (-1, C_12_34); (-1, C_14_23)]
let minus_gauge4 = Vector4 [(-2, C_13_42); (1, C_12_34); (1, C_14_23)]
let standard_quartic_gauge =
[ (Wm, Wp, Wm, Wp), gauge4, G_WWWW;
(Wm, Z, Wp, Z), minus_gauge4, G_ZZWW;
(Wm, Z, Wp, Ga), minus_gauge4, G_AZWW;
(Wm, Ga, Wp, Ga), minus_gauge4, G_AAWW;
(Gl, Gl, Gl, Gl), gauge4, G2]
let heavy_quartic_gauge =
[ (WHm, Wp, WHm, Wp), gauge4, G_WWWW;
(Wm, WHp, Wm, WHp), gauge4, G_WWWW;
(WHm, WHp, WHm, WHp), gauge4, G_WH4;
(Wm, Wp, WHm, WHp), gauge4, G_WHWHWW;
(Wm, Wp, Wm, WHp), gauge4, G_WHWWW;
(Wm, Wp, WHm, Wp), gauge4, G_WHWWW;
(WHm, WHp, Wm, WHp), gauge4, G_WH3W;
(WHm, WHp, WHm, Wp), gauge4, G_WH3W;
(WHm, Z, WHp, Z), minus_gauge4, G_ZZWW;
(WHm, Z, WHp, Ga), minus_gauge4, G_AZWW;
(WHm, Ga, WHp, ZH), minus_gauge4, G_AAWW;
(WHm, Z, WHp, ZH), minus_gauge4, G_ZZWW;
(Wm, ZH, Wp, ZH), minus_gauge4, G_WWWW;
(Wm, Ga, Wp, ZH), minus_gauge4, G_WWAZH;
(Wm, Z, Wp, ZH), minus_gauge4, G_WWZZH;
(WHm, Ga, WHp, ZH), minus_gauge4, G_WHWHAZH;
(WHm, Z, WHp, ZH), minus_gauge4, G_WHWHZZH;
(WHm, ZH, WHp, ZH), minus_gauge4, G_WH4;
(WHm, Z, Wp, Z), minus_gauge4, G_WHWZZ;
(Wm, Z, WHp, Z), minus_gauge4, G_WHWZZ;
(WHm, Ga, Wp, Z), minus_gauge4, G_WHWAZ;
(Wm, Ga, WHp, Z), minus_gauge4, G_WHWAZ;
(WHm, ZH, Wp, ZH), minus_gauge4, G_WHWZHZH;
(Wm, ZH, WHp, ZH), minus_gauge4, G_WHWZHZH;
(WHm, Ga, Wp, ZH), minus_gauge4, G_WHWAZH;
(Wm, Ga, WHp, ZH), minus_gauge4, G_WHWAZH;
(WHm, Z, Wp, ZH), minus_gauge4, G_WHWZZH;
(Wm, Z, WHp, ZH), minus_gauge4, G_WHWZZH]
@
(if Flags.u1_gauged then
[ (Wm, Ga, Wp, AH), minus_gauge4, G_WWAAH;
(Wm, Z, Wp, AH), minus_gauge4, G_WWZAH;
(WHm, Ga, WHp, AH), minus_gauge4, G_WHWHAAH;
(WHm, Z, WHp, AH), minus_gauge4, G_WHWHZAH;
(Wm, ZH, Wp, AH), minus_gauge4, G_WWZHAH;
(WHm, ZH, WHp, AH), minus_gauge4, G_WHWHZHAH;
(WHm, Ga, Wp, AH), minus_gauge4, G_WHWAAH;
(Wm, Ga, WHp, AH), minus_gauge4, G_WHWAAH;
(WHm, Z, Wp, AH), minus_gauge4, G_WHWZAH;
(Wm, Z, WHp, AH), minus_gauge4, G_WHWZAH;
(WHm, ZH, Wp, AH), minus_gauge4, G_WHWZHAH;
(Wm, ZH, WHp, AH), minus_gauge4, G_WHWZHAH]
else
[])
let quartic_gauge =
standard_quartic_gauge @ heavy_quartic_gauge
let standard_gauge_higgs' =
[ ((H, Wp, Wm), Scalar_Vector_Vector 1, G_HWW);
((H, Z, Z), Scalar_Vector_Vector 1, G_HZZ) ]
let heavy_gauge_higgs =
[ ((H, Wp, WHm), Scalar_Vector_Vector 1, G_HWHW);
((H, WHp, Wm), Scalar_Vector_Vector 1, G_HWHW);
((H, WHp, WHm), Scalar_Vector_Vector 1, G_HWHWH);
((H, ZH, ZH), Scalar_Vector_Vector 1, G_HWHWH);
((H, ZH, Z), Scalar_Vector_Vector 1, G_HZHZ);
((H, Wp, Wm), Scalar_Vector_Vector 1, G_HZHAH)]
@
(if Flags.u1_gauged then
[((H, AH, AH), Scalar_Vector_Vector 1, G_HAHAH);
((H, Z, AH), Scalar_Vector_Vector 1, G_HAHZ)]
else
[])
let triplet_gauge_higgs =
[ ((Psi0, Wp, Wm), Scalar_Vector_Vector 1, G_PsiWW);
((Psi0, WHp, WHm), Scalar_Vector_Vector (-1), G_PsiWW);
((Psi0, WHp, Wm), Scalar_Vector_Vector 1, G_PsiWHW);
((Psi0, WHm, Wp), Scalar_Vector_Vector 1, G_PsiWHW);
((Psi0, Z, Z), Scalar_Vector_Vector 1, G_PsiZZ);
((Psi0, ZH, ZH), Scalar_Vector_Vector 1, G_PsiZHZH);
((Psi0, ZH, Z), Scalar_Vector_Vector 1, G_PsiZHZ);
((Psim, Wp, Z), Scalar_Vector_Vector 1, G_PsiZW);
((Psip, Wm, Z), Scalar_Vector_Vector 1, G_PsiZW);
((Psim, WHp, Z), Scalar_Vector_Vector 1, G_PsiZWH);
((Psip, WHm, Z), Scalar_Vector_Vector 1, G_PsiZWH);
((Psim, Wp, ZH), Scalar_Vector_Vector 1, G_PsiZHW);
((Psip, Wm, ZH), Scalar_Vector_Vector 1, G_PsiZHW);
((Psim, WHp, ZH), Scalar_Vector_Vector 1, G_PsiZHWH);
((Psip, WHm, ZH), Scalar_Vector_Vector 1, G_PsiZHWH);
((Psimm, Wp, Wp), Scalar_Vector_Vector 1, G_PsippWW);
((Psipp, Wm, Wm), Scalar_Vector_Vector 1, G_PsippWW);
((Psimm, WHp, Wp), Scalar_Vector_Vector 1, G_PsippWHW);
((Psipp, WHm, Wm), Scalar_Vector_Vector 1, G_PsippWHW);
((Psimm, WHp, WHp), Scalar_Vector_Vector 1, G_PsippWHWH);
((Psipp, WHm, WHm), Scalar_Vector_Vector 1, G_PsippWHWH)]
@
(if Flags.u1_gauged then
[((Psi0, AH, Z), Scalar_Vector_Vector 1, G_PsiZAH);
((Psi0, AH, ZH), Scalar_Vector_Vector 1, G_PsiZHAH);
((Psi0, AH, AH), Scalar_Vector_Vector 1, G_PsiAHAH);
((Psim, Wp, AH), Scalar_Vector_Vector 1, G_PsiAHW);
((Psip, Wm, AH), Scalar_Vector_Vector 1, G_PsiAHW);
((Psim, WHp, AH), Scalar_Vector_Vector 1, G_PsiAHWH);
((Psip, WHm, AH), Scalar_Vector_Vector 1, G_PsiAHWH)]
else
[])
let triplet_gauge2_higgs =
[ ((Wp, H, Psim), Vector_Scalar_Scalar 1, G_PsiHW);
((Wm, H, Psip), Vector_Scalar_Scalar 1, G_PsiHW);
((WHp, H, Psim), Vector_Scalar_Scalar 1, G_PsiHWH);
((WHm, H, Psip), Vector_Scalar_Scalar 1, G_PsiHWH);
((Wp, Psi0, Psim), Vector_Scalar_Scalar 1, G_Psi0W);
((Wm, Psi0, Psip), Vector_Scalar_Scalar 1, G_Psi0W);
((WHp, Psi0, Psim), Vector_Scalar_Scalar 1, G_Psi0WH);
((WHm, Psi0, Psip), Vector_Scalar_Scalar 1, G_Psi0WH);
((Wp, Psi1, Psim), Vector_Scalar_Scalar 1, G_Psi1W);
((Wm, Psi1, Psip), Vector_Scalar_Scalar (-1), G_Psi1W);
((WHp, Psi1, Psim), Vector_Scalar_Scalar 1, G_Psi1WH);
((WHm, Psi1, Psip), Vector_Scalar_Scalar (-1), G_Psi1WH);
((Wp, Psip, Psimm), Vector_Scalar_Scalar 1, G_PsiPPW);
((Wm, Psim, Psipp), Vector_Scalar_Scalar 1, G_PsiPPW);
((WHp, Psip, Psimm), Vector_Scalar_Scalar 1, G_PsiPPWH);
((WHm, Psim, Psipp), Vector_Scalar_Scalar 1, G_PsiPPWH);
((Ga, Psip, Psim), Vector_Scalar_Scalar 1, Q_lepton);
((Ga, Psipp, Psimm), Vector_Scalar_Scalar 2, Q_lepton);
((Z, H, Psi1), Vector_Scalar_Scalar 1, G_Psi1HZ);
((ZH, H, Psi1), Vector_Scalar_Scalar 1, G_Psi1HZH);
((Z, Psi0, Psi1), Vector_Scalar_Scalar 1, G_Psi01Z);
((ZH, Psi0, Psi1), Vector_Scalar_Scalar 1, G_Psi01ZH);
((Z, Psip, Psim), Vector_Scalar_Scalar 1, G_ZPsip);
((Z, Psipp, Psimm), Vector_Scalar_Scalar 2, G_ZPsipp);
((ZH, Psipp, Psimm), Vector_Scalar_Scalar 2, G_ZHPsipp)]
@
(if Flags.u1_gauged then
[((AH, H, Psi1), Vector_Scalar_Scalar 1, G_Psi1HAH);
((AH, Psi0, Psi1), Vector_Scalar_Scalar 1, G_Psi01AH);
((AH, Psip, Psim), Vector_Scalar_Scalar 1, G_AHPsip);
((AH, Psipp, Psimm), Vector_Scalar_Scalar 2, G_AHPsip)]
else [])
let standard_gauge_higgs =
standard_gauge_higgs' @ heavy_gauge_higgs @ triplet_gauge_higgs @
triplet_gauge2_higgs
let standard_gauge_higgs4 =
[ (H, H, Wp, Wm), Scalar2_Vector2 1, G_HHWW;
(H, H, Z, Z), Scalar2_Vector2 1, G_HHZZ ]
let littlest_gauge_higgs4 =
[ (H, H, WHp, WHm), Scalar2_Vector2 (-1), G_HHWW;
(H, H, ZH, ZH), Scalar2_Vector2 (-1), G_HHWW;
(H, H, Wp, WHm), Scalar2_Vector2 1, G_HHWHW;
(H, H, WHp, Wm), Scalar2_Vector2 1, G_HHWHW;
(H, H, ZH, Z), Scalar2_Vector2 (-1), G_HHZHZ;
(H, Psi0, Wp, Wm), Scalar2_Vector2 1, G_HPsi0WW;
(H, Psi0, WHp, WHm), Scalar2_Vector2 (-1), G_HPsi0WW;
(H, Psi0, WHp, Wm), Scalar2_Vector2 1, G_HPsi0WHW;
(H, Psi0, Wp, WHm), Scalar2_Vector2 1, G_HPsi0WHW;
(H, Psi0, Z, Z), Scalar2_Vector2 1, G_HPsi0ZZ;
(H, Psi0, ZH, ZH), Scalar2_Vector2 1, G_HPsi0ZHZH;
(H, Psi0, ZH, Z), Scalar2_Vector2 1, G_HPsi0ZHZ;
(H, Psim, Wp, Ga), Scalar2_Vector2 1, G_HPsipWA;
(H, Psip, Wm, Ga), Scalar2_Vector2 1, G_HPsipWA;
(H, Psim, WHp, Ga), Scalar2_Vector2 1, G_HPsipWHA;
(H, Psip, WHm, Ga), Scalar2_Vector2 1, G_HPsipWHA;
(H, Psim, Wp, Z), Scalar2_Vector2 1, G_HPsipWZ;
(H, Psip, Wm, Z), Scalar2_Vector2 1, G_HPsipWZ;
(H, Psim, WHp, Z), Scalar2_Vector2 1, G_HPsipWHZ;
(H, Psip, WHm, Z), Scalar2_Vector2 1, G_HPsipWHZ;
(H, Psim, Wp, ZH), Scalar2_Vector2 1, G_HPsipWZH;
(H, Psip, Wm, ZH), Scalar2_Vector2 1, G_HPsipWZH;
(H, Psim, WHp, ZH), Scalar2_Vector2 1, G_HPsipWHZH;
(H, Psip, WHm, ZH), Scalar2_Vector2 1, G_HPsipWHZH;
(H, Psimm, Wp, Wp), Scalar2_Vector2 1, G_HPsippWW;
(H, Psipp, Wm, Wm), Scalar2_Vector2 1, G_HPsippWW;
(H, Psimm, WHp, WHp), Scalar2_Vector2 1, G_HPsippWHWH;
(H, Psipp, WHm, WHm), Scalar2_Vector2 1, G_HPsippWHWH;
(H, Psimm, WHp, Wp), Scalar2_Vector2 1, G_HPsippWHW;
(H, Psipp, WHm, Wm), Scalar2_Vector2 1, G_HPsippWHW;
(Psi0, Psi0, Wp, Wm), Scalar2_Vector2 2, G_HHWW;
(Psi0, Psi0, WHp, WHm), Scalar2_Vector2 (-2), G_HHWW;
(Psi0, Psi0, Z, Z), Scalar2_Vector2 4, G_HHZZ;
(Psi0, Psi0, ZH, ZH), Scalar2_Vector2 1, G_Psi00ZH;
(Psi0, Psi0, WHp, Wm), Scalar2_Vector2 2, G_HHWHW;
(Psi0, Psi0, Wp, WHm), Scalar2_Vector2 2, G_HHWHW;
(Psi0, Psi0, Z, ZH), Scalar2_Vector2 4, G_HHZHZ;
(Psi0, Psim, Wp, Ga), Scalar2_Vector2 1, G_Psi0pWA;
(Psi0, Psip, Wm, Ga), Scalar2_Vector2 1, G_Psi0pWA;
(Psi0, Psim, WHp, Ga), Scalar2_Vector2 1, G_Psi0pWHA;
(Psi0, Psip, WHm, Ga), Scalar2_Vector2 1, G_Psi0pWHA;
(Psi0, Psim, Wp, Z), Scalar2_Vector2 1, G_Psi0pWZ;
(Psi0, Psip, Wm, Z), Scalar2_Vector2 1, G_Psi0pWZ;
(Psi0, Psim, WHp, Z), Scalar2_Vector2 1, G_Psi0pWHZ;
(Psi0, Psip, WHm, Z), Scalar2_Vector2 1, G_Psi0pWHZ;
(Psi0, Psim, Wp, ZH), Scalar2_Vector2 1, G_Psi0pWZH;
(Psi0, Psip, Wm, ZH), Scalar2_Vector2 1, G_Psi0pWZH;
(Psi0, Psim, WHp, ZH), Scalar2_Vector2 1, G_Psi0pWHZH;
(Psi0, Psip, WHm, ZH), Scalar2_Vector2 1, G_Psi0pWHZH;
(Psi0, Psimm, Wp, Wp), Scalar2_Vector2 1, G_Psi0ppWW;
(Psi0, Psipp, Wm, Wm), Scalar2_Vector2 1, G_Psi0ppWW;
(Psi0, Psimm, WHp, WHp), Scalar2_Vector2 1, G_Psi0ppWHWH;
(Psi0, Psipp, WHm, WHm), Scalar2_Vector2 1, G_Psi0ppWHWH;
(Psi0, Psimm, WHp, Wp), Scalar2_Vector2 1, G_Psi0ppWHW;
(Psi0, Psipp, WHm, Wm), Scalar2_Vector2 1, G_Psi0ppWHW;
(Psi1, Psi1, Wp, Wm), Scalar2_Vector2 2, G_HHWW;
(Psi1, Psi1, WHp, WHm), Scalar2_Vector2 (-2), G_HHWW;
(Psi1, Psi1, Z, Z), Scalar2_Vector2 4, G_HHZZ;
(Psi1, Psi1, ZH, ZH), Scalar2_Vector2 1, G_Psi00ZH;
(Psi1, Psi1, WHp, Wm), Scalar2_Vector2 2, G_HHWHW;
(Psi1, Psi1, Wp, WHm), Scalar2_Vector2 2, G_HHWHW;
(Psi1, Psi1, Z, ZH), Scalar2_Vector2 4, G_HHZHZ;
(Psi1, Psim, Wp, Ga), Scalar2_Vector2 1, I_G_Psi0pWA;
(Psi1, Psip, Wm, Ga), Scalar2_Vector2 (-1), I_G_Psi0pWA;
(Psi1, Psim, WHp, Ga), Scalar2_Vector2 1, I_G_Psi0pWHA;
(Psi1, Psip, WHm, Ga), Scalar2_Vector2 (-1), I_G_Psi0pWHA;
(Psi1, Psim, Wp, Z), Scalar2_Vector2 1, I_G_Psi0pWZ;
(Psi1, Psip, Wm, Z), Scalar2_Vector2 (-1), I_G_Psi0pWZ;
(Psi1, Psim, WHp, Z), Scalar2_Vector2 1, I_G_Psi0pWHZ;
(Psi1, Psip, WHm, Z), Scalar2_Vector2 (-1), I_G_Psi0pWHZ;
(Psi1, Psim, Wp, ZH), Scalar2_Vector2 1, I_G_Psi0pWZH;
(Psi1, Psip, Wm, ZH), Scalar2_Vector2 (-1), I_G_Psi0pWZH;
(Psi1, Psim, WHp, ZH), Scalar2_Vector2 1, I_G_Psi0pWHZH;
(Psi1, Psip, WHm, ZH), Scalar2_Vector2 (-1), I_G_Psi0pWHZH;
(Psi1, Psimm, Wp, Wp), Scalar2_Vector2 1, I_G_Psi0ppWW;
(Psi1, Psipp, Wm, Wm), Scalar2_Vector2 (-1), I_G_Psi0ppWW;
(Psi1, Psimm, WHp, WHp), Scalar2_Vector2 1, I_G_Psi0ppWHWH;
(Psi1, Psipp, WHm, WHm), Scalar2_Vector2 (-1), I_G_Psi0ppWHWH;
(Psi1, Psimm, WHp, Wp), Scalar2_Vector2 1, I_G_Psi0ppWHW;
(Psi1, Psipp, WHm, Wm), Scalar2_Vector2 (-1), I_G_Psi0ppWHW;
(Psip, Psim, Wp, Wm), Scalar2_Vector2 4, G_HHWW;
(Psip, Psim, WHp, WHm), Scalar2_Vector2 1, G_Psi00ZH;
(Psip, Psim, WHp, Wm), Scalar2_Vector2 4, G_HHWHW;
(Psip, Psim, Wp, WHm), Scalar2_Vector2 4, G_HHWHW;
(Psip, Psim, Z, Z), Scalar2_Vector2 1, G_PsippZZ;
(Psip, Psim, Ga, Ga), Scalar2_Vector2 2, G_AAWW;
(Psip, Psim, ZH, ZH), Scalar2_Vector2 1, G_PsippZHZH;
(Psip, Psim, Ga, Z), Scalar2_Vector2 4, G_PsippAZ;
(Psip, Psimm, Wp, Ga), Scalar2_Vector2 1, G_PsippWA;
(Psim, Psipp, Wm, Ga), Scalar2_Vector2 1, G_PsippWA;
(Psip, Psimm, WHp, Ga), Scalar2_Vector2 1, G_PsippWHA;
(Psim, Psipp, WHm, Ga), Scalar2_Vector2 1, G_PsippWHA;
(Psip, Psimm, Wp, Z), Scalar2_Vector2 1, G_PsippWZ;
(Psim, Psipp, Wm, Z), Scalar2_Vector2 1, G_PsippWZ;
(Psip, Psimm, WHp, Z), Scalar2_Vector2 1, G_PsippWHZ;
(Psim, Psipp, WHm, Z), Scalar2_Vector2 1, G_PsippWHZ;
(Psip, Psimm, Wp, ZH), Scalar2_Vector2 1, G_PsippWZH;
(Psim, Psipp, Wm, ZH), Scalar2_Vector2 1, G_PsippWZH;
(Psip, Psimm, WHp, ZH), Scalar2_Vector2 1, G_PsippWHZH;
(Psim, Psipp, WHm, ZH), Scalar2_Vector2 1, G_PsippWHZH;
(Psipp, Psimm, Wp, Wm), Scalar2_Vector2 2, G_HHWW;
(Psipp, Psimm, WHp, WHm), Scalar2_Vector2 (-2), G_HHWW;
(Psipp, Psimm, WHp, Wm), Scalar2_Vector2 2, G_HHWHW;
(Psipp, Psimm, Wp, WHm), Scalar2_Vector2 2, G_HHWHW;
(Psipp, Psimm, Z, Z), Scalar2_Vector2 1, G_PsiccZZ;
(Psipp, Psimm, Ga, Ga), Scalar2_Vector2 8, G_AAWW;
(Psipp, Psimm, ZH, ZH), Scalar2_Vector2 1, G_Psi00ZH;
(Psipp, Psimm, Ga, Z), Scalar2_Vector2 1, G_PsiccAZ;
(Psipp, Psimm, Z, ZH), Scalar2_Vector2 4, G_PsiccZZH;
(Psipp, Psimm, Ga, ZH), Scalar2_Vector2 4, G_PsiccAZH]
@
(if Flags.u1_gauged then
[(H, H, AH, AH), Scalar2_Vector2 1, G_HHAA;
(H, H, AH, Z), Scalar2_Vector2 (-1), G_HHAHZ;
(H, H, ZH, AH), Scalar2_Vector2 (-1), G_HHZHAH;
(H, Psi0, AH, AH), Scalar2_Vector2 1, G_HPsi0AHAH;
(H, Psi0, Z, AH), Scalar2_Vector2 1, G_HPsi0ZAH;
(H, Psi0, ZH, AH), Scalar2_Vector2 1, G_HPsi0ZHAH;
(H, Psim, Wp, AH), Scalar2_Vector2 1, G_HPsipWAH;
(H, Psip, Wm, AH), Scalar2_Vector2 1, G_HPsipWAH;
(H, Psim, WHp, AH), Scalar2_Vector2 1, G_HPsipWHAH;
(H, Psip, WHm, AH), Scalar2_Vector2 1, G_HPsipWHAH;
(Psi0, Psi0, AH, AH), Scalar2_Vector2 1, G_Psi00AH;
(Psi0, Psi0, Z, AH), Scalar2_Vector2 4, G_HHAHZ;
(Psi0, Psi0, AH, ZH), Scalar2_Vector2 1, G_Psi00ZHAH;
(Psi0, Psim, Wp, AH), Scalar2_Vector2 1, G_Psi0pWAH;
(Psi0, Psip, Wm, AH), Scalar2_Vector2 1, G_Psi0pWAH;
(Psi0, Psim, WHp, AH), Scalar2_Vector2 1, G_Psi0pWHAH;
(Psi0, Psip, WHm, AH), Scalar2_Vector2 1, G_Psi0pWHAH;
(Psi1, Psi1, AH, AH), Scalar2_Vector2 1, G_Psi00AH;
(Psi1, Psi1, Z, AH), Scalar2_Vector2 4, G_HHAHZ;
(Psi1, Psi1, AH, ZH), Scalar2_Vector2 1, G_Psi00ZHAH;
(Psi1, Psim, Wp, AH), Scalar2_Vector2 1, I_G_Psi0pWAH;
(Psi1, Psip, Wm, AH), Scalar2_Vector2 (-1), I_G_Psi0pWAH;
(Psi1, Psim, WHp, AH), Scalar2_Vector2 1, I_G_Psi0pWHAH;
(Psi1, Psip, WHm, AH), Scalar2_Vector2 (-1), I_G_Psi0pWHAH;
(Psip, Psim, AH, AH), Scalar2_Vector2 1, G_Psi00AH;
(Psip, Psim, Ga, AH), Scalar2_Vector2 4, G_PsippAAH;
(Psip, Psim, Z, AH), Scalar2_Vector2 4, G_PsippZAH;
(Psip, Psimm, Wp, AH), Scalar2_Vector2 1, G_PsippWAH;
(Psim, Psipp, Wm, AH), Scalar2_Vector2 1, G_PsippWAH;
(Psip, Psimm, WHp, AH), Scalar2_Vector2 1, G_PsippWHAH;
(Psim, Psipp, WHm, AH), Scalar2_Vector2 1, G_PsippWHAH;
(Psipp, Psimm, AH, AH), Scalar2_Vector2 1, G_Psi00AH;
(Psipp, Psimm, AH, ZH), Scalar2_Vector2 (-1), G_Psi00ZHAH;
(Psipp, Psimm, Ga, AH), Scalar2_Vector2 4, G_PsiccAAH;
(Psipp, Psimm, Z, AH), Scalar2_Vector2 4, G_PsiccZAH]
else [])
let standard_higgs =
[ (H, H, H), Scalar_Scalar_Scalar 1, G_H3 ]
let anomaly_higgs =
[ (Eta, Gl, Gl), Dim5_Scalar_Gauge2_Skew 1, G_EGlGl;
(Eta, Ga, Ga), Dim5_Scalar_Gauge2_Skew 1, G_EGaGa;
(Eta, Ga, Z), Dim5_Scalar_Gauge2_Skew 1, G_EGaZ]
(* @ [ (H, Ga, Ga), Dim5_Scalar_Gauge2 1, G_HGaGa;
(H, Ga, Z), Dim5_Scalar_Gauge2 1, G_HGaZ ] *)
let standard_higgs4 =
[ (H, H, H, H), Scalar4 1, G_H4 ]
let gauge_higgs =
standard_gauge_higgs
let gauge_higgs4 =
standard_gauge_higgs4
let higgs =
standard_higgs
let higgs4 =
standard_higgs4
let top_quartic =
[ ((U (-3), H, H, U 3), GBBG (1, Psibar, S2, Psi), G_HHtt);
((Toppb, H, H, Topp), GBBG (1, Psibar, S2, Psi), G_HHthth);
((U (-3), H, H, Topp), GBBG (1, Psibar, S2LR, Psi), G_HHtht);
((Toppb, H, H, U 3), GBBG (1, Psibar, S2LR, Psi), G_HHtht)]
let goldstone_vertices =
[ ((Phi0, Wm, Wp), Scalar_Vector_Vector 1, I_G_ZWW);
((Phip, Ga, Wm), Scalar_Vector_Vector 1, I_Q_W);
((Phip, Z, Wm), Scalar_Vector_Vector 1, I_G_ZWW);
((Phim, Wp, Ga), Scalar_Vector_Vector 1, I_Q_W);
((Phim, Wp, Z), Scalar_Vector_Vector 1, I_G_ZWW) ]
let vertices3 =
(ThoList.flatmap electromagnetic_currents [1;2;3] @
ThoList.flatmap neutral_currents [1;2;3] @
ThoList.flatmap color_currents [1;2;3] @
ThoList.flatmap neutral_heavy_currents [1;2;3] @
ThoList.flatmap charged_currents [1;2;3] @
ThoList.flatmap quark_currents [1;2] @
heavy_top_currents @
(if Flags.u1_gauged then []
else anomaly_higgs) @
yukawa @ yukawa_add @ triple_gauge @
gauge_higgs @ higgs @ goldstone_vertices)
let vertices4 =
quartic_gauge @ gauge_higgs4 @ higgs4 @ top_quartic
let vertices () = (vertices3, vertices4, [])
(* For efficiency, make sure that [F.of_vertices vertices] is
evaluated only once. *)
let table = F.of_vertices (vertices ())
let fuse2 = F.fuse2 table
let fuse3 = F.fuse3 table
let fuse = F.fuse table
let max_degree () = 4
let flavor_of_string = function
| "e-" -> L 1 | "e+" -> L (-1)
| "mu-" -> L 2 | "mu+" -> L (-2)
| "tau-" -> L 3 | "tau+" -> L (-3)
| "nue" -> N 1 | "nuebar" -> N (-1)
| "numu" -> N 2 | "numubar" -> N (-2)
| "nutau" -> N 3 | "nutaubar" -> N (-3)
| "u" -> U 1 | "ubar" -> U (-1)
| "c" -> U 2 | "cbar" -> U (-2)
| "t" -> U 3 | "tbar" -> U (-3)
| "d" -> D 1 | "dbar" -> D (-1)
| "s" -> D 2 | "sbar" -> D (-2)
| "b" -> D 3 | "bbar" -> D (-3)
| "tp" -> Topp | "tpbar" -> Toppb
| "g" -> Gl
| "A" -> Ga | "Z" | "Z0" -> Z
| "AH" | "AH0" | "Ah" | "Ah0" -> AH
| "ZH" | "ZH0" | "Zh" | "Zh0" -> ZH
| "W+" -> Wp | "W-" -> Wm
| "WH+" -> WHp | "WH-" -> WHm
| "H" | "h" -> H | "eta" | "Eta" -> Eta
| "Psi" | "Psi0" | "psi" | "psi0" -> Psi0
| "Psi1" | "psi1" -> Psi1
| "Psi+" | "psi+" | "Psip" | "psip" -> Psip
| "Psi-" | "psi-" | "Psim" | "psim" -> Psim
| "Psi++" | "psi++" | "Psipp" | "psipp" -> Psipp
| "Psi--" | "psi--" | "Psimm" | "psimm" -> Psimm
| _ -> invalid_arg "Modellib_BSM.Littlest_Tpar.flavor_of_string"
let flavor_to_string = function
| L 1 -> "e-" | L (-1) -> "e+"
| L 2 -> "mu-" | L (-2) -> "mu+"
| L 3 -> "tau-" | L (-3) -> "tau+"
| L _ -> invalid_arg "Modellib_BSM.Littlest_Tpar.flavor_to_string"
| N 1 -> "nue" | N (-1) -> "nuebar"
| N 2 -> "numu" | N (-2) -> "numubar"
| N 3 -> "nutau" | N (-3) -> "nutaubar"
| N _ -> invalid_arg "Modellib_BSM.Littlest_Tpar.flavor_to_string"
| Lodd 1 -> "l1odd-" | Lodd (-1) -> "l1odd+"
| Lodd 2 -> "l2odd-" | Lodd (-2) -> "l2odd+"
| Lodd 3 -> "l3odd-" | Lodd (-3) -> "l3odd+"
| Lodd _ -> invalid_arg "Modellib_BSM.Littlest_Tpar.flavor_to_string"
| Nodd 1 -> "n1odd" | Nodd (-1) -> "n1oddbar"
| Nodd 2 -> "n2odd" | Nodd (-2) -> "n2oddbar"
| Nodd 3 -> "n3odd" | Nodd (-3) -> "n3oddbar"
| Nodd _ -> invalid_arg "Modellib_BSM.Littlest_Tpar.flavor_to_string"
| U 1 -> "u" | U (-1) -> "ubar"
| U 2 -> "c" | U (-2) -> "cbar"
| U 3 -> "t" | U (-3) -> "tbar"
| U _ -> invalid_arg "Modellib_BSM.Littlest_Tpar.flavor_to_string"
| D 1 -> "d" | D (-1) -> "dbar"
| D 2 -> "s" | D (-2) -> "sbar"
| D 3 -> "b" | D (-3) -> "bbar"
| D _ -> invalid_arg "Modellib_BSM.Littlest_Tpar.flavor_to_string"
| Uodd 1 -> "uodd" | Uodd (-1) -> "uoddbar"
| Uodd 2 -> "codd" | Uodd (-2) -> "coddbar"
| Uodd 3 -> "t1odd" | Uodd (-3) -> "t1oddbar"
| Uodd 4 -> "t2odd" | Uodd (-4) -> "t2oddbar"
| Uodd _ -> invalid_arg "Modellib_BSM.Littlest_Tpar.flavor_to_string"
| Dodd 1 -> "dodd" | Dodd (-1) -> "doddbar"
| Dodd 2 -> "sodd" | Dodd (-2) -> "soddbar"
| Dodd 3 -> "bodd" | Dodd (-3) -> "boddbar"
| Dodd _ -> invalid_arg "Modellib_BSM.Littlest_Tpar.flavor_to_string"
| Topp -> "tp" | Toppb -> "tpbar"
| Gl -> "g"
| Ga -> "A" | Z -> "Z"
| Wp -> "W+" | Wm -> "W-"
| ZH -> "ZH" | AH -> "AH" | WHp -> "WHp" | WHm -> "WHm"
| Phip -> "phi+" | Phim -> "phi-" | Phi0 -> "phi0"
| H -> "H" | Eta -> "Eta"
| Psi0 -> "Psi0" | Psi1 -> "Psi1" | Psip -> "Psi+"
| Psim -> "Psi-" | Psipp -> "Psi++" | Psimm -> "Psi--"
let flavor_to_TeX = function
| L 1 -> "e^-" | L (-1) -> "e^+"
| L 2 -> "\\mu^-" | L (-2) -> "\\mu^+"
| L 3 -> "\\tau^-" | L (-3) -> "\\tau^+"
| L _ -> invalid_arg "Modellib_BSM.Littlest_Tpar.flavor_to_TeX"
| N 1 -> "\\nu_e" | N (-1) -> "\\bar{\\nu}_e"
| N 2 -> "\\nu_\\mu" | N (-2) -> "\\bar{\\nu}_\\mu"
| N 3 -> "\\nu_\\tau" | N (-3) -> "\\bar{\\nu}_\\tau"
| N _ -> invalid_arg "Modellib_BSM.Littlest_Tpar.flavor_to_TeX"
| Lodd 1 -> "L_1^-" | Lodd (-1) -> "L_1^+"
| Lodd 2 -> "L_2^-" | Lodd (-2) -> "L_2^+"
| Lodd 3 -> "L_3^-" | Lodd (-3) -> "L_3^+"
| Lodd _ -> invalid_arg "Modellib_BSM.Littlest_Tpar.flavor_to_TeX"
| Nodd 1 -> "N_1" | Nodd (-1) -> "\\bar{N}_1"
| Nodd 2 -> "N_2" | Nodd (-2) -> "\\bar{N}_2"
| Nodd 3 -> "N_3" | Nodd (-3) -> "\\bar{N}_3"
| Nodd _ -> invalid_arg "Modellib_BSM.Littlest_Tpar.flavor_to_TeX"
| U 1 -> "u" | U (-1) -> "\\bar{u}"
| U 2 -> "c" | U (-2) -> "\\bar{c}"
| U 3 -> "t" | U (-3) -> "\\bar{t}"
| U _ -> invalid_arg "Modellib_BSM.Littlest_Tpar.flavor_to_TeX"
| D 1 -> "d" | D (-1) -> "\\bar{d}"
| D 2 -> "s" | D (-2) -> "\\bar{s}"
| D 3 -> "b" | D (-3) -> "\\bar{b}"
| D _ -> invalid_arg "Modellib_BSM.Littlest_Tpar.flavor_to_TeX"
| Uodd 1 -> "U" | Uodd (-1) -> "\\bar{U}"
| Uodd 2 -> "C" | Uodd (-2) -> "\\bar{C}"
| Uodd 3 -> "T_1" | Uodd (-3) -> "\\bar{T}_1"
| Uodd 4 -> "T_2" | Uodd (-4) -> "\\bar{T}_2"
| Uodd _ -> invalid_arg "Modellib_BSM.Littlest_Tpar.flavor_to_TeX"
| Dodd 1 -> "D" | Dodd (-1) -> "\\bar{D}"
| Dodd 2 -> "S" | Dodd (-2) -> "\\bar{S}"
| Dodd 3 -> "B" | Dodd (-3) -> "\\bar{B}"
| Dodd _ -> invalid_arg "Modellib_BSM.Littlest_Tpar.flavor_to_TeX"
| Topp -> "T^\\prime" | Toppb -> "\\bar{T}^\\prime"
| Gl -> "g"
| Ga -> "\\gamma" | Z -> "Z"
| Wp -> "W^+" | Wm -> "W^-"
| ZH -> "Z_H" | AH -> "\\gamma_H" | WHp -> "W_H^+" | WHm -> "W_H^-"
| Phip -> "\\Phi^+" | Phim -> "\\Phi^-" | Phi0 -> "\\Phi^0"
| H -> "H" | Eta -> "\\eta"
| Psi0 -> "\\Psi_S" | Psi1 -> "\\Psi_P" | Psip -> "\\Psi^+"
| Psim -> "\\Psi^-" | Psipp -> "\\Psi^{++}" | Psimm -> "\\Psi^{--}"
let flavor_symbol = function
| L n when n > 0 -> "l" ^ string_of_int n
| L n -> "l" ^ string_of_int (abs n) ^ "b"
| Lodd n when n > 0 -> "lodd" ^ string_of_int n
| Lodd n -> "lodd" ^ string_of_int (abs n) ^ "b"
| N n when n > 0 -> "n" ^ string_of_int n
| N n -> "n" ^ string_of_int (abs n) ^ "b"
| Nodd n when n > 0 -> "nodd" ^ string_of_int n
| Nodd n -> "nodd" ^ string_of_int (abs n) ^ "b"
| U n when n > 0 -> "u" ^ string_of_int n
| U n -> "u" ^ string_of_int (abs n) ^ "b"
| D n when n > 0 -> "d" ^ string_of_int n
| D n -> "d" ^ string_of_int (abs n) ^ "b"
| Uodd n when n > 0 -> "uodd" ^ string_of_int n
| Uodd n -> "uodd" ^ string_of_int (abs n) ^ "b"
| Dodd n when n > 0 -> "dodd" ^ string_of_int n
| Dodd n -> "dodd" ^ string_of_int (abs n) ^ "b"
| Topp -> "tp" | Toppb -> "tpb"
| Gl -> "gl"
| Ga -> "a" | Z -> "z"
| Wp -> "wp" | Wm -> "wm"
| ZH -> "zh" | AH -> "ah" | WHp -> "whp" | WHm -> "whm"
| Phip -> "pp" | Phim -> "pm" | Phi0 -> "p0"
| H -> "h" | Eta -> "eta"
| Psi0 -> "psi0" | Psi1 -> "psi1" | Psip -> "psip"
| Psim -> "psim" | Psipp -> "psipp" | Psimm -> "psimm"
(* There are PDG numbers for Z', Z'', W', 32-34, respectively.
We just introduce a number 38 for Y0 as a Z'''.
As well, there is the number 8 for a t'. But we cheat a little bit and
take the number 35 which is reserved for a heavy scalar Higgs for the
Eta scalar.
For the heavy Higgs states we take 35 and 36 for the neutral ones, 37 for
the charged and 38 for the doubly-charged.
The pseudoscalar gets the 39.
For the odd fermions we add 40 to the values for the SM particles.
*)
let pdg = function
| L n when n > 0 -> 9 + 2*n
| L n -> - 9 + 2*n
| N n when n > 0 -> 10 + 2*n
| N n -> - 10 + 2*n
| U n when n > 0 -> 2*n
| U n -> 2*n
| D n when n > 0 -> - 1 + 2*n
| D n -> 1 + 2*n
| Lodd n when n > 0 -> 49 + 2*n
| Lodd n -> - 49 + 2*n
| Nodd n when n > 0 -> 50 + 2*n
| Nodd n -> - 50 + 2*n
| Uodd n when n > 0 -> 40 + 2*n
| Uodd n -> -40 + 2*n
| Dodd n when n > 0 -> 39 + 2*n
| Dodd n -> -39 + 2*n
| Topp -> 8 | Toppb -> (-8)
| Gl -> 21
| Ga -> 22 | Z -> 23
| Wp -> 24 | Wm -> (-24)
| AH -> 32 | ZH -> 33 | WHp -> 34 | WHm -> (-34)
| Phip | Phim -> 27 | Phi0 -> 26
| Psi0 -> 35 | Psi1 -> 36 | Psip -> 37 | Psim -> (-37)
| Psipp -> 38 | Psimm -> (-38)
| H -> 25 | Eta -> 39
let mass_symbol f =
"mass(" ^ string_of_int (abs (pdg f)) ^ ")"
let width_symbol f =
"width(" ^ string_of_int (abs (pdg f)) ^ ")"
let constant_symbol = function
| Unit -> "unit" | Pi -> "PI" | VHeavy -> "vheavy"
| Alpha_QED -> "alpha" | E -> "e" | G_weak -> "g" | Vev -> "vev"
| Sin2thw -> "sin2thw" | Sinthw -> "sinthw" | Costhw -> "costhw"
| Sinpsi -> "sinpsi" | Cospsi -> "cospsi"
| Atpsi -> "atpsi" | Sccs -> "sccs"
| Supp -> "vF" | Supp2 -> "v2F2"
| Q_lepton -> "qlep" | Q_up -> "qup" | Q_down -> "qdwn"
| Q_Z_up -> "qzup"
| G_ZHTHT -> "gzhtht" | G_ZTHT -> "gztht"
| G_AHTHTH -> "gahthth" | G_AHTHT -> "gahtht" | G_AHTT -> "gahtt"
| G_NC_lepton -> "gnclep" | G_NC_neutrino -> "gncneu"
| G_NC_up -> "gncup" | G_NC_down -> "gncdwn"
| G_CC -> "gcc" | G_CCtop -> "gcctop" | G_CC_heavy -> "gcch"
| G_CC_WH -> "gccwh" | G_CC_W -> "gccw"
| G_NC_h_lepton -> "gnchlep" | G_NC_h_neutrino -> "gnchneu"
| G_NC_h_up -> "gnchup" | G_NC_h_down -> "gnchdwn"
| G_NC_heavy -> "gnch"
| I_Q_W -> "iqw" | I_G_ZWW -> "igzww" | I_G_WWW -> "igwww"
| I_G_AHWW -> "igahww" | I_G_ZHWW -> "igzhww" | I_G_ZWHW -> "igzwhw"
| I_G_AHWHWH -> "igahwhwh" | I_G_ZHWHWH -> "igzhwhwh"
| I_G_AHWHW -> "igahwhw"
| I_Q_H -> "iqh"
| Gs -> "gs" | I_Gs -> "igs" | G2 -> "gs**2"
| G_WWWW -> "gw4" | G_ZZWW -> "gzzww"
| G_AZWW -> "gazww" | G_AAWW -> "gaaww"
| G_WH4 -> "gwh4" | G_WHWHWW -> "gwhwhww" | G_WHWWW -> "gwhwww"
| G_WH3W -> "gwh3w"
| G_WWAAH -> "gwwaah" | G_WWAZH -> "gwwazh" | G_WWZZH -> "gwwzzh"
| G_WWZAH -> "gwwzah" | G_WHWHAAH -> "gwhwhaah"
| G_WHWHAZH -> "gwhwhazh" | G_WHWHZZH -> "gwhwhzzh"
| G_WHWHZAH -> "gwhwhzah"
| G_WWZHAH -> "gwwzhah" | G_WHWHZHAH -> "gwhwhzhah"
| G_WHWZZ -> "gwhwzz" | G_WHWAZ -> "gwhwaz"
| G_WHWAAH -> "gwhwaah" | G_WHWZAH -> "gwhwzah"
| G_WHWZHZH -> "gwhwzhzh" | G_WHWZHAH -> "gwhwzhah"
| G_WHWAZH -> "gwhwazh" | G_WHWZZH -> "gwhwzzh"
| G_HWW -> "ghww" | G_HZZ -> "ghzz"
| G_HHWW -> "ghhww" | G_HHZZ -> "ghhzz"
| G_HWHW -> "ghwhw" | G_HWHWH -> "ghwhwh" | G_HAHAH -> "ghahah"
| G_HZHZ -> "ghzhz" | G_HZHAH -> "ghzhah"
| G_HAHZ -> "ghahz"
| G_Htt -> "ghtt" | G_Hbb -> "ghbb"
| G_Htautau -> "ghtautau" | G_Hcc -> "ghcc"
| G_Hthth -> "ghthth" | G_Htht -> "ghtht"
| G_HHtt -> "ghhtt" | G_HHthth -> "ghhthth" | G_HHtht -> "ghhtht"
| G_Psi0tt -> "gpsi0tt" | G_Psi0bb -> "gpsi0bb"
| G_Psi0cc -> "gpsi0cc" | G_Psi0tautau -> "gpsi0tautau"
| G_Psi1tt -> "gpsi1tt" | G_Psi1bb -> "gpsi1bb"
| G_Psi1cc -> "gpsi1cc" | G_Psi1tautau -> "gpsi1tautau"
| G_Psipq3 -> "gpsipq3" | G_Psipq2 -> "gpsipq2" | G_Psipl3 -> "gpsipl3"
| G_Psi0tth -> "gpsi0tth" | G_Psi1tth -> "gpsi1tth"
| G_Psipbth -> "gpsipbth"
| G_Ethth -> "gethth" | G_Etht -> "getht"
| G_Ett -> "gett" | G_Ebb -> "gebb"
| G_HGaGa -> "ghgaga" | G_HGaZ -> "ghgaz"
| G_EGaGa -> "geaa" | G_EGaZ -> "geaz" | G_EGlGl -> "gegg"
| G_H3 -> "gh3" | G_H4 -> "gh4"
| G_PsiWW -> "gpsiww" | G_PsiWHW -> "gpsiwhw"
| G_PsiZZ -> "gpsizz" | G_PsiZHZH -> "gpsizhzh"
| G_PsiZHZ -> "gpsizhz" | G_PsiZAH -> "gpsizah"
| G_PsiZHAH -> "gpsizhah" | G_PsiAHAH -> "gpsiahah"
| G_PsiZW -> "gpsizw" | G_PsiZWH -> "gpsizwh" | G_PsiAHW -> "gpsiahw"
| G_PsiAHWH -> "gpsiahwh" | G_PsiZHW -> "gpsizhw"
| G_PsiZHWH -> "gpsizhwh"
| G_PsippWW -> "gpsippww" | G_PsippWHW -> "gpsippwhw"
| G_PsippWHWH -> "gpsippwhwh"
| G_PsiHW -> "gpsihw" | G_PsiHWH -> "gpsihwh"
| G_Psi0W -> "gpsi0w" | G_Psi0WH -> "gpsi0wh"
| G_Psi1W -> "gpsi1w" | G_Psi1WH -> "gpsi1wh"
| G_PsiPPW -> "gpsippw" | G_PsiPPWH -> "gpsippwh"
| G_Psi1HAH -> "gpsihah" | G_Psi01AH -> "gpsi0ah"
| G_AHPsip -> "gahpsip" | G_Psi1HZ -> "gpsi1hz"
| G_Psi1HZH -> "gpsi1hzh" | G_Psi01Z -> "gpsi01z"
| G_Psi01ZH -> "gpsi01zh" | G_ZPsip -> "gzpsip"
| G_ZPsipp -> "gzpsipp" | G_ZHPsipp -> "gzhpsipp"
| G_HHAA -> "ghhaa" | G_HHWHW -> "ghhwhw" | G_HHZHZ -> "ghhzhz"
| G_HHAHZ -> "ghhahz" | G_HHZHAH -> "ghhzhah"
| G_HPsi0WW -> "ghpsi0ww" | G_HPsi0WHW -> "ghpsi0whw"
| G_HPsi0ZZ -> "ghpsi0zz" | G_HPsi0ZHZH -> "ghpsi0zhzh"
| G_HPsi0ZHZ -> "ghpsi0zhz" | G_HPsi0AHAH -> "ghpsi0ahah"
| G_HPsi0ZAH -> "ghpsi0zah" | G_HPsi0ZHAH -> "ghpsi0zhah"
| G_HPsipWA -> "ghpsipwa" | G_HPsipWHA -> "ghpsipwha"
| G_HPsipWZ -> "ghpsipwz" | G_HPsipWHZ -> "ghpsiwhz"
| G_HPsipWAH -> "ghpsipwah" | G_HPsipWHAH -> "ghpsipwhah"
| G_HPsipWZH -> "ghpsipwzh" | G_HPsipWHZH -> "ghpsipwhzh"
| G_HPsippWW -> "ghpsippww" | G_HPsippWHWH -> "ghpsippwhwh"
| G_HPsippWHW -> "ghpsippwhw" | G_Psi00ZH -> "gpsi00zh"
| G_Psi00AH -> "gpsi00ah" | G_Psi00ZHAH -> "gpsi00zhah"
| G_Psi0pWA -> "gpsi0pwa" | G_Psi0pWHA -> "gpsi0pwha"
| G_Psi0pWZ -> "gpsi0pwz" | G_Psi0pWHZ -> "gpsi0pwhz"
| G_Psi0pWAH -> "gpsi0pwah" | G_Psi0pWHAH -> "gpsi0pwhah"
| G_Psi0pWZH -> "gpsi0pwzh" | G_Psi0pWHZH -> "gpsi0pwhzh"
| G_Psi0ppWW -> "gpsi0ppww" | G_Psi0ppWHWH -> "gpsi0ppwhwh"
| G_Psi0ppWHW -> "gpsi0ppwhw"
| I_G_Psi0pWA -> "i_gpsi0pwa" | I_G_Psi0pWHA -> "i_gpsi0pwha"
| I_G_Psi0pWZ -> "i_gpsi0pwz" | I_G_Psi0pWHZ -> "i_gpsi0pwhz"
| I_G_Psi0pWAH -> "i_gpsi0pwah" | I_G_Psi0pWHAH -> "i_gpsi0pwhah"
| I_G_Psi0pWZH -> "i_gpsi0pwzh" | I_G_Psi0pWHZH -> "i_gpsi0pwhzh"
| I_G_Psi0ppWW -> "i_gpsi0ppww" | I_G_Psi0ppWHWH -> "i_gpsi0ppwhwh"
| I_G_Psi0ppWHW -> "i_gpsi0ppwhw"
| G_PsippZZ -> "gpsippzz" | G_PsippZHZH -> "gpsippzhzh"
| G_PsippAZ -> "gpsippaz" | G_PsippAAH -> "gpsippaah"
| G_PsippZAH -> "gpsippzah"
| G_PsippWA -> "gpsippwa" | G_PsippWHA -> "gpsippwha"
| G_PsippWZ -> "gpsippwz" | G_PsippWHZ -> "gpsippwhz"
| G_PsippWAH -> "gpsippwah" | G_PsippWHAH -> "gpsippwhah"
| G_PsippWZH -> "gpsippwzh" | G_PsippWHZH -> "gpsippwhzh"
| G_PsiccZZ -> "gpsicczz" | G_PsiccAZ -> "gpsiccaz"
| G_PsiccAAH -> "gpsiccaah" | G_PsiccZZH -> "gpsicczzh"
| G_PsiccAZH -> "gpsiccazh" | G_PsiccZAH -> "gpsicczah"
| Mass f -> "mass" ^ flavor_symbol f
| Width f -> "width" ^ flavor_symbol f
end
module Simplest (Flags : BSM_flags) =
struct
open Coupling
let default_width = ref Timelike
let use_fudged_width = ref false
let options = Options.create
[ "constant_width", Arg.Unit (fun () -> default_width := Constant),
"use constant width (also in t-channel)";
"fudged_width", Arg.Set use_fudged_width,
"use fudge factor for charge particle width";
"custom_width", Arg.String (fun f -> default_width := Custom f),
"use custom width";
"cancel_widths", Arg.Unit (fun () -> default_width := Vanishing),
"use vanishing width";
"cms_width", Arg.Unit (fun () -> default_width := Complex_Mass),
"use complex mass scheme";
"running_width", Arg.Unit (fun () -> default_width := Running),
"use running width"]
let caveats () = []
(* We do not introduce the Goldstones for the heavy vectors here. The heavy
quarks are simply numerated by their generation, the assignments whether
they are up- or down-type will be defined by the model. *)
type flavor = L of int | N of int | U of int | D of int | QH of int
| NH of int | Wp | Wm | Ga | Z | Xp | Xm | X0 | Y0 | ZH
| Phip | Phim | Phi0 | H | Eta | Gl
type gauge = unit
let gauge_symbol () =
failwith "Modellib_BSM.Simplest.gauge_symbol: internal error"
let family n = [ L n; N n; U n; D n; QH n; NH n ]
(* Note that we add all heavy quarks, [U], [D], [C], [S], in order to have
both embeddings included. *)
let external_flavors () =
[ "1st Generation (incl. heavy)", ThoList.flatmap family [1; -1];
"2nd Generation (incl. heavy)", ThoList.flatmap family [2; -2];
"3rd Generation (incl. heavy)", ThoList.flatmap family [3; -3];
"Gauge Bosons", [Ga; Z; Wp; Wm; Gl; Xp; Xm; X0; Y0; ZH];
"Higgs", [H; Eta];
"Goldstone Bosons", [Phip; Phim; Phi0] ]
let flavors () = ThoList.flatmap snd (external_flavors ())
let spinor n =
if n >= 0 then
Spinor
else
ConjSpinor
let lorentz = function
| L n -> spinor n | N n -> spinor n
| U n -> spinor n | D n -> spinor n
| QH n -> spinor n | NH n -> spinor n
| Ga | Gl -> Vector
| Wp | Wm | Z | Xp | Xm | X0 | Y0 | ZH -> Massive_Vector
| _ -> Scalar
- let color = function
+ let color = function
| U n -> Color.SUN (if n > 0 then 3 else -3)
| D n -> Color.SUN (if n > 0 then 3 else -3)
| QH n -> Color.SUN (if n > 0 then 3 else -3)
| Gl -> Color.AdjSUN 3
| _ -> Color.Singlet
let nc () = 3
let prop_spinor n =
if n >= 0 then
Prop_Spinor
else
Prop_ConjSpinor
let propagator = function
| L n -> prop_spinor n | N n -> prop_spinor n
| U n -> prop_spinor n | D n -> prop_spinor n
| QH n -> prop_spinor n | NH n -> prop_spinor n
| Ga | Gl -> Prop_Feynman
| Wp | Wm | Z | Xp | Xm | X0 | Y0 | ZH -> Prop_Unitarity
| Phip | Phim | Phi0 -> Only_Insertion
| H | Eta -> Prop_Scalar
(* Optionally, ask for the fudge factor treatment for the widths of
charged particles. Currently, this only applies to $W^\pm$ and top. *)
let width f =
if !use_fudged_width then
match f with
| Wp | Wm | U 3 | U (-3) | QH _ | NH _ -> Fudged
| _ -> !default_width
else
!default_width
let goldstone = function
| Wp -> Some (Phip, Coupling.Integer 1)
| Wm -> Some (Phim, Coupling.Integer 1)
| Z -> Some (Phi0, Coupling.Integer 1)
| _ -> None
let conjugate = function
| L n -> L (-n) | N n -> N (-n)
| U n -> U (-n) | D n -> D (-n)
| QH n -> QH (-n) | NH n -> NH (-n)
| Ga -> Ga | Gl -> Gl | Z -> Z
| Wp -> Wm | Wm -> Wp
| Xp -> Xm | Xm -> Xp | X0 -> X0 | Y0 -> Y0 | ZH -> ZH
| Phip -> Phim | Phim -> Phip | Phi0 -> Phi0
| H -> H | Eta -> Eta
let fermion = function
| L n -> if n > 0 then 1 else -1
| N n -> if n > 0 then 1 else -1
| U n -> if n > 0 then 1 else -1
| D n -> if n > 0 then 1 else -1
| QH n -> if n > 0 then 1 else -1
| NH n -> if n > 0 then 1 else -1
| Ga | Gl | Z | Wp | Wm | Xp | Xm | X0 | Y0 | ZH -> 0
| _ -> 0
module Ch = Charges.QQ
let ( // ) = Algebra.Small_Rational.make
let charge = function
| L n -> if n > 0 then -1//1 else 1//1
| N n | NH n -> 0//1
| U n -> if n > 0 then 2//3 else -2//3
| QH 3 -> 2//3 | QH (-3) -> -2//3
| QH (1|2) ->
if Flags.anom_ferm_ass then
2//3
else
-1//3
| QH ((-1)|(-2)) ->
if Flags.anom_ferm_ass then
-2//3
else
1//3
| QH n -> invalid_arg ("Simplest.charge: QH " ^ string_of_int n)
| D n -> if n > 0 then -1//3 else 1//3
| Gl | Ga | Z | ZH | X0 | Y0 -> 0//1
| Wp | Xp -> 1//1
| Wm | Xm -> -1//1
| H | Phi0 | Eta -> 0//1
| Phip -> 1//1
| Phim -> -1//1
let lepton = function
| L n | N n | NH n
-> if n > 0 then 1//1 else -1//1
| U _ | D _ | _ -> 0//1
let baryon = function
| L _ | N _ -> 0//1
| U n | D n | QH n
-> if n > 0 then 1//1 else -1//1
| _ -> 0//1
let charges f =
[ charge f; lepton f; baryon f]
type constant =
| Unit | Pi | Alpha_QED | Sin2thw
| Sinthw | Costhw | E | G_weak | Vev | VHeavy
| Supp | Supp2
| Sinpsi | Cospsi | Atpsi | Sccs (* Mixing angles of SU(2) *)
| Q_lepton | Q_up | Q_down | Q_Z_up | G_CC | I_G_CC
| G_NC_neutrino | G_NC_lepton | G_NC_up | G_NC_down
| G_NC_X | G_NC_X_t | G_NC_Y | G_NC_Y_t | G_NC_H
| G_NC_h_neutrino | G_NC_h_lepton | G_NC_h_up | G_NC_h_down
| G_NC_h_top | G_NC_h_bot | G_NCH_N | G_NCH_U | G_NCH_D | G_NCHt
| G_zhthth
| I_Q_W | I_G_ZWW | I_G_WWW
| I_G_Z1 | I_G_Z2 | I_G_Z3 | I_G_Z4 | I_G_Z5 | I_G_Z6
| I_Q_H | Gs | I_Gs | G2
| G_WWWW | G_ZZWW | G_AZWW | G_AAWW
| I_Q_ZH
| G_HWW | G_HHWW | G_HZZ | G_HHZZ | G_HHZZH
| G_heavy_HVV | G_heavy_HWW | G_heavy_HZZ | G_HHthth
| G_Htt | G_Hbb | G_Hcc | G_Htautau | G_H3 | G_H4
| G_Hthth | G_Htht | G_Ethth | G_Etht | G_Ett | G_Hqhq
| G_Ebb | G_ZEH | G_ZHEH | G_Hgg
| G_HGaGa | G_HGaZ | G_EGaGa | G_EGaZ | G_EGlGl
| Mass of flavor | Width of flavor
(* Two integer counters for the QCD and EW order of the couplings. *)
- type orders = int * int
+ type coupling_order = QCD | EW
+ let all_coupling_orders () = [QCD; EW]
+ let coupling_order_to_string = function
+ | QCD -> "QCD"
+ | EW -> "EW"
- let orders = function
- | _ -> (0,0)
+ let coupling_orders = function
+ | _ -> failwith "Modellib_BSM.Simplest.orders: not implemented yet!"
(* \begin{dubious}
The current abstract syntax for parameter dependencies is admittedly
tedious. Later, there will be a parser for a convenient concrete syntax
as a part of a concrete syntax for models. But as these examples show,
it should include simple functions.
\end{dubious} *)
let input_parameters =
[]
let derived_parameters =
[]
let g_over_2_costh =
Quot (Neg (Atom G_weak), Prod [Integer 2; Atom Costhw])
let nc_coupling c t3 q =
(Real_Array c,
[Prod [g_over_2_costh; Diff (t3, Prod [Integer 2; q; Atom Sin2thw])];
Prod [g_over_2_costh; t3]])
let half = Quot (Integer 1, Integer 2)
let derived_parameter_arrays =
[ nc_coupling G_NC_neutrino half (Integer 0);
nc_coupling G_NC_lepton (Neg half) (Integer (-1));
nc_coupling G_NC_up half (Quot (Integer 2, Integer 3));
nc_coupling G_NC_down (Neg half) (Quot (Integer (-1), Integer 3));
nc_coupling G_NC_h_neutrino half (Integer 0);
nc_coupling G_NC_h_lepton (Neg half) (Integer (-1));
nc_coupling G_NC_h_up half (Quot (Integer 2, Integer 3));
nc_coupling G_NC_h_down (Neg half) (Quot (Integer (-1), Integer 3)) ]
let parameters () =
{ input = input_parameters;
derived = derived_parameters;
derived_arrays = derived_parameter_arrays }
module F = Modeltools.Fusions (struct
type f = flavor
type c = constant
let compare = compare
let conjugate = conjugate
end)
let electromagnetic_currents n =
[ ((L (-n), Ga, L n), FBF (1, Psibar, V, Psi), Q_lepton);
((U (-n), Ga, U n), FBF (1, Psibar, V, Psi), Q_up);
((D (-n), Ga, D n), FBF (1, Psibar, V, Psi), Q_down) ]
let color_currents n =
[ ((D (-n), Gl, D n), FBF ((-1), Psibar, V, Psi), Gs);
((U (-n), Gl, U n), FBF ((-1), Psibar, V, Psi), Gs);
((QH (-n), Gl, QH n), FBF ((-1), Psibar, V, Psi), Gs)]
let neutral_currents n =
[ ((L (-n), Z, L n), FBF (1, Psibar, VA, Psi), G_NC_lepton);
((N (-n), Z, N n), FBF (1, Psibar, VA, Psi), G_NC_neutrino);
((U (-n), Z, U n), FBF (1, Psibar, VA, Psi), G_NC_up);
((D (-n), Z, D n), FBF (1, Psibar, VA, Psi), G_NC_down) ]
let xy_currents =
ThoList.flatmap
(fun n -> [ ((N (-n), X0, N n), FBF ((-1), Psibar, VL, Psi), G_NC_X);
((L (-n), Xm, N n), FBF ((-1), Psibar, VL, Psi), G_NC_X);
((N (-n), Xp, L n), FBF ((-1), Psibar, VL, Psi), G_NC_X);
((N (-n), Y0, N n), FBF ((-1), Psibar, VL, Psi), G_NC_Y);
((NH (-n), X0, N n), FBF ((-1), Psibar, VL, Psi), G_CC);
((N (-n), X0, NH n), FBF ((-1), Psibar, VL, Psi), G_CC);
((NH (-n), Y0, N n), FBF ((-1), Psibar, VL, Psi), I_G_CC);
((N (-n), Y0, NH n), FBF ((-1), Psibar, VL, Psi), I_G_CC);
((L (-n), Xm, NH n), FBF ((-1), Psibar, VL, Psi), G_CC);
((NH (-n), Xp, L n), FBF ((-1), Psibar, VL, Psi), G_CC)])
[1;2;3]
@
[ ((U (-3), X0, U 3), FBF (1, Psibar, VL, Psi), G_NC_X_t);
((U (-3), Y0, U 3), FBF (1, Psibar, VL, Psi), G_NC_Y_t);
((U (-3), X0, QH 3), FBF (1, Psibar, VL, Psi), G_CC);
((QH (-3), X0, U 3), FBF (1, Psibar, VL, Psi), G_CC);
((U (-3), Y0, QH 3), FBF (1, Psibar, VL, Psi), I_G_CC);
((QH (-3), Y0, U 3), FBF (1, Psibar, VL, Psi), I_G_CC);
((D (-3), Xm, U 3), FBF (1, Psibar, VL, Psi), G_NC_X_t);
((U (-3), Xp, D 3), FBF (1, Psibar, VL, Psi), G_NC_X_t);
((D (-3), Xm, QH 3), FBF (1, Psibar, VL, Psi), G_CC);
((QH (-3), Xp, D 3), FBF (1, Psibar, VL, Psi), G_CC);
((QH (-3), Wp, D 3), FBF (1, Psibar, VL, Psi), G_NC_X_t);
((D (-3), Wm, QH 3), FBF (1, Psibar, VL, Psi), G_NC_X_t);
((QH (-3), Z, U 3), FBF (1, Psibar, VL, Psi), G_NCHt);
((U (-3), Z, QH 3), FBF (1, Psibar, VL, Psi), G_NCHt)]
@
ThoList.flatmap
(fun n ->
if Flags.anom_ferm_ass then
[ ((U (-n), X0, U n), FBF ((-1), Psibar, VL, Psi), G_NC_X);
((U (-n), Y0, U n), FBF ((-1), Psibar, VL, Psi), G_NC_Y);
((D (-n), Xm, U n), FBF ((-1), Psibar, VL, Psi), G_NC_X);
((U (-n), Xp, D n), FBF ((-1), Psibar, VL, Psi), G_NC_X);
((QH (-n), X0, U n), FBF ((-1), Psibar, VL, Psi), G_CC);
((U (-n), X0, QH n), FBF ((-1), Psibar, VL, Psi), G_CC);
((QH (-n), Y0, U n), FBF ((-1), Psibar, VL, Psi), I_G_CC);
((U (-n), Y0, QH n), FBF ((-1), Psibar, VL, Psi), I_G_CC);
((D (-n), Xm, QH n), FBF ((-1), Psibar, VL, Psi), G_CC);
((QH (-n), Xp, D n), FBF ((-1), Psibar, VL, Psi), G_CC);
((QH (-n), Wp, D n), FBF ((-1), Psibar, VL, Psi), G_NC_X);
((D (-n), Wm, QH n), FBF ((-1), Psibar, VL, Psi), G_NC_X);
((QH (-n), Z, U n), FBF (1, Psibar, VL, Psi), G_NC_H);
((U (-n), Z, QH n), FBF (1, Psibar, VL, Psi), G_NC_H)]
else
[ ((D (-n), X0, D n), FBF (1, Psibar, VL, Psi), G_NC_X);
((D (-n), Y0, D n), FBF (1, Psibar, VL, Psi), G_NC_Y);
((D (-n), Xm, U n), FBF (1, Psibar, VL, Psi), G_NC_X);
((U (-n), Xp, D n), FBF (1, Psibar, VL, Psi), G_NC_X);
((QH (-n), X0, D n), FBF ((-1), Psibar, VL, Psi), G_CC);
((D (-n), X0, QH n), FBF ((-1), Psibar, VL, Psi), G_CC);
((QH (-n), Y0, D n), FBF ((-1), Psibar, VL, Psi), I_G_CC);
((D (-n), Y0, QH n), FBF ((-1), Psibar, VL, Psi), I_G_CC);
((QH (-n), Xm, U n), FBF (1, Psibar, VL, Psi), G_CC);
((U (-n), Xp, QH n), FBF (1, Psibar, VL, Psi), G_CC);
((QH (-n), Wm, U n), FBF (1, Psibar, VL, Psi), G_NC_X);
((U (-n), Wp, QH n), FBF (1, Psibar, VL, Psi), G_NC_X);
((QH (-n), Z, D n), FBF (1, Psibar, VL, Psi), G_NC_H);
((D (-n), Z, QH n), FBF (1, Psibar, VL, Psi), G_NC_H)])
[1; 2]
(* The sign of this coupling is just the one of the T3, being -(1/2) for
leptons and down quarks, and +(1/2) for neutrinos and up quarks. *)
let neutral_heavy_currents n =
[ ((L (-n), ZH, L n), FBF (1, Psibar, VLR, Psi), G_NC_h_lepton);
((N (-n), ZH, N n), FBF ((-1), Psibar, VLR, Psi), G_NC_h_neutrino);
((U (-n), ZH, U n), FBF ((-1), Psibar, VLR, Psi), (if n = 3 then
G_NC_h_top else G_NC_h_up));
((D (-n), ZH, D n), FBF (1, Psibar, VLR, Psi), (if n = 3 then
G_NC_h_bot else G_NC_h_down));
((NH (-n), ZH, NH n), FBF (1, Psibar, VLR, Psi), G_NCH_N);
((QH (-n), ZH, QH n), FBF (1, Psibar, VLR, Psi), (if n = 3 then
G_NCH_U else if Flags.anom_ferm_ass then G_NCH_U else G_NCH_D))]
let heavy_currents n =
[ ((QH (-n), Ga, QH n), FBF (1, Psibar, V, Psi), (if n=3 then Q_up else
if Flags.anom_ferm_ass then Q_up else Q_down))]
let charged_currents n =
[ ((L (-n), Wm, N n), FBF (1, Psibar, VL, Psi), G_CC);
((N (-n), Wp, L n), FBF (1, Psibar, VL, Psi), G_CC);
((D (-n), Wm, U n), FBF (1, Psibar, VL, Psi), G_CC);
((U (-n), Wp, D n), FBF (1, Psibar, VL, Psi), G_CC) ]
let yukawa =
[ ((U (-3), H, U 3), FBF (1, Psibar, S, Psi), G_Htt);
((D (-3), H, D 3), FBF (1, Psibar, S, Psi), G_Hbb);
((U (-2), H, U 2), FBF (1, Psibar, S, Psi), G_Hcc);
((L (-3), H, L 3), FBF (1, Psibar, S, Psi), G_Htautau) ]
let yukawa_add =
[ ((QH (-3), H, U 3), FBF (1, Psibar, SL, Psi), G_Htht);
((U (-3), H, QH 3), FBF (1, Psibar, SR, Psi), G_Htht);
((QH (-3), Eta, U 3), FBF (1, Psibar, SR, Psi), G_Etht);
((U (-3), Eta, QH 3), FBF (1, Psibar, SL, Psi), G_Etht);
((D (-3), Eta, D 3), FBF (1, Psibar, P, Psi), G_Ebb);
((U (-3), Eta, U 3), FBF (1, Psibar, P, Psi), G_Ett)]
@
ThoList.flatmap
(fun n ->
if Flags.anom_ferm_ass then
[ ((QH (-n), H, U n), FBF (1, Psibar, SL, Psi), G_Hqhq);
((U (-n), H, QH n), FBF (1, Psibar, SR, Psi), G_Hqhq)]
else
[ ((QH (-n), H, D n), FBF (1, Psibar, SL, Psi), G_Hqhq);
((D (-n), H, QH n), FBF (1, Psibar, SR, Psi), G_Hqhq)])
[1;2]
let standard_triple_gauge =
[ ((Ga, Wm, Wp), Gauge_Gauge_Gauge 1, I_Q_W);
((Z, Wm, Wp), Gauge_Gauge_Gauge 1, I_G_ZWW);
((Gl, Gl, Gl), Gauge_Gauge_Gauge 1, I_Gs)]
let heavy_triple_gauge =
[ ((Ga, Xm, Xp), Gauge_Gauge_Gauge 1, I_Q_W);
((Z, Xm, Xp), Gauge_Gauge_Gauge 1, I_Q_ZH);
((Z, X0, Y0), Gauge_Gauge_Gauge 1, I_G_Z1);
((ZH, X0, Y0), Gauge_Gauge_Gauge 1, I_G_Z2);
((Y0, Wm, Xp), Gauge_Gauge_Gauge 1, I_G_Z3);
((Y0, Wp, Xm), Gauge_Gauge_Gauge (-1), I_G_Z3);
((X0, Wm, Xp), Gauge_Gauge_Gauge 1, I_G_Z4);
((X0, Wp, Xm), Gauge_Gauge_Gauge 1, I_G_Z4);
((ZH, Xm, Xp), Gauge_Gauge_Gauge 1, I_G_Z5);
((ZH, Wm, Wp), Gauge_Gauge_Gauge 1, I_G_Z6)]
let triple_gauge =
standard_triple_gauge @ heavy_triple_gauge
let gauge4 = Vector4 [(2, C_13_42); (-1, C_12_34); (-1, C_14_23)]
let minus_gauge4 = Vector4 [(-2, C_13_42); (1, C_12_34); (1, C_14_23)]
let standard_quartic_gauge =
[ (Wm, Wp, Wm, Wp), gauge4, G_WWWW;
(Wm, Z, Wp, Z), minus_gauge4, G_ZZWW;
(Wm, Z, Wp, Ga), minus_gauge4, G_AZWW;
(Wm, Ga, Wp, Ga), minus_gauge4, G_AAWW;
(Gl, Gl, Gl, Gl), gauge4, G2]
let heavy_quartic_gauge =
[]
let quartic_gauge =
standard_quartic_gauge @ heavy_quartic_gauge
let standard_gauge_higgs' =
[ ((H, Wp, Wm), Scalar_Vector_Vector 1, G_HWW);
((H, Z, Z), Scalar_Vector_Vector 1, G_HZZ) ]
let heavy_gauge_higgs =
[ ((H, Wp, Xm), Scalar_Vector_Vector 1, G_heavy_HWW);
((H, Wm, Xp), Scalar_Vector_Vector 1, G_heavy_HWW);
((H, Z, X0), Scalar_Vector_Vector 1, G_heavy_HVV);
((H, ZH, X0), Scalar_Vector_Vector 1, G_heavy_HVV)]
let standard_gauge_higgs =
standard_gauge_higgs' @ heavy_gauge_higgs
let standard_gauge_higgs4 =
[ (H, H, Wp, Wm), Scalar2_Vector2 1, G_HHWW;
(H, H, Z, Z), Scalar2_Vector2 1, G_HHZZ ]
let heavy_gauge_higgs4 =
[ (H, H, Z, ZH), Scalar2_Vector2 1, G_HHZZH;
(H, H, Xp, Xm), Scalar2_Vector2 (-1), G_HHWW;
(H, H, ZH, ZH), Scalar2_Vector2 (-1), G_HHZZ ]
let standard_higgs =
[ (H, H, H), Scalar_Scalar_Scalar 1, G_H3 ]
let anomaly_higgs =
[ (Eta, Gl, Gl), Dim5_Scalar_Gauge2_Skew 1, G_EGlGl;
(Eta, Ga, Ga), Dim5_Scalar_Gauge2_Skew 1, G_EGaGa;
(Eta, Ga, Z), Dim5_Scalar_Gauge2_Skew 1, G_EGaZ ]
(* @ [ (H, Ga, Ga), Dim5_Scalar_Gauge2 1, G_HGaGa;
(H, Ga, Z), Dim5_Scalar_Gauge2 1, G_HGaZ ] *)
let standard_higgs4 =
[ (H, H, H, H), Scalar4 1, G_H4 ]
let gauge_higgs =
standard_gauge_higgs
let gauge_higgs4 =
standard_gauge_higgs4 @ heavy_gauge_higgs4
let higgs =
standard_higgs
let eta_higgs_gauge =
[ (Z, Eta, H), Vector_Scalar_Scalar 1, G_ZEH;
(ZH, Eta, H), Vector_Scalar_Scalar 1, G_ZHEH;
(X0, Eta, H), Vector_Scalar_Scalar 1, G_CC ]
let top_quartic =
[ ((QH (-3), H, H, QH 3), GBBG (1, Psibar, S2, Psi), G_HHthth)]
let higgs4 =
standard_higgs4
let goldstone_vertices =
[ ((Phi0, Wm, Wp), Scalar_Vector_Vector 1, I_G_ZWW);
((Phip, Ga, Wm), Scalar_Vector_Vector 1, I_Q_W);
((Phip, Z, Wm), Scalar_Vector_Vector 1, I_G_ZWW);
((Phim, Wp, Ga), Scalar_Vector_Vector 1, I_Q_W);
((Phim, Wp, Z), Scalar_Vector_Vector 1, I_G_ZWW) ]
let vertices3 =
(ThoList.flatmap electromagnetic_currents [1;2;3] @
ThoList.flatmap color_currents [1;2;3] @
ThoList.flatmap neutral_currents [1;2;3] @
ThoList.flatmap neutral_heavy_currents [1;2;3] @
ThoList.flatmap heavy_currents [1;2;3] @
ThoList.flatmap charged_currents [1;2;3] @
xy_currents @ anomaly_higgs @
eta_higgs_gauge @
yukawa @ yukawa_add @
triple_gauge @
gauge_higgs @ higgs @ goldstone_vertices)
let vertices4 =
quartic_gauge @ gauge_higgs4 @ higgs4
let vertices () = (vertices3, vertices4, [])
(* For efficiency, make sure that [F.of_vertices vertices] is
evaluated only once. *)
let table = F.of_vertices (vertices ())
let fuse2 = F.fuse2 table
let fuse3 = F.fuse3 table
let fuse = F.fuse table
let max_degree () = 4
let flavor_of_string = function
| "e-" -> L 1 | "e+" -> L (-1)
| "mu-" -> L 2 | "mu+" -> L (-2)
| "tau-" -> L 3 | "tau+" -> L (-3)
| "nue" -> N 1 | "nuebar" -> N (-1)
| "numu" -> N 2 | "numubar" -> N (-2)
| "nutau" -> N 3 | "nutaubar" -> N (-3)
| "nh1" -> NH 1 | "nh1bar" -> NH (-1)
| "nh2" -> NH 2 | "nh2bar" -> NH (-2)
| "nh3" -> NH 3 | "nh3bar" -> NH (-3)
| "u" -> U 1 | "ubar" -> U (-1)
| "c" -> U 2 | "cbar" -> U (-2)
| "t" -> U 3 | "tbar" -> U (-3)
| "d" -> D 1 | "dbar" -> D (-1)
| "s" -> D 2 | "sbar" -> D (-2)
| "b" -> D 3 | "bbar" -> D (-3)
| "uh" -> if Flags.anom_ferm_ass then QH 1 else invalid_arg
"Modellib_BSM.Simplest.flavor_of_string"
| "dh" -> if Flags.anom_ferm_ass then invalid_arg
"Modellib_BSM.Simplest.flavor_of_string" else QH 1
| "uhbar" -> if Flags.anom_ferm_ass then QH (-1) else invalid_arg
"Modellib_BSM.Simplest.flavor_of_string"
| "dhbar" -> if Flags.anom_ferm_ass then invalid_arg
"Modellib_BSM.Simplest.flavor_of_string" else QH (-1)
| "ch" -> if Flags.anom_ferm_ass then QH 2 else invalid_arg
"Modellib_BSM.Simplest.flavor_of_string"
| "sh" -> if Flags.anom_ferm_ass then invalid_arg
"Modellib_BSM.Simplest.flavor_of_string" else QH 2
| "chbar" -> if Flags.anom_ferm_ass then QH (-2) else invalid_arg
"Modellib_BSM.Simplest.flavor_of_string"
| "shbar" -> if Flags.anom_ferm_ass then invalid_arg
"Modellib_BSM.Simplest.flavor_of_string" else QH (-2)
| "th" -> QH 3 | "thbar" -> QH (-3)
| "eta" | "Eta" -> Eta
| "A" -> Ga | "Z" | "Z0" -> Z | "g" | "gl" -> Gl
| "ZH" | "ZH0" | "Zh" | "Zh0" -> ZH
| "W+" -> Wp | "W-" -> Wm
| "X+" -> Xp | "X-" -> Xm
| "X0" -> X0 | "Y0" -> Y0
| "H" -> H
| _ -> invalid_arg "Modellib_BSM.Simplest.flavor_of_string"
let flavor_to_string = function
| L 1 -> "e-" | L (-1) -> "e+"
| L 2 -> "mu-" | L (-2) -> "mu+"
| L 3 -> "tau-" | L (-3) -> "tau+"
| L _ -> invalid_arg
"Modellib_BSM.Simplest.flavor_to_string: invalid lepton"
| N 1 -> "nue" | N (-1) -> "nuebar"
| N 2 -> "numu" | N (-2) -> "numubar"
| N 3 -> "nutau" | N (-3) -> "nutaubar"
| N _ -> invalid_arg
"Modellib_BSM.Simplest.flavor_to_string: invalid neutrino"
| U 1 -> "u" | U (-1) -> "ubar"
| U 2 -> "c" | U (-2) -> "cbar"
| U 3 -> "t" | U (-3) -> "tbar"
| U _ -> invalid_arg
"Modellib_BSM.Simplest.flavor_to_string: invalid up type quark"
| D 1 -> "d" | D (-1) -> "dbar"
| D 2 -> "s" | D (-2) -> "sbar"
| D 3 -> "b" | D (-3) -> "bbar"
| D _ -> invalid_arg
"Modellib_BSM.Simplest.flavor_to_string: invalid down type quark"
| QH 1 -> if Flags.anom_ferm_ass then "uh" else "dh"
| QH 2 -> if Flags.anom_ferm_ass then "ch" else "sh"
| QH 3 -> "th"
| QH (-1) -> if Flags.anom_ferm_ass then "uhbar" else "dhbar"
| QH (-2) -> if Flags.anom_ferm_ass then "chbar" else "shbar"
| QH (-3) -> "thbar"
| QH _ -> invalid_arg
"Modellib_BSM.Simplest.flavor_to_string: invalid heavy quark"
| NH n when n > 0 -> "nh" ^ string_of_int n
| NH n -> "nh" ^ string_of_int (abs n) ^ "bar"
| Ga -> "A" | Z -> "Z" | Gl -> "gl"
| Wp -> "W+" | Wm -> "W-"
| Xp -> "X+" | Xm -> "X-" | X0 -> "X0" | Y0 -> "Y0" | ZH -> "ZH"
| Phip -> "phi+" | Phim -> "phi-" | Phi0 -> "phi0"
| H -> "H" | Eta -> "Eta"
let flavor_to_TeX = function
| L 1 -> "e^-" | L (-1) -> "\\e^+"
| L 2 -> "\\mu^-" | L (-2) -> "\\mu^+"
| L 3 -> "\\tau^-" | L (-3) -> "\\tau^+"
| L _ -> invalid_arg
"Modellib_BSM.Simplest.flavor_to_TeX: invalid lepton"
| N 1 -> "\\nu_e" | N (-1) -> "\\bar{\\nu}_e"
| N 2 -> "\\nu_\\mu" | N (-2) -> "\\bar{\\nu}_\\mu"
| N 3 -> "\\nu_\\tau" | N (-3) -> "\\bar{\\nu}_\\tau"
| N _ -> invalid_arg
"Modellib_BSM.Simplest.flavor_to_TeX: invalid neutrino"
| U 1 -> "u" | U (-1) -> "\\bar{u}"
| U 2 -> "c" | U (-2) -> "\\bar{c}"
| U 3 -> "t" | U (-3) -> "\\bar{t}"
| U _ -> invalid_arg
"Modellib_BSM.Simplest.flavor_to_TeX: invalid up type quark"
| D 1 -> "d" | D (-1) -> "\\bar{d}"
| D 2 -> "s" | D (-2) -> "\\bar{s}"
| D 3 -> "b" | D (-3) -> "\\bar{b}"
| D _ -> invalid_arg
"Modellib_BSM.Simplest.flavor_to_TeX: invalid down type quark"
| QH 1 -> if Flags.anom_ferm_ass then "U" else "D"
| QH 2 -> if Flags.anom_ferm_ass then "C" else "S"
| QH 3 -> "T"
| QH (-1) -> if Flags.anom_ferm_ass then "\\bar{U}" else "\\bar{D}"
| QH (-2) -> if Flags.anom_ferm_ass then "\\bar{C}" else "\\bar{S}"
| QH (-3) -> "thbar"
| QH _ -> invalid_arg
"Modellib_BSM.Simplest.flavor_to_TeX: invalid heavy quark"
| NH n when n > 0 -> "N_" ^ string_of_int n
| NH n -> "\\bar{N}_" ^ string_of_int (abs n)
| Ga -> "\\gamma" | Z -> "Z" | Gl -> "g"
| Wp -> "W^+" | Wm -> "W^-"
| Xp -> "X^+" | Xm -> "X^-" | X0 -> "X^0" | Y0 -> "Y^0" | ZH -> "Z_H"
| Phip -> "\\phi^+" | Phim -> "\\phi^-" | Phi0 -> "\\phi^0"
| H -> "H" | Eta -> "\\eta"
let flavor_symbol = function
| L n when n > 0 -> "l" ^ string_of_int n
| L n -> "l" ^ string_of_int (abs n) ^ "b"
| N n when n > 0 -> "n" ^ string_of_int n
| N n -> "n" ^ string_of_int (abs n) ^ "b"
| U n when n > 0 -> "u" ^ string_of_int n
| U n -> "u" ^ string_of_int (abs n) ^ "b"
| D n when n > 0 -> "d" ^ string_of_int n
| D n -> "d" ^ string_of_int (abs n) ^ "b"
| NH n when n > 0 -> "nh" ^ string_of_int n
| NH n -> "nh" ^ string_of_int (abs n) ^ "b"
| QH n when n > 0 -> "qh" ^ string_of_int n
| QH n -> "qh" ^ string_of_int (abs n) ^ "b"
| Ga -> "a" | Z -> "z" | Gl -> "gl"
| Wp -> "wp" | Wm -> "wm"
| Xp -> "xp" | Xm -> "xm" | X0 -> "x0" | Y0 -> "y0" | ZH -> "zh"
| Phip -> "pp" | Phim -> "pm" | Phi0 -> "p0"
| H -> "h" | Eta -> "eta"
(* There are PDG numbers for Z', Z'', W', 32-34, respectively.
We just introduce a number 38 for Y0 as a Z'''.
As well, there is the number 8 for a t'. But we cheat a little bit and
take the number 35 which is reserved for a heavy scalar Higgs for the
Eta scalar.
We abuse notation for the heavy quarks and take the PDG code for their
SUSY partners!!! (What about an update of the PDG numbering scheme?)
Thereby we take only those for up-type (s)quarks. The heavy neutrinos get
the numbers of the sneutrinos.
*)
let pdg = function
| L n when n > 0 -> 9 + 2*n
| L n -> - 9 + 2*n
| N n when n > 0 -> 10 + 2*n
| N n -> - 10 + 2*n
| U n when n > 0 -> 2*n
| U n -> 2*n
| D n when n > 0 -> - 1 + 2*n
| D n -> 1 + 2*n
| NH n when n > 0 -> 1000010 + 2*n
| NH n -> - 1000010 + 2*n
| QH 3 -> 1000006
| QH (-3) -> - 1000006
| QH n when n > 0 -> if Flags.anom_ferm_ass then
1000000 + 2*n else 999999 + 2*n
| QH n -> if Flags.anom_ferm_ass then
- 1000000 + 2*n else - 999999 + 2*n
| Gl -> 21
| Ga -> 22 | Z -> 23
| Wp -> 24 | Wm -> (-24)
| Xp -> 34 | Xm -> (-34) | ZH -> 32 | X0 -> 33 | Y0 -> 38
| Phip | Phim -> 27 | Phi0 -> 26
| H -> 25 | Eta -> 36
(* As in the case of SUSY we introduce an internal dummy pdf code in order
to have manageable arrays. Heavy neutrinos get numbers 41,43,45, while the
heavy quarks have the numbers 40,42,44. I take them all as up type
here.
*)
let pdg_mw = function
| L n when n > 0 -> 9 + 2*n
| L n -> - 9 + 2*n
| N n when n > 0 -> 10 + 2*n
| N n -> - 10 + 2*n
| U n when n > 0 -> 2*n
| U n -> 2*n
| D n when n > 0 -> - 1 + 2*n
| D n -> 1 + 2*n
| NH n when n > 0 -> 39 + 2*n
| NH n -> - 39 + 2*n
| QH n when n > 0 -> 38 + 2*n
| QH n -> - 38 + 2*n
| Gl -> 21
| Ga -> 22 | Z -> 23
| Wp -> 24 | Wm -> (-24)
| Xp -> 34 | Xm -> (-34) | ZH -> 32 | X0 -> 33 | Y0 -> 38
| Phip | Phim -> 27 | Phi0 -> 26
| H -> 25 | Eta -> 36
let mass_symbol f =
"mass(" ^ string_of_int (abs (pdg_mw f)) ^ ")"
let width_symbol f =
"width(" ^ string_of_int (abs (pdg_mw f)) ^ ")"
let constant_symbol = function
| Unit -> "unit" | Pi -> "PI" | VHeavy -> "vheavy"
| Alpha_QED -> "alpha" | E -> "e" | G_weak -> "g" | Vev -> "vev"
| Sin2thw -> "sin2thw" | Sinthw -> "sinthw" | Costhw -> "costhw"
| Sinpsi -> "sinpsi" | Cospsi -> "cospsi"
| Atpsi -> "atpsi" | Sccs -> "sccs"
| Supp -> "vF" | Supp2 -> "v2F2"
| Q_lepton -> "qlep" | Q_up -> "qup" | Q_down -> "qdwn"
| Q_Z_up -> "qzup"
| G_zhthth -> "gzhthth"
| G_NC_lepton -> "gnclep" | G_NC_neutrino -> "gncneu"
| G_NC_up -> "gncup" | G_NC_down -> "gncdwn"
| G_NC_X -> "gncx" | G_NC_X_t -> "gncxt"
| G_NC_Y -> "gncy" | G_NC_Y_t -> "gncyt" | G_NC_H -> "gnch"
| G_CC -> "gcc" | I_G_CC -> "i_gcc"
| G_NC_h_lepton -> "gnchlep" | G_NC_h_neutrino -> "gnchneu"
| G_NC_h_up -> "gnchup" | G_NC_h_down -> "gnchdwn"
| G_NC_h_top -> "gnchtop" | G_NC_h_bot -> "gnchbot"
| G_NCH_N -> "gnchn" | G_NCH_U -> "gnchu" | G_NCH_D -> "gnchd"
| G_NCHt -> "gncht"
| I_Q_W -> "iqw" | I_G_ZWW -> "igzww" | I_G_WWW -> "igwww"
| I_Q_H -> "iqh" | I_Q_ZH -> "iqzh"
| I_G_Z1 -> "igz1" | I_G_Z2 -> "igz2" | I_G_Z3 -> "igz3"
| I_G_Z4 -> "igz4" | I_G_Z5 -> "igz5" | I_G_Z6 -> "igz6"
| G_HHthth -> "ghhthth"
| G_WWWW -> "gw4" | G_ZZWW -> "gzzww"
| G_AZWW -> "gazww" | G_AAWW -> "gaaww"
| G_HWW -> "ghww" | G_HZZ -> "ghzz"
| G_heavy_HVV -> "ghyhvv"
| G_heavy_HWW -> "ghyhww"
| G_heavy_HZZ -> "ghyhzz"
| G_HHWW -> "ghhww" | G_HHZZ -> "ghhzz"
| G_HHZZH -> "ghhzzh"
| G_Hgg -> "ghgg"
| G_Htt -> "ghtt" | G_Hbb -> "ghbb"
| G_Htautau -> "ghtautau" | G_Hcc -> "ghcc"
| G_Hthth -> "ghthth" | G_Htht -> "ghtht"
| G_Hqhq -> "ghqhq"
| G_Ethth -> "gethth" | G_Etht -> "getht"
| G_Ett -> "gett" | G_Ebb -> "gebb"
| G_HGaGa -> "ghgaga" | G_HGaZ -> "ghgaz"
| G_EGaGa -> "geaa" | G_EGaZ -> "geaz" | G_EGlGl -> "gegg"
| G_ZEH -> "gzeh" | G_ZHEH -> "gzheh"
| G_H3 -> "gh3" | G_H4 -> "gh4"
| Mass f -> "mass" ^ flavor_symbol f
| Width f -> "width" ^ flavor_symbol f
| Gs -> "gs" | I_Gs -> "igs" | G2 -> "gs**2"
end
module Xdim (Flags : BSM_flags) =
struct
open Coupling
let default_width = ref Timelike
let use_fudged_width = ref false
let options = Options.create
[ "constant_width", Arg.Unit (fun () -> default_width := Constant),
"use constant width (also in t-channel)";
"fudged_width", Arg.Set use_fudged_width,
"use fudge factor for charge particle width";
"custom_width", Arg.String (fun f -> default_width := Custom f),
"use custom width";
"cancel_widths", Arg.Unit (fun () -> default_width := Vanishing),
"use vanishing width";
"cms_width", Arg.Unit (fun () -> default_width := Complex_Mass),
"use complex mass scheme";
"running_width", Arg.Unit (fun () -> default_width := Running),
"use running width"]
let caveats () = []
type matter_field = L of int | N of int | U of int | D of int
type gauge_boson = Ga | Wp | Wm | Z | Gl
type other = Phip | Phim | Phi0 | H | Grav
type flavor = M of matter_field | G of gauge_boson | O of other
let matter_field f = M f
let gauge_boson f = G f
let other f = O f
type field =
| Matter of matter_field
| Gauge of gauge_boson
| Other of other
let field = function
| M f -> Matter f
| G f -> Gauge f
| O f -> Other f
type gauge = unit
let gauge_symbol () =
failwith "Modellib_BSM.Xdim.gauge_symbol: internal error"
let family n = List.map matter_field [ L n; N n; U n; D n ]
let external_flavors () =
[ "1st Generation", ThoList.flatmap family [1; -1];
"2nd Generation", ThoList.flatmap family [2; -2];
"3rd Generation", ThoList.flatmap family [3; -3];
"Gauge Bosons", List.map gauge_boson [Ga; Z; Wp; Wm; Gl];
"Higgs", List.map other [H];
"Graviton", List.map other [Grav];
"Goldstone Bosons", List.map other [Phip; Phim; Phi0] ]
let flavors () = ThoList.flatmap snd (external_flavors ())
let spinor n =
if n >= 0 then
Spinor
else
ConjSpinor
let lorentz = function
| M f ->
begin match f with
| L n -> spinor n | N n -> spinor n
| U n -> spinor n | D n -> spinor n
end
| G f ->
begin match f with
| Ga | Gl -> Vector
| Wp | Wm | Z -> Massive_Vector
end
| O f ->
begin match f with
| Grav -> Tensor_2
| _ -> Scalar
end
- let color = function
+ let color = function
| M (U n) -> Color.SUN (if n > 0 then 3 else -3)
| M (D n) -> Color.SUN (if n > 0 then 3 else -3)
| G Gl -> Color.AdjSUN 3
| _ -> Color.Singlet
let nc () = 3
let prop_spinor n =
if n >= 0 then
Prop_Spinor
else
Prop_ConjSpinor
let propagator = function
| M f ->
begin match f with
| L n -> prop_spinor n | N n -> prop_spinor n
| U n -> prop_spinor n | D n -> prop_spinor n
end
| G f ->
begin match f with
| Ga | Gl -> Prop_Feynman
| Wp | Wm | Z -> Prop_Unitarity
end
| O f ->
begin match f with
| Phip | Phim | Phi0 -> Only_Insertion
| H -> Prop_Scalar
| Grav -> Prop_Tensor_2
end
(* Optionally, ask for the fudge factor treatment for the widths of
charged particles. Currently, this only applies to $W^\pm$ and top. *)
let width f =
if !use_fudged_width then
match f with
| G Wp | G Wm | M (U 3) | M (U (-3)) | O Grav -> Fudged
| _ -> !default_width
else
!default_width
let goldstone = function
| G f ->
begin match f with
| Wp -> Some (O Phip, Coupling.Integer 1)
| Wm -> Some (O Phim, Coupling.Integer 1)
| Z -> Some (O Phi0, Coupling.Integer 1)
| _ -> None
end
| _ -> None
let conjugate = function
| M f ->
M (begin match f with
| L n -> L (-n) | N n -> N (-n)
| U n -> U (-n) | D n -> D (-n)
end)
| G f ->
G (begin match f with
| Gl -> Gl | Ga -> Ga | Z -> Z
| Wp -> Wm | Wm -> Wp
end)
| O f ->
O (begin match f with
| Phip -> Phim | Phim -> Phip | Phi0 -> Phi0
| H -> H | Grav -> Grav
end)
let fermion = function
| M f ->
begin match f with
| L n -> if n > 0 then 1 else -1
| N n -> if n > 0 then 1 else -1
| U n -> if n > 0 then 1 else -1
| D n -> if n > 0 then 1 else -1
end
| G f ->
begin match f with
| Gl | Ga | Z | Wp | Wm -> 0
end
| O _ -> 0
module Ch = Charges.QQ
let ( // ) = Algebra.Small_Rational.make
let generation' = function
| 1 -> [ 1//1; 0//1; 0//1]
| 2 -> [ 0//1; 1//1; 0//1]
| 3 -> [ 0//1; 0//1; 1//1]
| -1 -> [-1//1; 0//1; 0//1]
| -2 -> [ 0//1; -1//1; 0//1]
| -3 -> [ 0//1; 0//1; -1//1]
| n -> invalid_arg ("Xdim.generation': " ^ string_of_int n)
let generation f =
match f with
| M (L n | N n | U n | D n) -> generation' n
| G _ | O _ -> [0//1; 0//1; 0//1]
let charge = function
| M f ->
begin match f with
| L n -> if n > 0 then -1//1 else 1//1
| N n -> 0//1
| U n -> if n > 0 then 2//3 else -2//3
| D n -> if n > 0 then -1//3 else 1//3
end
| G f ->
begin match f with
| Gl | Ga | Z -> 0//1
| Wp -> 1//1
| Wm -> -1//1
end
| O f ->
begin match f with
| H | Phi0 | Grav -> 0//1
| Phip -> 1//1
| Phim -> -1//1
end
let lepton = function
| M f ->
begin match f with
| L n | N n -> if n > 0 then 1//1 else -1//1
| U _ | D _ -> 0//1
end
| G _ | O _ -> 0//1
let baryon = function
| M f ->
begin match f with
| L _ | N _ -> 0//1
| U n | D n -> if n > 0 then 1//1 else -1//1
end
| G _ | O _ -> 0//1
let charges f =
[ charge f; lepton f; baryon f] @ generation f
type constant =
| Unit | Pi | Alpha_QED | Sin2thw
| Sinthw | Costhw | E | G_weak | Vev
| Q_lepton | Q_up | Q_down | G_CC | G_CCQ of int*int
| G_NC_neutrino | G_NC_lepton | G_NC_up | G_NC_down
| Gs | I_Gs | G2
| I_Q_W | I_G_ZWW
| G_WWWW | G_ZZWW | G_AZWW | G_AAWW
| G_HWW | G_HHWW | G_HZZ | G_HHZZ
| G_Htt | G_Hbb | G_Hcc | G_Htautau | G_H3 | G_H4
| G_HGaZ | G_HGaGa | G_Hgg | G_Grav
| Mass of flavor | Width of flavor
(* Two integer counters for the QCD and EW order of the couplings. *)
- type orders = int * int
+ type coupling_order = QCD | EW
+ let all_coupling_orders () = [QCD; EW]
+ let coupling_order_to_string = function
+ | QCD -> "QCD"
+ | EW -> "EW"
- let orders = function
- | _ -> (0,0)
+ let coupling_orders = function
+ | _ -> failwith "Modellib_BSM.Xdim.orders: not implemented yet!"
let input_parameters =
[]
let derived_parameters =
[]
let g_over_2_costh =
Quot (Neg (Atom G_weak), Prod [Integer 2; Atom Costhw])
let nc_coupling c t3 q =
(Real_Array c,
[Prod [g_over_2_costh; Diff (t3, Prod [Integer 2; q; Atom Sin2thw])];
Prod [g_over_2_costh; t3]])
let half = Quot (Integer 1, Integer 2)
let derived_parameter_arrays =
[ nc_coupling G_NC_neutrino half (Integer 0);
nc_coupling G_NC_lepton (Neg half) (Integer (-1));
nc_coupling G_NC_up half (Quot (Integer 2, Integer 3));
nc_coupling G_NC_down (Neg half) (Quot (Integer (-1), Integer 3)) ]
let parameters () =
{ input = input_parameters;
derived = derived_parameters;
derived_arrays = derived_parameter_arrays }
module F = Modeltools.Fusions (struct
type f = flavor
type c = constant
let compare = compare
let conjugate = conjugate
end)
let mgm ((m1, g, m2), fbf, c) = ((M m1, G g, M m2), fbf, c)
let mom ((m1, o, m2), fbf, c) = ((M m1, O o, M m2), fbf, c)
let electromagnetic_currents n =
List.map mgm
[ ((L (-n), Ga, L n), FBF (1, Psibar, V, Psi), Q_lepton);
((U (-n), Ga, U n), FBF (1, Psibar, V, Psi), Q_up);
((D (-n), Ga, D n), FBF (1, Psibar, V, Psi), Q_down) ]
let neutral_currents n =
List.map mgm
[ ((L (-n), Z, L n), FBF (1, Psibar, VA, Psi), G_NC_lepton);
((N (-n), Z, N n), FBF (1, Psibar, VA, Psi), G_NC_neutrino);
((U (-n), Z, U n), FBF (1, Psibar, VA, Psi), G_NC_up);
((D (-n), Z, D n), FBF (1, Psibar, VA, Psi), G_NC_down) ]
let color_currents n =
List.map mgm
[ ((U (-n), Gl, U n), FBF ((-1), Psibar, V, Psi), Gs);
((D (-n), Gl, D n), FBF ((-1), Psibar, V, Psi), Gs) ]
let charged_currents n =
List.map mgm
[ ((L (-n), Wm, N n), FBF (1, Psibar, VL, Psi), G_CC);
((N (-n), Wp, L n), FBF (1, Psibar, VL, Psi), G_CC);
((D (-n), Wm, U n), FBF (1, Psibar, VL, Psi), G_CC);
((U (-n), Wp, D n), FBF (1, Psibar, VL, Psi), G_CC) ]
let gravity_currents n =
List.map mom
[ ((L (-n), Grav, L n), Graviton_Spinor_Spinor 1, G_Grav);
((N (-n), Grav, N n), Graviton_Spinor_Spinor 1, G_Grav);
((U (-n), Grav, U n), Graviton_Spinor_Spinor 1, G_Grav);
((D (-n), Grav, D n), Graviton_Spinor_Spinor 1, G_Grav) ]
let yukawa =
List.map mom
[ ((U (-3), H, U 3), FBF (1, Psibar, S, Psi), G_Htt);
((D (-3), H, D 3), FBF (1, Psibar, S, Psi), G_Hbb);
((U (-2), H, U 2), FBF (1, Psibar, S, Psi), G_Hcc);
((L (-3), H, L 3), FBF (1, Psibar, S, Psi), G_Htautau) ]
let tgc ((g1, g2, g3), t, c) = ((G g1, G g2, G g3), t, c)
let standard_triple_gauge =
List.map tgc
[ ((Ga, Wm, Wp), Gauge_Gauge_Gauge 1, I_Q_W);
((Z, Wm, Wp), Gauge_Gauge_Gauge 1, I_G_ZWW);
((Gl, Gl, Gl), Gauge_Gauge_Gauge 1, I_Gs) ]
let triple_gauge =
standard_triple_gauge
let qgc ((g1, g2, g3, g4), t, c) = ((G g1, G g2, G g3, G g4), t, c)
let gauge4 = Vector4 [(2, C_13_42); (-1, C_12_34); (-1, C_14_23)]
let minus_gauge4 = Vector4 [(-2, C_13_42); (1, C_12_34); (1, C_14_23)]
let standard_quartic_gauge =
List.map qgc
[ (Wm, Wp, Wm, Wp), gauge4, G_WWWW;
(Wm, Z, Wp, Z), minus_gauge4, G_ZZWW;
(Wm, Z, Wp, Ga), minus_gauge4, G_AZWW;
(Wm, Ga, Wp, Ga), minus_gauge4, G_AAWW;
(Gl, Gl, Gl, Gl), gauge4, G2]
let quartic_gauge =
standard_quartic_gauge
let gravity_gauge =
[ (O Grav, G Z, G Z), Graviton_Vector_Vector 1, G_Grav;
(O Grav, G Wp, G Wm), Graviton_Vector_Vector 1, G_Grav;
(O Grav, G Ga, G Ga), Graviton_Vector_Vector 1, G_Grav;
(O Grav, G Gl, G Gl), Graviton_Vector_Vector 1, G_Grav ]
let standard_gauge_higgs =
[ ((O H, G Wp, G Wm), Scalar_Vector_Vector 1, G_HWW);
((O H, G Z, G Z), Scalar_Vector_Vector 1, G_HZZ) ]
let standard_gauge_higgs4 =
[ (O H, O H, G Wp, G Wm), Scalar2_Vector2 1, G_HHWW;
(O H, O H, G Z, G Z), Scalar2_Vector2 1, G_HHZZ ]
let standard_higgs =
[ (O H, O H, O H), Scalar_Scalar_Scalar 1, G_H3 ]
let standard_higgs4 =
[ (O H, O H, O H, O H), Scalar4 1, G_H4 ]
let gravity_higgs =
[ (O Grav, O H, O H), Graviton_Scalar_Scalar 1, G_Grav]
let anomalous_gauge_higgs =
[]
let anomalous_gauge_higgs4 =
[]
let anomalous_higgs =
[]
let anomaly_higgs =
[ (O H, G Ga, G Ga), Dim5_Scalar_Gauge2 1, G_HGaGa;
(O H, G Ga, G Z), Dim5_Scalar_Gauge2 1, G_HGaZ;
(O H, G Gl, G Gl), Dim5_Scalar_Gauge2 1, G_Hgg ]
let anomalous_higgs4 =
[]
let gauge_higgs =
standard_gauge_higgs
let gauge_higgs4 =
standard_gauge_higgs4
let higgs =
standard_higgs @ gravity_higgs
let higgs4 =
standard_higgs4
let goldstone_vertices =
[ ((O Phi0, G Wm, G Wp), Scalar_Vector_Vector 1, I_G_ZWW);
((O Phip, G Ga, G Wm), Scalar_Vector_Vector 1, I_Q_W);
((O Phip, G Z, G Wm), Scalar_Vector_Vector 1, I_G_ZWW);
((O Phim, G Wp, G Ga), Scalar_Vector_Vector 1, I_Q_W);
((O Phim, G Wp, G Z), Scalar_Vector_Vector 1, I_G_ZWW) ]
let vertices3 =
(ThoList.flatmap electromagnetic_currents [1;2;3] @
ThoList.flatmap neutral_currents [1;2;3] @
ThoList.flatmap color_currents [1;2;3] @
ThoList.flatmap charged_currents [1;2;3] @
ThoList.flatmap gravity_currents [1;2;3] @
yukawa @ triple_gauge @ gravity_gauge @
gauge_higgs @ higgs @ anomaly_higgs
@ goldstone_vertices)
let vertices4 =
quartic_gauge @ gauge_higgs4 @ higgs4
let vertices () = (vertices3, vertices4, [])
(* For efficiency, make sure that [F.of_vertices vertices] is
evaluated only once. *)
let table = F.of_vertices (vertices ())
let fuse2 = F.fuse2 table
let fuse3 = F.fuse3 table
let fuse = F.fuse table
let max_degree () = 4
let flavor_of_string = function
| "e-" -> M (L 1) | "e+" -> M (L (-1))
| "mu-" -> M (L 2) | "mu+" -> M (L (-2))
| "tau-" -> M (L 3) | "tau+" -> M (L (-3))
| "nue" -> M (N 1) | "nuebar" -> M (N (-1))
| "numu" -> M (N 2) | "numubar" -> M (N (-2))
| "nutau" -> M (N 3) | "nutaubar" -> M (N (-3))
| "u" -> M (U 1) | "ubar" -> M (U (-1))
| "c" -> M (U 2) | "cbar" -> M (U (-2))
| "t" -> M (U 3) | "tbar" -> M (U (-3))
| "d" -> M (D 1) | "dbar" -> M (D (-1))
| "s" -> M (D 2) | "sbar" -> M (D (-2))
| "b" -> M (D 3) | "bbar" -> M (D (-3))
| "g" | "gl" -> G Gl
| "A" -> G Ga | "Z" | "Z0" -> G Z
| "W+" -> G Wp | "W-" -> G Wm
| "H" -> O H
| "GG" -> O Grav
| _ -> invalid_arg "Modellib_BSM.Xdim.flavor_of_string"
let flavor_to_string = function
| M f ->
begin match f with
| L 1 -> "e-" | L (-1) -> "e+"
| L 2 -> "mu-" | L (-2) -> "mu+"
| L 3 -> "tau-" | L (-3) -> "tau+"
| L _ -> invalid_arg
"Modellib_BSM.Xdim.flavor_to_string: invalid lepton"
| N 1 -> "nue" | N (-1) -> "nuebar"
| N 2 -> "numu" | N (-2) -> "numubar"
| N 3 -> "nutau" | N (-3) -> "nutaubar"
| N _ -> invalid_arg
"Modellib_BSM.Xdim.flavor_to_string: invalid neutrino"
| U 1 -> "u" | U (-1) -> "ubar"
| U 2 -> "c" | U (-2) -> "cbar"
| U 3 -> "t" | U (-3) -> "tbar"
| U _ -> invalid_arg
"Modellib_BSM.Xdim.flavor_to_string: invalid up type quark"
| D 1 -> "d" | D (-1) -> "dbar"
| D 2 -> "s" | D (-2) -> "sbar"
| D 3 -> "b" | D (-3) -> "bbar"
| D _ -> invalid_arg
"Modellib_BSM.Xdim.flavor_to_string: invalid down type quark"
end
| G f ->
begin match f with
| Gl -> "g"
| Ga -> "A" | Z -> "Z"
| Wp -> "W+" | Wm -> "W-"
end
| O f ->
begin match f with
| Phip -> "phi+" | Phim -> "phi-" | Phi0 -> "phi0"
| H -> "H" | Grav -> "GG"
end
let flavor_to_TeX = function
| M f ->
begin match f with
| L 1 -> "e^-" | L (-1) -> "e^+"
| L 2 -> "\\mu^-" | L (-2) -> "\\mu^+"
| L 3 -> "\\tau^-" | L (-3) -> "\\tau^+"
| L _ -> invalid_arg
"Modellib_BSM.Xdim.flavor_to_TeX: invalid lepton"
| N 1 -> "\\nu_e" | N (-1) -> "\\bar{\\nu}_e"
| N 2 -> "\\nu_\\mu" | N (-2) -> "\\bar{\\nu}_\\mu"
| N 3 -> "\\nu_\\tau" | N (-3) -> "\\bar{\\nu}_\\tau"
| N _ -> invalid_arg
"Modellib_BSM.Xdim.flavor_to_TeX: invalid neutrino"
| U 1 -> "u" | U (-1) -> "\\bar{u}"
| U 2 -> "c" | U (-2) -> "\\bar{c}"
| U 3 -> "t" | U (-3) -> "\\bar{t}"
| U _ -> invalid_arg
"Modellib_BSM.Xdim.flavor_to_TeX: invalid up type quark"
| D 1 -> "d" | D (-1) -> "\\bar{d}"
| D 2 -> "s" | D (-2) -> "\\bar{s}"
| D 3 -> "b" | D (-3) -> "\\bar{b}"
| D _ -> invalid_arg
"Modellib_BSM.Xdim.flavor_to_TeX: invalid down type quark"
end
| G f ->
begin match f with
| Gl -> "g"
| Ga -> "\\gamma" | Z -> "Z"
| Wp -> "W^+" | Wm -> "W^-"
end
| O f ->
begin match f with
| Phip -> "\\phi^+" | Phim -> "\\phi^-" | Phi0 -> "\\phi^0"
| H -> "H" | Grav -> "G"
end
let flavor_symbol = function
| M f ->
begin match f with
| L n when n > 0 -> "l" ^ string_of_int n
| L n -> "l" ^ string_of_int (abs n) ^ "b"
| N n when n > 0 -> "n" ^ string_of_int n
| N n -> "n" ^ string_of_int (abs n) ^ "b"
| U n when n > 0 -> "u" ^ string_of_int n
| U n -> "u" ^ string_of_int (abs n) ^ "b"
| D n when n > 0 -> "d" ^ string_of_int n
| D n -> "d" ^ string_of_int (abs n) ^ "b"
end
| G f ->
begin match f with
| Gl -> "gl"
| Ga -> "a" | Z -> "z"
| Wp -> "wp" | Wm -> "wm"
end
| O f ->
begin match f with
| Phip -> "pp" | Phim -> "pm" | Phi0 -> "p0"
| H -> "h" | Grav -> "gv"
end
let pdg = function
| M f ->
begin match f with
| L n when n > 0 -> 9 + 2*n
| L n -> - 9 + 2*n
| N n when n > 0 -> 10 + 2*n
| N n -> - 10 + 2*n
| U n when n > 0 -> 2*n
| U n -> 2*n
| D n when n > 0 -> - 1 + 2*n
| D n -> 1 + 2*n
end
| G f ->
begin match f with
| Gl -> 21
| Ga -> 22 | Z -> 23
| Wp -> 24 | Wm -> (-24)
end
| O f ->
begin match f with
| Phip | Phim -> 27 | Phi0 -> 26
| H -> 25 | Grav -> 39
end
let mass_symbol f =
"mass(" ^ string_of_int (abs (pdg f)) ^ ")"
let width_symbol f =
"width(" ^ string_of_int (abs (pdg f)) ^ ")"
let constant_symbol = function
| Unit -> "unit" | Pi -> "PI"
| Alpha_QED -> "alpha" | E -> "e" | G_weak -> "g" | Vev -> "vev"
| Sin2thw -> "sin2thw" | Sinthw -> "sinthw" | Costhw -> "costhw"
| Q_lepton -> "qlep" | Q_up -> "qup" | Q_down -> "qdwn"
| G_NC_lepton -> "gnclep" | G_NC_neutrino -> "gncneu"
| G_NC_up -> "gncup" | G_NC_down -> "gncdwn"
| Gs -> "gs" | I_Gs -> "igs" | G2 -> "gs**2"
| G_CC -> "gcc"
| G_CCQ (n1,n2) -> "gccq" ^ string_of_int n1 ^ string_of_int n2
| I_Q_W -> "iqw" | I_G_ZWW -> "igzww"
| G_WWWW -> "gw4" | G_ZZWW -> "gzzww"
| G_AZWW -> "gazww" | G_AAWW -> "gaaww"
| G_HWW -> "ghww" | G_HZZ -> "ghzz"
| G_HHWW -> "ghhww" | G_HHZZ -> "ghhzz"
| G_Htt -> "ghtt" | G_Hbb -> "ghbb"
| G_Htautau -> "ghtautau" | G_Hcc -> "ghcc"
| G_HGaZ -> "ghgaz" | G_HGaGa -> "ghgaga" | G_Hgg -> "ghgg"
| G_H3 -> "gh3" | G_H4 -> "gh4" | G_Grav -> "ggrav"
| Mass f -> "mass" ^ flavor_symbol f
| Width f -> "width" ^ flavor_symbol f
end
module UED (Flags : BSM_flags) =
struct
open Coupling
let default_width = ref Timelike
let use_fudged_width = ref false
let options = Options.create
[ "constant_width", Arg.Unit (fun () -> default_width := Constant),
"use constant width (also in t-channel)";
"fudged_width", Arg.Set use_fudged_width,
"use fudge factor for charge particle width";
"custom_width", Arg.String (fun f -> default_width := Custom f),
"use custom width";
"cancel_widths", Arg.Unit (fun () -> default_width := Vanishing),
"use vanishing width";
"cms_width", Arg.Unit (fun () -> default_width := Complex_Mass),
"use complex mass scheme";
"running_width", Arg.Unit (fun () -> default_width := Running),
"use running width"]
let caveats () = []
type matter_field = L of int | N of int | U of int | D of int
| L_K1_L of int | L_K1_R of int | N_K1 of int
| L_K2_L of int | L_K2_R of int | N_K2 of int
| U_K1_L of int | U_K2_L of int | D_K1_L of int | D_K2_L of int
| U_K1_R of int | U_K2_R of int | D_K1_R of int | D_K2_R of int
type gauge_boson = Ga | Wp | Wm | Z | Gl | Gl_K1 | Gl_K2
| B1 | B2 | Z1 | Z2 | Wp1 | Wm1 | Wp2 | Wm2
type other = Phip | Phim | Phi0 | H | H1up | H1um
| H1dp | H1dm | H2up |H2um | H2dp |H2dm
| Grav
type flavor = M of matter_field | G of gauge_boson | O of other
let matter_field f = M f
let gauge_boson f = G f
let other f = O f
type field =
| Matter of matter_field
| Gauge of gauge_boson
| Other of other
let field = function
| M f -> Matter f
| G f -> Gauge f
| O f -> Other f
type gauge = unit
let gauge_symbol () =
failwith "Modellib_BSM.UED.gauge_symbol: internal error"
let family n = List.map matter_field [ L n; N n; U n; D n; L_K1_L n;
L_K1_R n; L_K2_L n; L_K2_R n; N_K1 n; N_K2 n; U_K1_L n; U_K2_L n;
D_K1_L n; D_K2_L n; U_K1_R n; U_K2_R n; D_K1_R n; D_K2_R n]
(* We don't introduce a special index for the higher excitations but make
them parts of the particles' names. *)
let external_flavors () =
[ "1st Generation", ThoList.flatmap family [1; -1];
"2nd Generation", ThoList.flatmap family [2; -2];
"3rd Generation", ThoList.flatmap family [3; -3];
"Gauge Bosons", List.map gauge_boson [Ga; Z; Wp; Wm; Gl;
Gl_K1; Gl_K2; B1; B2; Z1; Z2; Wp1 ; Wm1; Wp2; Wm2];
"Higgs", List.map other [H; H1up; H1um; H1dp; H1dm;
H2up; H2um; H2dp; H2dm];
"Graviton", List.map other [Grav];
"Goldstone Bosons", List.map other [Phip; Phim; Phi0] ]
let flavors () = ThoList.flatmap snd (external_flavors ())
let spinor n =
if n >= 0 then
Spinor
else
ConjSpinor
let lorentz = function
| M f ->
begin match f with
| L n -> spinor n | N n -> spinor n
| U n -> spinor n | D n -> spinor n
| L_K1_L n -> spinor n | L_K1_R n -> spinor n
| L_K2_L n -> spinor n | L_K2_R n -> spinor n
| N_K1 n -> spinor n | N_K2 n -> spinor n
| U_K1_L n -> spinor n | U_K1_R n -> spinor n
| U_K2_L n -> spinor n | U_K2_R n -> spinor n
| D_K1_L n -> spinor n | D_K1_R n -> spinor n
| D_K2_L n -> spinor n | D_K2_R n -> spinor n
end
| G f ->
begin match f with
| Ga | Gl -> Vector
| Wp | Wm | Z | Gl_K1 | Gl_K2 | B1 | B2
| Z1 | Z2 | Wp1 | Wm1 | Wp2 | Wm2 -> Massive_Vector
end
| O f ->
begin match f with
| Grav -> Tensor_2
| _ -> Scalar
end
- let color = function
+ let color = function
| M (U n) -> Color.SUN (if n > 0 then 3 else -3)
| M (D n) -> Color.SUN (if n > 0 then 3 else -3)
| M (U_K1_L n) -> Color.SUN (if n > 0 then 3 else -3)
| M (D_K1_L n) -> Color.SUN (if n > 0 then 3 else -3)
| M (U_K1_R n) -> Color.SUN (if n > 0 then 3 else -3)
| M (D_K1_R n) -> Color.SUN (if n > 0 then 3 else -3)
| M (U_K2_L n) -> Color.SUN (if n > 0 then 3 else -3)
| M (D_K2_L n) -> Color.SUN (if n > 0 then 3 else -3)
| M (U_K2_R n) -> Color.SUN (if n > 0 then 3 else -3)
| M (D_K2_R n) -> Color.SUN (if n > 0 then 3 else -3)
| G Gl | G Gl_K1 | G Gl_K2 -> Color.AdjSUN 3
| _ -> Color.Singlet
let nc () = 3
let prop_spinor n =
if n >= 0 then
Prop_Spinor
else
Prop_ConjSpinor
let propagator = function
| M f ->
begin match f with
| L n -> prop_spinor n | N n -> prop_spinor n
| U n -> prop_spinor n | D n -> prop_spinor n
| L_K1_L n -> prop_spinor n | L_K1_R n -> prop_spinor n
| L_K2_L n -> prop_spinor n | L_K2_R n -> prop_spinor n
| N_K1 n -> prop_spinor n | N_K2 n -> prop_spinor n
| U_K1_L n -> prop_spinor n | U_K1_R n -> prop_spinor n
| U_K2_L n -> prop_spinor n | U_K2_R n -> prop_spinor n
| D_K1_L n -> prop_spinor n | D_K1_R n -> prop_spinor n
| D_K2_L n -> prop_spinor n | D_K2_R n -> prop_spinor n
end
| G f ->
begin match f with
| Ga | Gl -> Prop_Feynman
| Wp | Wm | Z | Gl_K1 | Gl_K2 | B1 | B2
| Z1 | Z2 | Wp1 | Wm1 | Wp2 | Wm2 -> Prop_Unitarity
end
| O f ->
begin match f with
| Phip | Phim | Phi0 -> Only_Insertion
| H | H1up | H1um | H1dp | H1dm | H2up
| H2um | H2dp | H2dm -> Prop_Scalar
| Grav -> Prop_Tensor_2
end
(* Optionally, ask for the fudge factor treatment for the widths of
charged particles. Currently, this only applies to $W^\pm$ and top. *)
let width f =
if !use_fudged_width then
match f with
| G Wp | G Wm | M (U 3) | M (U (-3)) | O Grav -> Fudged
| _ -> !default_width
else
!default_width
let goldstone = function
| G f ->
begin match f with
| Wp -> Some (O Phip, Coupling.Integer 1)
| Wm -> Some (O Phim, Coupling.Integer 1)
| Z -> Some (O Phi0, Coupling.Integer 1)
| _ -> None
end
| _ -> None
let conjugate = function
| M f ->
M (begin match f with
| L n -> L (-n) | N n -> N (-n)
| U n -> U (-n) | D n -> D (-n)
| L_K1_L n -> L_K1_L (-n) | L_K1_R n -> L_K1_R (-n)
| L_K2_L n -> L_K2_L (-n) | L_K2_R n -> L_K2_R (-n)
| N_K1 n -> N_K1 (-n) | N_K2 n -> N_K2 (-n)
| U_K1_L n -> U_K1_L (-n) | U_K1_R n -> U_K1_R (-n)
| U_K2_L n -> U_K2_L (-n) | U_K2_R n -> U_K2_R (-n)
| D_K1_L n -> D_K1_L (-n) | D_K1_R n -> D_K1_R (-n)
| D_K2_L n -> D_K2_L (-n) | D_K2_R n -> D_K2_R (-n)
end)
| G f ->
G (begin match f with
| Gl -> Gl | Ga -> Ga | Z -> Z
| Wp -> Wm | Wm -> Wp
| Gl_K1 -> Gl_K1 | Gl_K2 -> Gl_K2 | B1 -> B1 | B2 -> B2
| Z1 -> Z1 | Z2 -> Z2 | Wp1 -> Wm1 | Wm1 -> Wp1
| Wp2 -> Wm2 | Wm2 -> Wp2
end)
| O f ->
O (begin match f with
| Phip -> Phim | Phim -> Phip | Phi0 -> Phi0
| H -> H | H1up -> H1um | H1um -> H1up
| H1dp -> H1dm | H1dm -> H1dp
| H2up -> H2um | H2um -> H2up
| H2dp -> H2dm | H2dm -> H2dp
| Grav -> Grav
end)
let fermion = function
| M f ->
begin match f with
| L n -> if n > 0 then 1 else -1
| N n -> if n > 0 then 1 else -1
| U n -> if n > 0 then 1 else -1
| D n -> if n > 0 then 1 else -1
| L_K1_L n -> if n > 0 then 1 else -1
| L_K2_L n -> if n > 0 then 1 else -1
| L_K1_R n -> if n > 0 then 1 else -1
| L_K2_R n -> if n > 0 then 1 else -1
| U_K1_L n -> if n > 0 then 1 else -1
| U_K2_L n -> if n > 0 then 1 else -1
| U_K1_R n -> if n > 0 then 1 else -1
| U_K2_R n -> if n > 0 then 1 else -1
| D_K1_L n -> if n > 0 then 1 else -1
| D_K2_L n -> if n > 0 then 1 else -1
| D_K1_R n -> if n > 0 then 1 else -1
| D_K2_R n -> if n > 0 then 1 else -1
| N_K1 n -> if n > 0 then 1 else -1
| N_K2 n -> if n > 0 then 1 else -1
end
| G f ->
begin match f with
| Gl | Ga | Z | Wp | Wm | Gl_K1 | Gl_K2
| B1 | B2 | Z1 | Z2 | Wp1 | Wm1 | Wp2
| Wm2 -> 0
end
| O _ -> 0
module Ch = Charges.QQ
let ( // ) = Algebra.Small_Rational.make
let generation' = function
| 1 -> [ 1//1; 0//1; 0//1]
| 2 -> [ 0//1; 1//1; 0//1]
| 3 -> [ 0//1; 0//1; 1//1]
| -1 -> [-1//1; 0//1; 0//1]
| -2 -> [ 0//1; -1//1; 0//1]
| -3 -> [ 0//1; 0//1; -1//1]
| n -> invalid_arg ("SM.generation': " ^ string_of_int n)
let generation f =
match f with
| M (L n | N n | U n | D n | L_K1_L n | L_K2_L n
| L_K1_R n | L_K2_R n | N_K1 n | N_K2 n | U_K1_L n
| U_K2_L n | U_K1_R n | U_K2_R n | D_K1_L n | D_K2_L n
| D_K1_R n | D_K2_R n ) -> generation' n
| G _ | O _ -> [0//1; 0//1; 0//1]
let charge = function
| M f ->
begin match f with
| L n | L_K1_L n | L_K2_L n | L_K1_R n
| L_K2_R n -> if n > 0 then -1//1 else 1//1
| N n | N_K1 n | N_K2 n -> 0//1
| U n | U_K1_L n | U_K2_L n | U_K1_R n
| U_K2_R n -> if n > 0 then 2//3 else -2//3
| D n | D_K1_L n | D_K2_L n | D_K1_R n
| D_K2_R n -> if n > 0 then -1//3 else 1//3
end
| G f ->
begin match f with
| Gl | Gl_K1 | Gl_K2 | Ga | Z
| B1 | B2 | Z1 | Z2 -> 0//1
| Wp | Wp1 | Wp2 -> 1//1
| Wm | Wm1 | Wm2 -> -1//1
end
| O f ->
begin match f with
| H | Phi0 | Grav -> 0//1
| H1up | H1dp | H2up | H2dp | Phip -> 1//1
| H1um | H1dm | H2um | H2dm | Phim -> -1//1
end
let lepton = function
| M f ->
begin match f with
| L n | N n | L_K1_L n | L_K1_R n | L_K2_L n
| L_K2_R n | N_K1 n | N_K2 n -> if n > 0 then 1//1 else -1//1
| U _ | D _ | _ -> 0//1
end
| G _ | O _ -> 0//1
let baryon = function
| M f ->
begin match f with
| U n | D n | U_K1_L n | U_K1_R n | U_K2_L n
| U_K2_R n | D_K1_L n | D_K1_R n | D_K2_L n
| D_K2_R n -> if n > 0 then 1//1 else -1//1
| L _ | N _ | _ -> 0//1
end
| G _ | O _ -> 0//1
let charges f =
[ charge f; lepton f; baryon f] @ generation f
type constant =
| Unit | Pi | Alpha_QED | Sin2thw
| Sinthw | Costhw | E | G_weak | Vev
| Q_lepton | Q_up | Q_down | G_CC | G_CCQ of int*int
| G_NC_neutrino | G_NC_lepton | G_NC_up | G_NC_down
| I_Q_W | I_G_ZWW | I_Q_W_K | I_G_ZWW_K1 | I_G_ZWW_K2
| I_G_ZWW_K3
| G_WWWW | G_ZZWW | G_AZWW | G_AAWW
| G_HWW | G_HHWW | G_HZZ | G_HHZZ
| G_Htt | G_Hbb | G_Hcc | G_Htautau | G_H3 | G_H4
| G_HGaZ | G_HGaGa | G_Hgg
| Gs | I_Gs | I_GsRt2 | G2 | G22 | G_Grav
| Mass of flavor | Width of flavor
(* Two integer counters for the QCD and EW order of the couplings. *)
- type orders = int * int
+ type coupling_order = QCD | EW
+ let all_coupling_orders () = [QCD; EW]
+ let coupling_order_to_string = function
+ | QCD -> "QCD"
+ | EW -> "EW"
- let orders = function
- | _ -> (0,0)
+ let coupling_orders = function
+ | _ -> failwith "Modellib_BSM.UED.orders: not implemented yet!"
let input_parameters =
[]
let derived_parameters =
[]
let g_over_2_costh =
Quot (Neg (Atom G_weak), Prod [Integer 2; Atom Costhw])
let nc_coupling c t3 q =
(Real_Array c,
[Prod [g_over_2_costh; Diff (t3, Prod [Integer 2; q; Atom Sin2thw])];
Prod [g_over_2_costh; t3]])
let half = Quot (Integer 1, Integer 2)
let derived_parameter_arrays =
[ nc_coupling G_NC_neutrino half (Integer 0);
nc_coupling G_NC_lepton (Neg half) (Integer (-1));
nc_coupling G_NC_up half (Quot (Integer 2, Integer 3));
nc_coupling G_NC_down (Neg half) (Quot (Integer (-1), Integer 3)) ]
let parameters () =
{ input = input_parameters;
derived = derived_parameters;
derived_arrays = derived_parameter_arrays }
module F = Modeltools.Fusions (struct
type f = flavor
type c = constant
let compare = compare
let conjugate = conjugate
end)
let mgm ((m1, g, m2), fbf, c) = ((M m1, G g, M m2), fbf, c)
let mom ((m1, o, m2), fbf, c) = ((M m1, O o, M m2), fbf, c)
let electromagnetic_currents n =
List.map mgm
[ ((L (-n), Ga, L n), FBF (1, Psibar, V, Psi), Q_lepton);
((U (-n), Ga, U n), FBF (1, Psibar, V, Psi), Q_up);
((D (-n), Ga, D n), FBF (1, Psibar, V, Psi), Q_down) ]
let neutral_currents n =
List.map mgm
[ ((L (-n), Z, L n), FBF (1, Psibar, VA, Psi), G_NC_lepton);
((N (-n), Z, N n), FBF (1, Psibar, VA, Psi), G_NC_neutrino);
((U (-n), Z, U n), FBF (1, Psibar, VA, Psi), G_NC_up);
((D (-n), Z, D n), FBF (1, Psibar, VA, Psi), G_NC_down) ]
let charged_currents n =
List.map mgm
[ ((L (-n), Wm, N n), FBF (1, Psibar, VL, Psi), G_CC);
((N (-n), Wp, L n), FBF (1, Psibar, VL, Psi), G_CC);
((D (-n), Wm, U n), FBF (1, Psibar, VL, Psi), G_CC);
((U (-n), Wp, D n), FBF (1, Psibar, VL, Psi), G_CC) ]
let color_currents n =
List.map mgm
[ ((U (-n), Gl, U n), FBF ((-1), Psibar, V, Psi), Gs);
((D (-n), Gl, D n), FBF ((-1), Psibar, V, Psi), Gs) ]
let gravity_currents n =
List.map mom
[ ((L (-n), Grav, L n), Graviton_Spinor_Spinor 1, G_Grav);
((N (-n), Grav, N n), Graviton_Spinor_Spinor 1, G_Grav);
((U (-n), Grav, U n), Graviton_Spinor_Spinor 1, G_Grav);
((D (-n), Grav, D n), Graviton_Spinor_Spinor 1, G_Grav) ]
let yukawa =
List.map mom
[ ((U (-3), H, U 3), FBF (1, Psibar, S, Psi), G_Htt);
((D (-3), H, D 3), FBF (1, Psibar, S, Psi), G_Hbb);
((U (-2), H, U 2), FBF (1, Psibar, S, Psi), G_Hcc);
((L (-3), H, L 3), FBF (1, Psibar, S, Psi), G_Htautau) ]
let tgc ((g1, g2, g3), t, c) = ((G g1, G g2, G g3), t, c)
(* Gluons should be included in just that way. *)
let standard_triple_gauge =
List.map tgc
[ ((Ga, Wm, Wp), Gauge_Gauge_Gauge 1, I_Q_W);
((Ga, Wm1, Wp1), Gauge_Gauge_Gauge 1, I_Q_W_K);
((Z, Wm, Wp), Gauge_Gauge_Gauge 1, I_G_ZWW);
((Z, Wm1, Wp1), Gauge_Gauge_Gauge 1, I_G_ZWW_K1);
((Z1, Wm, Wp1), Gauge_Gauge_Gauge 1, I_G_ZWW_K2);
((Z1, Wm1, Wp), Gauge_Gauge_Gauge 1, I_G_ZWW_K2);
((Z2, Wm1, Wp2), Gauge_Gauge_Gauge 1, I_G_ZWW_K3);
((Gl, Gl, Gl), Gauge_Gauge_Gauge 1, I_Gs);
((Gl, Gl_K2, Gl_K2), Gauge_Gauge_Gauge (-1), I_Gs);
((Gl, Gl_K1, Gl_K1), Gauge_Gauge_Gauge 1, I_Gs);
((Gl_K2, Gl_K1, Gl_K1), Gauge_Gauge_Gauge 1, I_GsRt2)]
let triple_gauge =
standard_triple_gauge
let qgc ((g1, g2, g3, g4), t, c) = ((G g1, G g2, G g3, G g4), t, c)
let gauge4 = Vector4 [(2, C_13_42); (-1, C_12_34); (-1, C_14_23)]
let minus_gauge4 = Vector4 [(-2, C_13_42); (1, C_12_34); (1, C_14_23)]
let standard_quartic_gauge =
List.map qgc
[ (Wm, Wp, Wm, Wp), gauge4, G_WWWW;
(Wm, Z, Wp, Z), minus_gauge4, G_ZZWW;
(Wm, Z, Wp, Ga), minus_gauge4, G_AZWW;
(Wm, Ga, Wp, Ga), minus_gauge4, G_AAWW;
((Gl, Gl, Gl, Gl), gauge4, G2);
((Gl, Gl, Gl_K1, Gl_K1), gauge4, G2);
((Gl, Gl, Gl_K2, Gl_K2), gauge4, G2);
((Gl_K1, Gl_K1, Gl_K2, Gl_K2), gauge4, G2);
((Gl_K2, Gl_K2, Gl_K2, Gl_K2), gauge4, G22)]
let quartic_gauge =
standard_quartic_gauge
let gravity_gauge =
[ (O Grav, G Z, G Z), Graviton_Vector_Vector 1, G_Grav;
(O Grav, G Wp, G Wm), Graviton_Vector_Vector 1, G_Grav;
(O Grav, G Ga, G Ga), Graviton_Vector_Vector 1, G_Grav;
(O Grav, G Gl, G Gl), Graviton_Vector_Vector 1, G_Grav ]
let standard_gauge_higgs =
[ ((O H, G Wp, G Wm), Scalar_Vector_Vector 1, G_HWW);
((O H, G Z, G Z), Scalar_Vector_Vector 1, G_HZZ) ]
let standard_gauge_higgs4 =
[ (O H, O H, G Wp, G Wm), Scalar2_Vector2 1, G_HHWW;
(O H, O H, G Z, G Z), Scalar2_Vector2 1, G_HHZZ ]
let standard_higgs =
[ (O H, O H, O H), Scalar_Scalar_Scalar 1, G_H3 ]
let standard_higgs4 =
[ (O H, O H, O H, O H), Scalar4 1, G_H4 ]
let gravity_higgs =
[ (O Grav, O H, O H), Graviton_Scalar_Scalar 1, G_Grav]
let anomalous_gauge_higgs =
[]
let anomalous_gauge_higgs4 =
[]
let anomalous_higgs =
[]
let anomaly_higgs =
[ (O H, G Ga, G Ga), Dim5_Scalar_Gauge2 1, G_HGaGa;
(O H, G Ga, G Z), Dim5_Scalar_Gauge2 1, G_HGaZ;
(O H, G Gl, G Gl), Dim5_Scalar_Gauge2 1, G_Hgg ]
let anomalous_higgs4 =
[]
let gauge_higgs =
standard_gauge_higgs
let gauge_higgs4 =
standard_gauge_higgs4
let higgs =
standard_higgs @ gravity_higgs
let higgs4 =
standard_higgs4
let goldstone_vertices =
[ ((O Phi0, G Wm, G Wp), Scalar_Vector_Vector 1, I_G_ZWW);
((O Phip, G Ga, G Wm), Scalar_Vector_Vector 1, I_Q_W);
((O Phip, G Z, G Wm), Scalar_Vector_Vector 1, I_G_ZWW);
((O Phim, G Wp, G Ga), Scalar_Vector_Vector 1, I_Q_W);
((O Phim, G Wp, G Z), Scalar_Vector_Vector 1, I_G_ZWW) ]
let vertices3 =
(ThoList.flatmap electromagnetic_currents [1;2;3] @
ThoList.flatmap neutral_currents [1;2;3] @
ThoList.flatmap charged_currents [1;2;3] @
ThoList.flatmap color_currents [1;2;3] @
ThoList.flatmap gravity_currents [1;2;3] @
yukawa @ triple_gauge @ gravity_gauge @
gauge_higgs @ higgs @ anomaly_higgs
@ goldstone_vertices)
let vertices4 =
quartic_gauge @ gauge_higgs4 @ higgs4
let vertices () = (vertices3, vertices4, [])
(* For efficiency, make sure that [F.of_vertices vertices] is
evaluated only once. *)
let table = F.of_vertices (vertices ())
let fuse2 = F.fuse2 table
let fuse3 = F.fuse3 table
let fuse = F.fuse table
let max_degree () = 4
let flavor_of_string = function
| "e-" -> M (L 1) | "e+" -> M (L (-1))
| "mu-" -> M (L 2) | "mu+" -> M (L (-2))
| "tau-" -> M (L 3) | "tau+" -> M (L (-3))
| "nue" -> M (N 1) | "nuebar" -> M (N (-1))
| "numu" -> M (N 2) | "numubar" -> M (N (-2))
| "nutau" -> M (N 3) | "nutaubar" -> M (N (-3))
| "u" -> M (U 1) | "ubar" -> M (U (-1))
| "c" -> M (U 2) | "cbar" -> M (U (-2))
| "t" -> M (U 3) | "tbar" -> M (U (-3))
| "d" -> M (D 1) | "dbar" -> M (D (-1))
| "s" -> M (D 2) | "sbar" -> M (D (-2))
| "b" -> M (D 3) | "bbar" -> M (D (-3))
| "uk1l" -> M (U_K1_L 1) | "uk1lbar" -> M (U_K1_L (-1))
| "ck1l" -> M (U_K1_L 2) | "ck1lbar" -> M (U_K1_L (-2))
| "tk1l" -> M (U_K1_L 3) | "tk1lbar" -> M (U_K1_L (-3))
| "dk1l" -> M (D_K1_L 1) | "dk1lbar" -> M (D_K1_L (-1))
| "sk1l" -> M (D_K1_L 2) | "sk1lbar" -> M (D_K1_L (-2))
| "bk1l" -> M (D_K1_L 3) | "bk1lbar" -> M (D_K1_L (-3))
| "uk1r" -> M (U_K1_R 1) | "uk1rbar" -> M (U_K1_R (-1))
| "ck1r" -> M (U_K1_R 2) | "ck1rbar" -> M (U_K1_R (-2))
| "tk1r" -> M (U_K1_R 3) | "tk1rbar" -> M (U_K1_R (-3))
| "dk1r" -> M (D_K1_R 1) | "dk1rbar" -> M (D_K1_R (-1))
| "sk1r" -> M (D_K1_R 2) | "sk1rbar" -> M (D_K1_R (-2))
| "bk1r" -> M (D_K1_R 3) | "bk1rbar" -> M (D_K1_R (-3))
| "uk2l" -> M (U_K2_L 1) | "uk2lbar" -> M (U_K2_L (-1))
| "ck2l" -> M (U_K2_L 2) | "ck2lbar" -> M (U_K2_L (-2))
| "tk2l" -> M (U_K2_L 3) | "tk2lbar" -> M (U_K2_L (-3))
| "dk2l" -> M (D_K2_L 1) | "dk2lbar" -> M (D_K2_L (-1))
| "sk2l" -> M (D_K2_L 2) | "sk2lbar" -> M (D_K2_L (-2))
| "bk2l" -> M (D_K2_L 3) | "bk2lbar" -> M (D_K2_L (-3))
| "uk2r" -> M (U_K2_R 1) | "uk2rbar" -> M (U_K2_R (-1))
| "ck2r" -> M (U_K2_R 2) | "ck2rbar" -> M (U_K2_R (-2))
| "tk2r" -> M (U_K2_R 3) | "tk2rbar" -> M (U_K2_R (-3))
| "dk2r" -> M (D_K2_R 1) | "dk2rbar" -> M (D_K2_R (-1))
| "sk2r" -> M (D_K2_R 2) | "sk2rbar" -> M (D_K2_R (-2))
| "bk2r" -> M (D_K2_R 3) | "bk2rbar" -> M (D_K2_R (-3))
| "g" | "gl" -> G Gl
| "g_k1" | "gl_k1" -> G Gl_K1
| "g_k2" | "gl_k2" -> G Gl_K2
| "b1" -> G B1 | "b2" -> G B2 | "z1" -> G Z1 | "z2" -> G Z2
| "W1+" -> G Wp1 | "W1-" -> G Wm1
| "W2+" -> G Wp2 | "W2-" -> G Wm2
| "A" -> G Ga | "Z" | "Z0" -> G Z
| "W+" -> G Wp | "W-" -> G Wm
| "H" -> O H | "H1u+" -> O H1up | "H1u-" -> O H1um
| "H1d+" -> O H1dp | "H1d-" -> O H1dm
| "H2u+" -> O H2up | "H2u-" -> O H2um
| "H2d+" -> O H2dp | "H2d-" -> O H2dm
| "GG" -> O Grav
| "ek1l-" -> M (L_K1_L 1) | "ek1l+" -> M (L_K1_L (-1))
| "muk1l-" -> M (L_K1_L 2) | "mu1l+" -> M (L_K1_L (-2))
| "tauk1l-" -> M (L_K1_L 3) | "tauk1l+" -> M (L_K1_L (-3))
| "ek1r-" -> M (L_K1_R 1) | "ek1r+" -> M (L_K1_R (-1))
| "muk1r-" -> M (L_K1_R 2) | "mu1r+" -> M (L_K1_R (-2))
| "tau1r-" -> M (L_K1_R 3) | "tauk1r+" -> M (L_K1_R (-3))
| "ek2l-" -> M (L_K2_L 1) | "ek2l+" -> M (L_K2_L (-1))
| "muk2l-" -> M (L_K2_L 2) | "mu2l+" -> M (L_K2_L (-2))
| "tauk2l-" -> M (L_K2_L 3) | "tauk2l+" -> M (L_K2_L (-3))
| "ek2r-" -> M (L_K2_R 1) | "ek2r+" -> M (L_K2_R (-1))
| "muk2r-" -> M (L_K2_R 2) | "mu2r+" -> M (L_K2_R (-2))
| "tau2r-" -> M (L_K2_R 3) | "tauk2r+" -> M (L_K2_R (-3))
| "nuek1" -> M (N_K1 1) | "nuek1bar" -> M (N_K1 (-1))
| "numuk1" -> M (N_K1 2) | "numuk1bar" -> M (N_K1 (-2))
| "nutauk1" -> M (N_K1 3) | "nutauk1bar" -> M (N_K1 (-3))
| "nuek2" -> M (N_K2 1) | "nuek2bar" -> M (N_K2 (-1))
| "numuk2" -> M (N_K2 2) | "numuk2bar" -> M (N_K2 (-2))
| "nutauk2" -> M (N_K2 3) | "nutauk2bar" -> M (N_K2 (-3))
| _ -> invalid_arg "Modellib_BSM.UED.flavor_of_string"
let flavor_to_string = function
| M f ->
begin match f with
| L 1 -> "e-" | L (-1) -> "e+"
| L 2 -> "mu-" | L (-2) -> "mu+"
| L 3 -> "tau-" | L (-3) -> "tau+"
| L _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_string: invalid lepton"
| N 1 -> "nue" | N (-1) -> "nuebar"
| N 2 -> "numu" | N (-2) -> "numubar"
| N 3 -> "nutau" | N (-3) -> "nutaubar"
| N _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_string: invalid neutrino"
| U 1 -> "u" | U (-1) -> "ubar"
| U 2 -> "c" | U (-2) -> "cbar"
| U 3 -> "t" | U (-3) -> "tbar"
| U _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_string: invalid up type quark"
| D 1 -> "d" | D (-1) -> "dbar"
| D 2 -> "s" | D (-2) -> "sbar"
| D 3 -> "b" | D (-3) -> "bbar"
| D _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_string: invalid down type quark"
| U_K1_L 1 -> "uk1l" | U_K1_L (-1) -> "uk1lbar"
| U_K1_L 2 -> "ck1l" | U_K1_L (-2) -> "ck1lbar"
| U_K1_L 3 -> "tk1l" | U_K1_L (-3) -> "tk1lbar"
| U_K1_L _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_string: invalid up type quark"
| D_K1_L 1 -> "dk1l" | D_K1_L (-1) -> "dk1lbar"
| D_K1_L 2 -> "sk1l" | D_K1_L (-2) -> "sk1lbar"
| D_K1_L 3 -> "bk1l" | D_K1_L (-3) -> "bk1lbar"
| D_K1_L _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_string: invalid down type quark"
| U_K1_R 1 -> "uk1r" | U_K1_R (-1) -> "uk1rbar"
| U_K1_R 2 -> "ck1r" | U_K1_R (-2) -> "ck1rbar"
| U_K1_R 3 -> "tk1r" | U_K1_R (-3) -> "tk1rbar"
| U_K1_R _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_string: invalid up type quark"
| D_K1_R 1 -> "dk1r" | D_K1_R (-1) -> "dk1rbar"
| D_K1_R 2 -> "sk1r" | D_K1_R (-2) -> "sk1rbar"
| D_K1_R 3 -> "bk1r" | D_K1_R (-3) -> "bk1rbar"
| D_K1_R _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_string: invalid down type quark"
| U_K2_L 1 -> "uk2l" | U_K2_L (-1) -> "uk2lbar"
| U_K2_L 2 -> "ck2l" | U_K2_L (-2) -> "ck2lbar"
| U_K2_L 3 -> "tk2l" | U_K2_L (-3) -> "tk2lbar"
| U_K2_L _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_string: invalid up type quark"
| D_K2_L 1 -> "dk2l" | D_K2_L (-1) -> "dk2lbar"
| D_K2_L 2 -> "sk2l" | D_K2_L (-2) -> "sk2lbar"
| D_K2_L 3 -> "bk2l" | D_K2_L (-3) -> "bk2lbar"
| D_K2_L _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_string: invalid down type quark"
| U_K2_R 1 -> "uk2r" | U_K2_R (-1) -> "uk2rbar"
| U_K2_R 2 -> "ck2r" | U_K2_R (-2) -> "ck2rbar"
| U_K2_R 3 -> "tk2r" | U_K2_R (-3) -> "tk2rbar"
| U_K2_R _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_string: invalid up type quark"
| D_K2_R 1 -> "dk2r" | D_K2_R (-1) -> "dk2rbar"
| D_K2_R 2 -> "sk2r" | D_K2_R (-2) -> "sk2rbar"
| D_K2_R 3 -> "bk2r" | D_K2_R (-3) -> "bk2rbar"
| D_K2_R _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_string: invalid down type quark"
| L_K1_L 1 -> "ek1l-" | L_K1_L (-1) -> "ek1l+"
| L_K1_L 2 -> "muk1l-" | L_K1_L (-2) -> "muk1l+"
| L_K1_L 3 -> "tauk1l-" | L_K1_L (-3) -> "tauk1l+"
| L_K1_L _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_string: invalid lepton"
| L_K1_R 1 -> "ek1r-" | L_K1_R (-1) -> "ek1r+"
| L_K1_R 2 -> "muk1r-" | L_K1_R (-2) -> "muk1r+"
| L_K1_R 3 -> "tauk1r-" | L_K1_R (-3) -> "tauk1r+"
| L_K1_R _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_string: invalid lepton"
| L_K2_L 1 -> "ek2l-" | L_K2_L (-1) -> "ek2l+"
| L_K2_L 2 -> "muk2l-" | L_K2_L (-2) -> "muk2l+"
| L_K2_L 3 -> "tauk2l-" | L_K2_L (-3) -> "tauk2l+"
| L_K2_L _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_string: invalid lepton"
| L_K2_R 1 -> "ek2r-" | L_K2_R (-1) -> "ek2r+"
| L_K2_R 2 -> "muk2r-" | L_K2_R (-2) -> "muk2r+"
| L_K2_R 3 -> "tauk2r-" | L_K2_R (-3) -> "tauk2r+"
| L_K2_R _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_string: invalid lepton"
| N_K1 1 -> "nuek1" | N_K1 (-1) -> "nuek1bar"
| N_K1 2 -> "numuk1" | N_K1 (-2) -> "numuk1bar"
| N_K1 3 -> "nutauk1" | N_K1 (-3) -> "nutauk1bar"
| N_K1 _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_string: invalid neutrino"
| N_K2 1 -> "nuek2" | N_K2 (-1) -> "nuek2bar"
| N_K2 2 -> "numuk2" | N_K2 (-2) -> "numuk2bar"
| N_K2 3 -> "nutauk2" | N_K2 (-3) -> "nutauk2bar"
| N_K2 _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_string: invalid neutrino"
end
| G f ->
begin match f with
| Gl -> "g"
| Ga -> "A" | Z -> "Z"
| Wp -> "W+" | Wm -> "W-"
| Gl_K1 -> "gk1" | Gl_K2 -> "gk2"
| B1 -> "b1" | B2 -> "b2" | Z1 -> "z1" | Z2 -> "z2"
| Wp1 -> "W1+" | Wm1 -> "W1-"
| Wp2 -> "W2+" | Wm2 -> "W2-"
end
| O f ->
begin match f with
| Phip -> "phi+" | Phim -> "phi-" | Phi0 -> "phi0"
| H -> "H" | H1up -> "H1u+" | H1um -> "H1u-"
| H1dp -> "H1d+" | H1dm -> "H1d-"
| H2up -> "H2u+" | H2um -> "H2u-"
| H2dp -> "H2d+" | H2dm -> "H2d-"
| Grav -> "GG"
end
let flavor_to_TeX = function
| M f ->
begin match f with
| L 1 -> "e^-" | L (-1) -> "e^+"
| L 2 -> "\\mu^-" | L (-2) -> "\\mu^+"
| L 3 -> "\\tau^-" | L (-3) -> "\\tau^+"
| L _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_TeX: invalid lepton"
| N 1 -> "\\nu_e" | N (-1) -> "\\bar{\\nu}_e"
| N 2 -> "\\nu_\\mu" | N (-2) -> "\\bar{\\nu}_\\mu"
| N 3 -> "\\nu_\\tau" | N (-3) -> "\\bar{\\nu}_\\tau"
| N _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_TeX: invalid neutrino"
| U 1 -> "u" | U (-1) -> "\\bar{u}"
| U 2 -> "c" | U (-2) -> "\\bar{c}"
| U 3 -> "t" | U (-3) -> "\\bar{t}"
| U _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_TeX: invalid up type quark"
| D 1 -> "d" | D (-1) -> "dbar"
| D 2 -> "s" | D (-2) -> "sbar"
| D 3 -> "b" | D (-3) -> "bbar"
| D _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_TeX: invalid down type quark"
| U_K1_L 1 -> "u^\\prime_L" | U_K1_L (-1) -> "\\bar{u}^\\prime_L"
| U_K1_L 2 -> "c^\\prime_L" | U_K1_L (-2) -> "\\bar{c}^\\prime_L"
| U_K1_L 3 -> "t^\\prime_L" | U_K1_L (-3) -> "\\bar{t}^\\prime_L"
| U_K1_L _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_TeX: invalid up type quark"
| D_K1_L 1 -> "d^\\prime_L" | D_K1_L (-1) -> "\\bar{d}^\\prime_L"
| D_K1_L 2 -> "s^\\prime_L" | D_K1_L (-2) -> "\\bar{s}^\\prime_L"
| D_K1_L 3 -> "b^\\prime_L" | D_K1_L (-3) -> "\\bar{b}^\\prime_L"
| D_K1_L _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_TeX: invalid down type quark"
| U_K1_R 1 -> "u^\\prime_R" | U_K1_R (-1) -> "\\bar{u}^\\prime_R"
| U_K1_R 2 -> "c^\\prime_R" | U_K1_R (-2) -> "\\bar{c}^\\prime_R"
| U_K1_R 3 -> "t^\\prime_R" | U_K1_R (-3) -> "\\bar{t}^\\prime_R"
| U_K1_R _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_TeX: invalid up type quark"
| D_K1_R 1 -> "d^\\prime_R" | D_K1_R (-1) -> "\\bar{d}^\\prime_R"
| D_K1_R 2 -> "s^\\prime_R" | D_K1_R (-2) -> "\\bar{s}^\\prime_R"
| D_K1_R 3 -> "b^\\prime_R" | D_K1_R (-3) -> "\\bar{b}^\\prime_R"
| D_K1_R _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_TeX: invalid down type quark"
| U_K2_L 1 -> "u^{\\prime\\prime}_L" | U_K2_L (-1) -> "\\bar{u}^{\\prime\\prime}_L"
| U_K2_L 2 -> "c^{\\prime\\prime}_L" | U_K2_L (-2) -> "\\bar{c}^{\\prime\\prime}_L"
| U_K2_L 3 -> "t^{\\prime\\prime}_L" | U_K2_L (-3) -> "\\bar{t}^{\\prime\\prime}_L"
| U_K2_L _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_TeX: invalid up type quark"
| D_K2_L 1 -> "d^{\\prime\\prime}_L" | D_K2_L (-1) -> "\\bar{d}^{\\prime\\prime}_L"
| D_K2_L 2 -> "s^{\\prime\\prime}_L" | D_K2_L (-2) -> "\\bar{s}^{\\prime\\prime}_L"
| D_K2_L 3 -> "b^{\\prime\\prime}_L" | D_K2_L (-3) -> "\\bar{b}^{\\prime\\prime}_L"
| D_K2_L _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_TeX: invalid down type quark"
| U_K2_R 1 -> "u^{\\prime\\prime}_R" | U_K2_R (-1) -> "\\bar{u}^{\\prime\\prime}_R"
| U_K2_R 2 -> "c^{\\prime\\prime}_R" | U_K2_R (-2) -> "\\bar{c}^{\\prime\\prime}_R"
| U_K2_R 3 -> "t^{\\prime\\prime}_R" | U_K2_R (-3) -> "\\bar{t}^{\\prime\\prime}_R"
| U_K2_R _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_TeX: invalid up type quark"
| D_K2_R 1 -> "d^\\prime_R" | D_K2_R (-1) -> "\\bar{d}^{\\prime\\prime}_R"
| D_K2_R 2 -> "s^\\prime_R" | D_K2_R (-2) -> "\\bar{s}^{\\prime\\prime}_R"
| D_K2_R 3 -> "b^\\prime_R" | D_K2_R (-3) -> "\\bar{b}^{\\prime\\prime}_R"
| D_K2_R _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_TeX: invalid down type quark"
| L_K1_L 1 -> "e_L^{\\prime,,-}" | L_K1_L (-1) -> "\\bar{e}_L^{\\prime,,+}"
| L_K1_L 2 -> "\\mu_L^{\\prime,,-}" | L_K1_L (-2) -> "\\bar{\\mu}_L^{{\\prime,,+}"
| L_K1_L 3 -> "\\tau_L^{\\prime,,-}" | L_K1_L (-3) -> "\\bar{\\tau}_L^{\\prime,,+}"
| L_K1_L _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_TeX: invalid lepton"
| L_K1_R 1 -> "e_R^{\\prime,,-}" | L_K1_R (-1) -> "\\bar{e}_R^{\\prime,,+}"
| L_K1_R 2 -> "\\mu_R{\\prime,,-}" | L_K1_R (-2) -> "\\bar{\\mu}_R^{\\prime,,+}"
| L_K1_R 3 -> "\\tau_R¬{\\prime,,-}" | L_K1_R (-3) -> "\\bar{\\tau}_R¬{\\prime,,+}"
| L_K1_R _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_TeX: invalid lepton"
| L_K2_L 1 -> "e^{\\prime\\prime,,-}_L" | L_K2_L (-1) -> "\\bar{e}_L^{\\prime\\prime,,+}"
| L_K2_L 2 -> "\\mu_L^{\\prime\\prime,,-}" | L_K2_L (-2) -> "\\bar{\\mu}_L^{\\prime\\prime,,+}"
| L_K2_L 3 -> "\\tau_L^{\\prime\\prime,,-}" | L_K2_L (-3) -> "\\bar{\\tau}_L^{\\prime\\prime,,+}"
| L_K2_L _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_TeX: invalid lepton"
| L_K2_R 1 -> "e_R^{\\prime\\prime,,-}" | L_K2_R (-1) -> "\\bar{e}_R^{\\prime\\prime,,+}"
| L_K2_R 2 -> "\\mu_R^{\\prime\\prime,,-}" | L_K2_R (-2) -> "\\bar{\\mu}_R^{\\prime\\prime,,+}"
| L_K2_R 3 -> "\\tau_R{\\prime\\prime,,-}" | L_K2_R (-3) -> "\\bar{\\tau}_R^{\\prime\\prime,,+}"
| L_K2_R _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_TeX: invalid lepton"
| N_K1 1 -> "\\nu_e^\\prime" | N_K1 (-1) -> "\\bar{\\nu}_e^\\prime"
| N_K1 2 -> "\\nu_\\mu^\\prime" | N_K1 (-2) -> "\\bar{\\nu}_\\mu^\\prime"
| N_K1 3 -> "\\nu_\\tau^\\prime" | N_K1 (-3) -> "\\bar{\\nu}_\\tau^\\prime"
| N_K1 _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_TeX: invalid neutrino"
| N_K2 1 -> "\\nu_e^{\\prime\\prime}" | N_K2 (-1) -> "\\bar{\\nu}_e^{\\prime\\prime}"
| N_K2 2 -> "\\nu_\\mu^{\\prime\\prime}" | N_K2 (-2) -> "\\bar{\\nu}_\\mu^{\\prime\\prime}"
| N_K2 3 -> "\\nu_\\tau^{\\prime\\prime}" | N_K2 (-3) -> "\\bar{\\nu}_\\tau^{\\prime\\prime}"
| N_K2 _ -> invalid_arg
"Modellib_BSM.UED.flavor_to_TeX: invalid neutrino"
end
| G f ->
begin match f with
| Gl -> "g"
| Ga -> "\\gamma" | Z -> "Z"
| Wp -> "W^+" | Wm -> "W^-"
| Gl_K1 -> "g^\\prime" | Gl_K2 -> "g^{\\prime\\prime}"
| B1 -> "B^\\prime" | B2 -> "B^{\\prime\\prime}"
| Z1 -> "Z^\\prime" | Z2 -> "Z^{\\prime\\prime}"
| Wp1 -> "W^{\\prime,,+}" | Wm1 -> "W^{\\prime,,-}"
| Wp2 -> "W^{\\prime\\prime,,+}" | Wm2 -> "W^{\\prime\\prime,,-}"
end
| O f ->
begin match f with
| Phip -> "\\phi^+" | Phim -> "\\phi^-" | Phi0 -> "\\phi^0"
| H -> "H" | H1up -> "H1u+" | H1um -> "H1u-"
| H1dp -> "H1d+" | H1dm -> "H1d-"
| H2up -> "H2u+" | H2um -> "H2u-"
| H2dp -> "H2d+" | H2dm -> "H2d-"
| Grav -> "G^\\prime"
end
let flavor_symbol = function
| M f ->
begin match f with
| L n when n > 0 -> "l" ^ string_of_int n
| L n -> "l" ^ string_of_int (abs n) ^ "b"
| N n when n > 0 -> "n" ^ string_of_int n
| N n -> "n" ^ string_of_int (abs n) ^ "b"
| U n when n > 0 -> "u" ^ string_of_int n
| U n -> "u" ^ string_of_int (abs n) ^ "b"
| D n when n > 0 -> "d" ^ string_of_int n
| D n -> "d" ^ string_of_int (abs n) ^ "b"
| L_K1_L n when n > 0 -> "lk1l" ^ string_of_int n
| L_K1_L n -> "lk1l" ^ string_of_int (abs n) ^ "b"
| L_K1_R n when n > 0 -> "lk1r" ^ string_of_int n
| L_K1_R n -> "lk1r" ^ string_of_int (abs n) ^ "b"
| L_K2_L n when n > 0 -> "lk2l" ^ string_of_int n
| L_K2_L n -> "lk2l" ^ string_of_int (abs n) ^ "b"
| L_K2_R n when n > 0 -> "lk2r" ^ string_of_int n
| L_K2_R n -> "lk2r" ^ string_of_int (abs n) ^ "b"
| U_K1_L n when n > 0 -> "uk1l" ^ string_of_int n
| U_K1_L n -> "uk1l" ^ string_of_int (abs n) ^ "b"
| U_K1_R n when n > 0 -> "uk1r" ^ string_of_int n
| U_K1_R n -> "uk1r" ^ string_of_int (abs n) ^ "b"
| U_K2_L n when n > 0 -> "uk2l" ^ string_of_int n
| U_K2_L n -> "uk2l" ^ string_of_int (abs n) ^ "b"
| U_K2_R n when n > 0 -> "uk2r" ^ string_of_int n
| U_K2_R n -> "uk2r" ^ string_of_int (abs n) ^ "b"
| D_K1_L n when n > 0 -> "dk1l" ^ string_of_int n
| D_K1_L n -> "dk1l" ^ string_of_int (abs n) ^ "b"
| D_K1_R n when n > 0 -> "dk1r" ^ string_of_int n
| D_K1_R n -> "dk1r" ^ string_of_int (abs n) ^ "b"
| D_K2_L n when n > 0 -> "dk2l" ^ string_of_int n
| D_K2_L n -> "dk2l" ^ string_of_int (abs n) ^ "b"
| D_K2_R n when n > 0 -> "dk2r" ^ string_of_int n
| D_K2_R n -> "dk2r" ^ string_of_int (abs n) ^ "b"
| N_K1 n when n > 0 -> "nk1" ^ string_of_int n
| N_K1 n -> "nk1" ^ string_of_int (abs n) ^ "b"
| N_K2 n when n > 0 -> "nk2" ^ string_of_int n
| N_K2 n -> "nk2" ^ string_of_int (abs n) ^ "b"
end
| G f ->
begin match f with
| Gl -> "gl"
| Ga -> "a" | Z -> "z"
| Wp -> "wp" | Wm -> "wm"
| Gl_K1 -> "gk1" | Gl_K2 -> "gk2"
| B1 -> "b1" | B2 -> "b2" | Z1 -> "z1" | Z2 -> "z2"
| Wp1 -> "wp1" | Wm1 -> "wm1"
| Wp2 -> "wp2" | Wm2 -> "wm2"
end
| O f ->
begin match f with
| Phip -> "pp" | Phim -> "pm" | Phi0 -> "p0"
| H -> "h" | H1up -> "h1up" | H1um -> "h1um"
| H1dp -> "h1dp" | H1dm -> "h1dm"
| H2up -> "h2up" | H2um -> "h2um"
| H2dp -> "h2dp" | H2dm -> "h2dm"
| Grav -> "gv"
end
let pdg = function
| M f ->
begin match f with
| L n when n > 0 -> 9 + 2*n
| L n -> - 9 + 2*n
| N n when n > 0 -> 10 + 2*n
| N n -> - 10 + 2*n
| U n when n > 0 -> 2*n
| U n -> 2*n
| D n when n > 0 -> - 1 + 2*n
| D n -> 1 + 2*n
| U_K1_L n when n > 0 -> 4000000 + 2*n
| U_K1_L n -> - 4000000 + 2*n
| D_K1_L n when n > 0 -> 3999999 + 2*n
| D_K1_L n -> - 3999999 + 2*n
| U_K1_R n when n > 0 -> 5000000 + 2*n
| U_K1_R n -> - 5000000 + 2*n
| D_K1_R n when n > 0 -> 4999999 + 2*n
| D_K1_R n -> - 4999999 + 2*n
| U_K2_L n when n > 0 -> 6000000 + 2*n
| U_K2_L n -> - 6000000 + 2*n
| D_K2_L n when n > 0 -> 5999999 + 2*n
| D_K2_L n -> - 5999999 + 2*n
| U_K2_R n when n > 7000000 -> 2*n
| U_K2_R n -> - 7000000 + 2*n
| D_K2_R n when n > 0 -> 6999999 + 2*n
| D_K2_R n -> - 6999999 + 2*n
| L_K1_L n when n > 0 -> 4000009 + 2*n
| L_K1_L n -> - 4000009 + 2*n
| L_K1_R n when n > 0 -> 5000009 + 2*n
| L_K1_R n -> - 5000009 + 2*n
| L_K2_L n when n > 0 -> 6000009 + 2*n
| L_K2_L n -> - 6000009 + 2*n
| L_K2_R n when n > 0 -> 7000009 + 2*n
| L_K2_R n -> - 7000009 + 2*n
| N_K1 n when n > 0 -> 4000010 + 2*n
| N_K1 n -> - 4000010 + 2*n
| N_K2 n when n > 0 -> 6000010 + 2*n
| N_K2 n -> - 6000010 + 2*n
end
| G f ->
begin match f with
| Gl -> 21
| Ga -> 22 | Z -> 23
| Wp -> 24 | Wm -> (-24)
| Gl_K1 -> 4000021 | Gl_K2 -> 6000021
| B1 -> 4000022 | B2 -> 6000022
| Z1 -> 4000023 | Z2 -> 6000024
| Wp1 -> 4000024 | Wm1 -> (-4000024)
| Wp2 -> 6000024 | Wm2 -> (-6000024)
end
| O f ->
begin match f with
| Phip | Phim -> 27 | Phi0 -> 26
| H -> 25 | H1up -> 4000036 | H1um -> (-4000036)
| H1dp -> 4000037 | H1dm -> (-4000037)
| H2up -> 6000036 | H2um -> (-6000036)
| H2dp -> 6000037 | H2dm -> (-6000037)
| Grav -> 39
end
let mass_symbol f =
"mass(" ^ string_of_int (abs (pdg f)) ^ ")"
let width_symbol f =
"width(" ^ string_of_int (abs (pdg f)) ^ ")"
let constant_symbol = function
| Unit -> "unit" | Pi -> "PI"
| Alpha_QED -> "alpha" | E -> "e" | G_weak -> "g" | Vev -> "vev"
| Sin2thw -> "sin2thw" | Sinthw -> "sinthw" | Costhw -> "costhw"
| Q_lepton -> "qlep" | Q_up -> "qup" | Q_down -> "qdwn"
| G_NC_lepton -> "gnclep" | G_NC_neutrino -> "gncneu"
| G_NC_up -> "gncup" | G_NC_down -> "gncdwn"
| G_CC -> "gcc"
| G_CCQ (n1,n2) -> "gccq" ^ string_of_int n1 ^ string_of_int n2
| I_Q_W -> "iqw" | I_G_ZWW -> "igzww"
| I_Q_W_K -> "iqwk" | I_G_ZWW_K1 -> "igzwwk1"
| I_G_ZWW_K2 -> "igzwwk2" | I_G_ZWW_K3 -> "igzwwk3"
| G_WWWW -> "gw4" | G_ZZWW -> "gzzww"
| G_AZWW -> "gazww" | G_AAWW -> "gaaww"
| G_HWW -> "ghww" | G_HZZ -> "ghzz"
| G_HHWW -> "ghhww" | G_HHZZ -> "ghhzz"
| G_Htt -> "ghtt" | G_Hbb -> "ghbb"
| G_Htautau -> "ghtautau" | G_Hcc -> "ghcc"
| G_HGaZ -> "ghgaz" | G_HGaGa -> "ghgaga" | G_Hgg -> "ghgg"
| G_H3 -> "gh3" | G_H4 -> "gh4"
| G2 -> "gs**2" | Gs -> "gs" | I_Gs -> "igs" | I_GsRt2 -> "igs/sqrt(2.0_default)"
| G22 -> "gs**2/2.0_default"
| G_Grav -> "ggrav"
| Mass f -> "mass" ^ flavor_symbol f
| Width f -> "width" ^ flavor_symbol f
end
module GravTest (Flags : BSM_flags) =
struct
open Coupling
let default_width = ref Timelike
let use_fudged_width = ref false
let options = Options.create
[ "constant_width", Arg.Unit (fun () -> default_width := Constant),
"use constant width (also in t-channel)";
"fudged_width", Arg.Set use_fudged_width,
"use fudge factor for charge particle width";
"custom_width", Arg.String (fun f -> default_width := Custom f),
"use custom width";
"cancel_widths", Arg.Unit (fun () -> default_width := Vanishing),
"use vanishing width";
"cms_width", Arg.Unit (fun () -> default_width := Complex_Mass),
"use complex mass scheme";
"running_width", Arg.Unit (fun () -> default_width := Running),
"use running width"]
let caveats () = []
type matter_field = L of int | N of int | U of int | D of int | SL of int
type gauge_boson = Ga | Wp | Wm | Z | Gl | Phino
type other = Phip | Phim | Phi0 | H | Grino
type flavor = M of matter_field | G of gauge_boson | O of other
let matter_field f = M f
let gauge_boson f = G f
let other f = O f
type field =
| Matter of matter_field
| Gauge of gauge_boson
| Other of other
let field = function
| M f -> Matter f
| G f -> Gauge f
| O f -> Other f
type gauge = unit
let gauge_symbol () =
failwith "Modellib_BSM.SM.gauge_symbol: internal error"
let family n = List.map matter_field [ L n; SL n; N n; U n; D n ]
let external_flavors () =
[ "1st Generation", ThoList.flatmap family [1; -1];
"2nd Generation", ThoList.flatmap family [2; -2];
"3rd Generation", ThoList.flatmap family [3; -3];
"Gauge Bosons", List.map gauge_boson [Ga; Z; Wp; Wm; Gl; Phino];
"Higgs", List.map other [H];
"Gravitino", List.map other [Grino];
"Goldstone Bosons", List.map other [Phip; Phim; Phi0] ]
let flavors () = ThoList.flatmap snd (external_flavors ())
let spinor n =
if n >= 0 then
Spinor
else
ConjSpinor
let lorentz = function
| M f ->
begin match f with
| L n -> spinor n | N n -> spinor n
| U n -> spinor n | D n -> spinor n
| SL _ -> Scalar
end
| G f ->
begin match f with
| Ga | Gl -> Vector
| Wp | Wm | Z -> Massive_Vector
| Phino -> Majorana
end
| O f ->
begin match f with
| Grino -> Vectorspinor
| _ -> Scalar
end
- let color = function
+ let color = function
| M (U n) -> Color.SUN (if n > 0 then 3 else -3)
| M (D n) -> Color.SUN (if n > 0 then 3 else -3)
| G Gl -> Color.AdjSUN 3
| _ -> Color.Singlet
let nc () = 3
let prop_spinor n =
if n >= 0 then
Prop_Spinor
else
Prop_ConjSpinor
let propagator = function
| M f ->
begin match f with
| L n -> prop_spinor n | N n -> prop_spinor n
| U n -> prop_spinor n | D n -> prop_spinor n
| SL n -> Prop_Scalar
end
| G f ->
begin match f with
| Ga | Gl -> Prop_Feynman
| Wp | Wm | Z -> Prop_Unitarity
| Phino -> Prop_Majorana
end
| O f ->
begin match f with
| Phip | Phim | Phi0 -> Only_Insertion
| H -> Prop_Scalar
| Grino -> Prop_Vectorspinor
end
(* Optionally, ask for the fudge factor treatment for the widths of
charged particles. Currently, this only applies to $W^\pm$ and top. *)
let width f =
if !use_fudged_width then
match f with
| G Wp | G Wm | M (U 3) | M (U (-3)) | O Grino -> Fudged
| _ -> !default_width
else
!default_width
let goldstone = function
| G f ->
begin match f with
| Wp -> Some (O Phip, Coupling.Integer 1)
| Wm -> Some (O Phim, Coupling.Integer 1)
| Z -> Some (O Phi0, Coupling.Integer 1)
| _ -> None
end
| _ -> None
let conjugate = function
| M f ->
M (begin match f with
| L n -> L (-n) | N n -> N (-n)
| U n -> U (-n) | D n -> D (-n)
| SL n -> SL (-n)
end)
| G f ->
G (begin match f with
| Gl -> Gl | Ga -> Ga | Z -> Z
| Wp -> Wm | Wm -> Wp | Phino -> Phino
end)
| O f ->
O (begin match f with
| Phip -> Phim | Phim -> Phip | Phi0 -> Phi0
| H -> H | Grino -> Grino
end)
let fermion = function
| M f ->
begin match f with
| L n -> if n > 0 then 1 else -1
| N n -> if n > 0 then 1 else -1
| U n -> if n > 0 then 1 else -1
| D n -> if n > 0 then 1 else -1
| SL _ -> 0
end
| G f ->
begin match f with
| Gl | Ga | Z | Wp | Wm -> 0
| Phino -> 2
end
| O f ->
begin match f with
| Grino -> 2
| _ -> 0
end
module Ch = Charges.QQ
let ( // ) = Algebra.Small_Rational.make
let generation' = function
| 1 -> [ 1//1; 0//1; 0//1]
| 2 -> [ 0//1; 1//1; 0//1]
| 3 -> [ 0//1; 0//1; 1//1]
| -1 -> [-1//1; 0//1; 0//1]
| -2 -> [ 0//1; -1//1; 0//1]
| -3 -> [ 0//1; 0//1; -1//1]
| n -> invalid_arg ("SM3.generation': " ^ string_of_int n)
let generation f =
match f with
| M (L n | N n | U n | D n | SL n) -> generation' n
| G _ | O _ -> [0//1; 0//1; 0//1]
let charge = function
| M f ->
begin match f with
| L n -> if n > 0 then -1//1 else 1//1
| SL n -> if n > 0 then -1//1 else 1//1
| N n -> 0//1
| U n -> if n > 0 then 2//3 else -2//3
| D n -> if n > 0 then -1//3 else 1//3
end
| G f ->
begin match f with
| Gl | Ga | Z | Phino -> 0//1
| Wp -> 1//1
| Wm -> -1//1
end
| O f ->
begin match f with
| H | Phi0 | Grino -> 0//1
| Phip -> 1//1
| Phim -> -1//1
end
let lepton = function
| M f ->
begin match f with
| L n | N n | SL n -> if n > 0 then 1//1 else -1//1
| U _ | D _ -> 0//1
end
| G _ | O _ -> 0//1
let baryon = function
| M f ->
begin match f with
| L _ | N _ | SL _ -> 0//1
| U n | D n -> if n > 0 then 1//1 else -1//1
end
| G _ | O _ -> 0//1
let charges f =
[ charge f; lepton f; baryon f] @ generation f
type constant =
| Unit | Pi | Alpha_QED | Sin2thw
| Sinthw | Costhw | E | G_weak | Vev
| Q_lepton | Q_up | Q_down | G_CC | G_CCQ of int*int
| G_NC_neutrino | G_NC_lepton | G_NC_up | G_NC_down
| I_Q_W | I_G_ZWW
| G_WWWW | G_ZZWW | G_AZWW | G_AAWW
| G_HWW | G_HHWW | G_HZZ | G_HHZZ
| G_Htt | G_Hbb | G_Hcc | G_Htautau | G_H3 | G_H4
| G_HGaZ | G_HGaGa | G_Hgg
| G_strong | G_Grav
| Mass of flavor | Width of flavor
(* Two integer counters for the QCD and EW order of the couplings. *)
- type orders = int * int
+ type coupling_order = QCD | EW
+ let all_coupling_orders () = [QCD; EW]
+ let coupling_order_to_string = function
+ | QCD -> "QCD"
+ | EW -> "EW"
- let orders = function
- | _ -> (0,0)
+ let coupling_orders = function
+ | _ -> failwith "Modellib_BSM.GravTest.orders: not implemented yet!"
let input_parameters =
[]
let derived_parameters =
[]
let g_over_2_costh =
Quot (Neg (Atom G_weak), Prod [Integer 2; Atom Costhw])
let nc_coupling c t3 q =
(Real_Array c,
[Prod [g_over_2_costh; Diff (t3, Prod [Integer 2; q; Atom Sin2thw])];
Prod [g_over_2_costh; t3]])
let half = Quot (Integer 1, Integer 2)
let derived_parameter_arrays =
[ nc_coupling G_NC_neutrino half (Integer 0);
nc_coupling G_NC_lepton (Neg half) (Integer (-1));
nc_coupling G_NC_up half (Quot (Integer 2, Integer 3));
nc_coupling G_NC_down (Neg half) (Quot (Integer (-1), Integer 3)) ]
let parameters () =
{ input = input_parameters;
derived = derived_parameters;
derived_arrays = derived_parameter_arrays }
module F = Modeltools.Fusions (struct
type f = flavor
type c = constant
let compare = compare
let conjugate = conjugate
end)
let mgm ((m1, g, m2), fbf, c) = ((M m1, G g, M m2), fbf, c)
let mom ((m1, o, m2), fbf, c) = ((M m1, O o, M m2), fbf, c)
let electromagnetic_currents n =
List.map mgm
[ ((L (-n), Ga, L n), FBF (1, Psibar, V, Psi), Q_lepton);
((U (-n), Ga, U n), FBF (1, Psibar, V, Psi), Q_up);
((D (-n), Ga, D n), FBF (1, Psibar, V, Psi), Q_down) ]
let neutral_currents n =
List.map mgm
[ ((L (-n), Z, L n), FBF (1, Psibar, VA, Psi), G_NC_lepton);
((N (-n), Z, N n), FBF (1, Psibar, VA, Psi), G_NC_neutrino);
((U (-n), Z, U n), FBF (1, Psibar, VA, Psi), G_NC_up);
((D (-n), Z, D n), FBF (1, Psibar, VA, Psi), G_NC_down) ]
let charged_currents n =
List.map mgm
[ ((L (-n), Wm, N n), FBF (1, Psibar, VL, Psi), G_CC);
((N (-n), Wp, L n), FBF (1, Psibar, VL, Psi), G_CC);
((D (-n), Wm, U n), FBF (1, Psibar, VL, Psi), G_CC);
((U (-n), Wp, D n), FBF (1, Psibar, VL, Psi), G_CC) ]
let yukawa =
List.map mom
[ ((U (-3), H, U 3), FBF (1, Psibar, S, Psi), G_Htt);
((D (-3), H, D 3), FBF (1, Psibar, S, Psi), G_Hbb);
((U (-2), H, U 2), FBF (1, Psibar, S, Psi), G_Hcc);
((L (-3), H, L 3), FBF (1, Psibar, S, Psi), G_Htautau) ]
let tgc ((g1, g2, g3), t, c) = ((G g1, G g2, G g3), t, c)
let standard_triple_gauge =
List.map tgc
[ ((Ga, Wm, Wp), Gauge_Gauge_Gauge 1, I_Q_W);
((Z, Wm, Wp), Gauge_Gauge_Gauge 1, I_G_ZWW) ]
let triple_gauge =
standard_triple_gauge
let qgc ((g1, g2, g3, g4), t, c) = ((G g1, G g2, G g3, G g4), t, c)
let gauge4 = Vector4 [(2, C_13_42); (-1, C_12_34); (-1, C_14_23)]
let minus_gauge4 = Vector4 [(-2, C_13_42); (1, C_12_34); (1, C_14_23)]
let standard_quartic_gauge =
List.map qgc
[ (Wm, Wp, Wm, Wp), gauge4, G_WWWW;
(Wm, Z, Wp, Z), minus_gauge4, G_ZZWW;
(Wm, Z, Wp, Ga), minus_gauge4, G_AZWW;
(Wm, Ga, Wp, Ga), minus_gauge4, G_AAWW ]
let quartic_gauge =
standard_quartic_gauge
let standard_gauge_higgs =
[ ((O H, G Wp, G Wm), Scalar_Vector_Vector 1, G_HWW);
((O H, G Z, G Z), Scalar_Vector_Vector 1, G_HZZ) ]
let standard_gauge_higgs4 =
[ (O H, O H, G Wp, G Wm), Scalar2_Vector2 1, G_HHWW;
(O H, O H, G Z, G Z), Scalar2_Vector2 1, G_HHZZ ]
let standard_higgs =
[ (O H, O H, O H), Scalar_Scalar_Scalar 1, G_H3 ]
let standard_higgs4 =
[ (O H, O H, O H, O H), Scalar4 1, G_H4 ]
let anomalous_gauge_higgs =
[]
let anomalous_gauge_higgs4 =
[]
let anomalous_higgs =
[]
let anomaly_higgs =
[ (O H, G Ga, G Ga), Dim5_Scalar_Gauge2 1, G_HGaGa;
(O H, G Ga, G Z), Dim5_Scalar_Gauge2 1, G_HGaZ;
(O H, G Gl, G Gl), Dim5_Scalar_Gauge2 1, G_Hgg ]
let gravitino_coup n =
[ (O Grino, M (SL (-n)), M (L n)), GBG (1, Gravbar, POT, Psi), G_Grav;
(M (L (-n)), M (SL n), O Grino), GBG (1, Psibar, POT, Grav), G_Grav]
let gravitino_gauge =
[ (O Grino, G Ga, G Phino), GBG (1, Gravbar, V, Chi), G_Grav ]
let anomalous_higgs4 =
[]
let gauge_higgs =
standard_gauge_higgs
let gauge_higgs4 =
standard_gauge_higgs4
let higgs =
standard_higgs
let higgs4 =
standard_higgs4
let goldstone_vertices =
[ ((O Phi0, G Wm, G Wp), Scalar_Vector_Vector 1, I_G_ZWW);
((O Phip, G Ga, G Wm), Scalar_Vector_Vector 1, I_Q_W);
((O Phip, G Z, G Wm), Scalar_Vector_Vector 1, I_G_ZWW);
((O Phim, G Wp, G Ga), Scalar_Vector_Vector 1, I_Q_W);
((O Phim, G Wp, G Z), Scalar_Vector_Vector 1, I_G_ZWW) ]
let vertices3 =
(ThoList.flatmap electromagnetic_currents [1;2;3] @
ThoList.flatmap neutral_currents [1;2;3] @
ThoList.flatmap charged_currents [1;2;3] @
ThoList.flatmap gravitino_coup [1;2;3] @
gravitino_gauge @
yukawa @ triple_gauge @
gauge_higgs @ higgs @ anomaly_higgs
@ goldstone_vertices)
let vertices4 =
quartic_gauge @ gauge_higgs4 @ higgs4
let vertices () = (vertices3, vertices4, [])
(* For efficiency, make sure that [F.of_vertices vertices] is
evaluated only once. *)
let table = F.of_vertices (vertices ())
let fuse2 = F.fuse2 table
let fuse3 = F.fuse3 table
let fuse = F.fuse table
let max_degree () = 4
let flavor_of_string = function
| "e-" -> M (L 1) | "e+" -> M (L (-1))
| "mu-" -> M (L 2) | "mu+" -> M (L (-2))
| "tau-" -> M (L 3) | "tau+" -> M (L (-3))
| "se-" -> M (SL 1) | "se+" -> M (SL (-1))
| "smu-" -> M (SL 2) | "smu+" -> M (SL (-2))
| "stau-" -> M (SL 3) | "stau+" -> M (SL (-3))
| "nue" -> M (N 1) | "nuebar" -> M (N (-1))
| "numu" -> M (N 2) | "numubar" -> M (N (-2))
| "nutau" -> M (N 3) | "nutaubar" -> M (N (-3))
| "u" -> M (U 1) | "ubar" -> M (U (-1))
| "c" -> M (U 2) | "cbar" -> M (U (-2))
| "t" -> M (U 3) | "tbar" -> M (U (-3))
| "d" -> M (D 1) | "dbar" -> M (D (-1))
| "s" -> M (D 2) | "sbar" -> M (D (-2))
| "b" -> M (D 3) | "bbar" -> M (D (-3))
| "g" | "gl" -> G Gl
| "A" -> G Ga | "Z" | "Z0" -> G Z
| "W+" -> G Wp | "W-" -> G Wm
| "H" -> O H
| "GG" -> O Grino
| "phino" | "Phino" -> G Phino
| _ -> invalid_arg "Modellib_BSM.GravTest.flavor_of_string"
let flavor_to_string = function
| M f ->
begin match f with
| L 1 -> "e-" | L (-1) -> "e+"
| L 2 -> "mu-" | L (-2) -> "mu+"
| L 3 -> "tau-" | L (-3) -> "tau+"
| L _ -> invalid_arg
"Modellib_BSM.GravTest.flavor_to_string: invalid lepton"
| SL 1 -> "se-" | SL (-1) -> "se+"
| SL 2 -> "smu-" | SL (-2) -> "smu+"
| SL 3 -> "stau-" | SL (-3) -> "stau+"
| SL _ -> invalid_arg
"Modellib_BSM.GravTest.flavor_to_string: invalid slepton"
| N 1 -> "nue" | N (-1) -> "nuebar"
| N 2 -> "numu" | N (-2) -> "numubar"
| N 3 -> "nutau" | N (-3) -> "nutaubar"
| N _ -> invalid_arg
"Modellib_BSM.GravTest.flavor_to_string: invalid neutrino"
| U 1 -> "u" | U (-1) -> "ubar"
| U 2 -> "c" | U (-2) -> "cbar"
| U 3 -> "t" | U (-3) -> "tbar"
| U _ -> invalid_arg
"Modellib_BSM.SM.flavor_to_string: invalid up type quark"
| D 1 -> "d" | D (-1) -> "dbar"
| D 2 -> "s" | D (-2) -> "sbar"
| D 3 -> "b" | D (-3) -> "bbar"
| D _ -> invalid_arg
"Modellib_BSM.GravTest.flavor_to_string: invalid down type quark"
end
| G f ->
begin match f with
| Gl -> "g"
| Ga -> "A" | Z -> "Z"
| Wp -> "W+" | Wm -> "W-"
| Phino -> "phino"
end
| O f ->
begin match f with
| Phip -> "phi+" | Phim -> "phi-" | Phi0 -> "phi0"
| H -> "H" | Grino -> "GG"
end
let flavor_to_TeX = function
| M f ->
begin match f with
| L 1 -> "e^-" | L (-1) -> "e^+"
| L 2 -> "\\mu^-" | L (-2) -> "\\mu^+"
| L 3 -> "\\tau^-" | L (-3) -> "\\tau^+"
| L _ -> invalid_arg
"Modellib_BSM.GravTest.flavor_to_TeX: invalid lepton"
| SL 1 -> "\\tilde{e}^-" | SL (-1) -> "\\tilde{e}^+"
| SL 2 -> "\\tilde{\\mu}^-" | SL (-2) -> "\\tilde{\\mu}^+"
| SL 3 -> "\\tilde{\\tau}^-" | SL (-3) -> "\\tilde{\\tau}^+"
| SL _ -> invalid_arg
"Modellib_BSM.GravTest.flavor_to_TeX: invalid slepton"
| N 1 -> "\\nu_e" | N (-1) -> "\\bar{\\nu}_e"
| N 2 -> "\\nu_\\mu" | N (-2) -> "\\bar{\\nu}_\\mu"
| N 3 -> "\\nu_\\tau" | N (-3) -> "\\bar{\\nu}_\\tau"
| N _ -> invalid_arg
"Modellib_BSM.GravTest.flavor_to_TeX: invalid neutrino"
| U 1 -> "u" | U (-1) -> "\\bar{u}"
| U 2 -> "c" | U (-2) -> "\\bar{c}"
| U 3 -> "t" | U (-3) -> "\\bar{t}"
| U _ -> invalid_arg
"Modellib_BSM.SM.flavor_to_TeX: invalid up type quark"
| D 1 -> "d" | D (-1) -> "\\bar{d}"
| D 2 -> "s" | D (-2) -> "\\bar{s}"
| D 3 -> "b" | D (-3) -> "\\bar{b}"
| D _ -> invalid_arg
"Modellib_BSM.GravTest.flavor_to_TeX: invalid down type quark"
end
| G f ->
begin match f with
| Gl -> "g"
| Ga -> "\\gamma" | Z -> "Z"
| Wp -> "W^+" | Wm -> "W^-"
| Phino -> "\\tilde{\\phi}"
end
| O f ->
begin match f with
| Phip -> "\\phi^+" | Phim -> "\\phi^-" | Phi0 -> "\\phi^0"
| H -> "H" | Grino -> "\\tilde{G}"
end
let flavor_symbol = function
| M f ->
begin match f with
| L n when n > 0 -> "l" ^ string_of_int n
| L n -> "l" ^ string_of_int (abs n) ^ "b"
| SL n when n > 0 -> "sl" ^ string_of_int n
| SL n -> "sl" ^ string_of_int (abs n) ^ "b"
| N n when n > 0 -> "n" ^ string_of_int n
| N n -> "n" ^ string_of_int (abs n) ^ "b"
| U n when n > 0 -> "u" ^ string_of_int n
| U n -> "u" ^ string_of_int (abs n) ^ "b"
| D n when n > 0 -> "d" ^ string_of_int n
| D n -> "d" ^ string_of_int (abs n) ^ "b"
end
| G f ->
begin match f with
| Gl -> "gl"
| Ga -> "a" | Z -> "z"
| Wp -> "wp" | Wm -> "wm"
| Phino -> "phino"
end
| O f ->
begin match f with
| Phip -> "pp" | Phim -> "pm" | Phi0 -> "p0"
| H -> "h" | Grino -> "gv"
end
let pdg = function
| M f ->
begin match f with
| L n when n > 0 -> 9 + 2*n
| L n -> - 9 + 2*n
| SL n when n > 0 -> 39 + 2*n
| SL n -> - 39 + 2*n
| N n when n > 0 -> 10 + 2*n
| N n -> - 10 + 2*n
| U n when n > 0 -> 2*n
| U n -> 2*n
| D n when n > 0 -> - 1 + 2*n
| D n -> 1 + 2*n
end
| G f ->
begin match f with
| Gl -> 21
| Ga -> 22 | Z -> 23
| Wp -> 24 | Wm -> (-24)
| Phino -> 46
end
| O f ->
begin match f with
| Phip | Phim -> 27 | Phi0 -> 26
| H -> 25 | Grino -> 39
end
let mass_symbol f =
"mass(" ^ string_of_int (abs (pdg f)) ^ ")"
let width_symbol f =
"width(" ^ string_of_int (abs (pdg f)) ^ ")"
let constant_symbol = function
| Unit -> "unit" | Pi -> "PI"
| Alpha_QED -> "alpha" | E -> "e" | G_weak -> "g" | Vev -> "vev"
| Sin2thw -> "sin2thw" | Sinthw -> "sinthw" | Costhw -> "costhw"
| Q_lepton -> "qlep" | Q_up -> "qup" | Q_down -> "qdwn"
| G_NC_lepton -> "gnclep" | G_NC_neutrino -> "gncneu"
| G_NC_up -> "gncup" | G_NC_down -> "gncdwn"
| G_CC -> "gcc"
| G_CCQ (n1,n2) -> "gccq" ^ string_of_int n1 ^ string_of_int n2
| I_Q_W -> "iqw" | I_G_ZWW -> "igzww"
| G_WWWW -> "gw4" | G_ZZWW -> "gzzww"
| G_AZWW -> "gazww" | G_AAWW -> "gaaww"
| G_HWW -> "ghww" | G_HZZ -> "ghzz"
| G_HHWW -> "ghhww" | G_HHZZ -> "ghhzz"
| G_Htt -> "ghtt" | G_Hbb -> "ghbb"
| G_Htautau -> "ghtautau" | G_Hcc -> "ghcc"
| G_HGaZ -> "ghgaz" | G_HGaGa -> "ghgaga" | G_Hgg -> "ghgg"
| G_H3 -> "gh3" | G_H4 -> "gh4"
| G_strong -> "gs" | G_Grav -> "ggrav"
| Mass f -> "mass" ^ flavor_symbol f
| Width f -> "width" ^ flavor_symbol f
end
module Template (Flags : BSM_flags) =
struct
open Coupling
let default_width = ref Timelike
let use_fudged_width = ref false
let options = Options.create
[ "constant_width", Arg.Unit (fun () -> default_width := Constant),
"use constant width (also in t-channel)";
"fudged_width", Arg.Set use_fudged_width,
"use fudge factor for charge particle width";
"custom_width", Arg.String (fun f -> default_width := Custom f),
"use custom width";
"cancel_widths", Arg.Unit (fun () -> default_width := Vanishing),
"use vanishing width";
"cms_width", Arg.Unit (fun () -> default_width := Complex_Mass),
"use complex mass scheme";
"running_width", Arg.Unit (fun () -> default_width := Running),
"use running width"]
let caveats () = []
type matter_field = L of int | N of int | U of int | D of int
type gauge_boson = Ga | Wp | Wm | Z | Gl
type other = Phip | Phim | Phi0 | H
type flavor = M of matter_field | G of gauge_boson | O of other
let matter_field f = M f
let gauge_boson f = G f
let other f = O f
type field =
| Matter of matter_field
| Gauge of gauge_boson
| Other of other
let field = function
| M f -> Matter f
| G f -> Gauge f
| O f -> Other f
type gauge = unit
let gauge_symbol () =
failwith "Modellib_BSM.Template.gauge_symbol: internal error"
let family n = List.map matter_field [ L n; N n; U n; D n ]
let external_flavors () =
[ "1st Generation", ThoList.flatmap family [1; -1];
"2nd Generation", ThoList.flatmap family [2; -2];
"3rd Generation", ThoList.flatmap family [3; -3];
"Gauge Bosons", List.map gauge_boson [Ga; Z; Wp; Wm; Gl];
"Higgs", List.map other [H];
"Goldstone Bosons", List.map other [Phip; Phim; Phi0] ]
let flavors () = ThoList.flatmap snd (external_flavors ())
let spinor n =
if n >= 0 then
Spinor
else
ConjSpinor
let lorentz = function
| M f ->
begin match f with
| L n -> spinor n | N n -> spinor n
| U n -> spinor n | D n -> spinor n
end
| G f ->
begin match f with
| Ga | Gl -> Vector
| Wp | Wm | Z -> Massive_Vector
end
| O f -> Scalar
- let color = function
+ let color = function
| M (U n) -> Color.SUN (if n > 0 then 3 else -3)
| M (D n) -> Color.SUN (if n > 0 then 3 else -3)
| G Gl -> Color.AdjSUN 3
| _ -> Color.Singlet
let nc () = 3
let prop_spinor n =
if n >= 0 then
Prop_Spinor
else
Prop_ConjSpinor
let propagator = function
| M f ->
begin match f with
| L n -> prop_spinor n | N n -> prop_spinor n
| U n -> prop_spinor n | D n -> prop_spinor n
end
| G f ->
begin match f with
| Ga | Gl -> Prop_Feynman
| Wp | Wm | Z -> Prop_Unitarity
end
| O f ->
begin match f with
| Phip | Phim | Phi0 -> Only_Insertion
| H -> Prop_Scalar
end
(* Optionally, ask for the fudge factor treatment for the widths of
charged particles. Currently, this only applies to $W^\pm$ and top. *)
let width f =
if !use_fudged_width then
match f with
| G Wp | G Wm | M (U 3) | M (U (-3)) -> Fudged
| _ -> !default_width
else
!default_width
let goldstone = function
| G f ->
begin match f with
| Wp -> Some (O Phip, Coupling.Integer 1)
| Wm -> Some (O Phim, Coupling.Integer 1)
| Z -> Some (O Phi0, Coupling.Integer 1)
| _ -> None
end
| _ -> None
let conjugate = function
| M f ->
M (begin match f with
| L n -> L (-n) | N n -> N (-n)
| U n -> U (-n) | D n -> D (-n)
end)
| G f ->
G (begin match f with
| Gl -> Gl | Ga -> Ga | Z -> Z
| Wp -> Wm | Wm -> Wp
end)
| O f ->
O (begin match f with
| Phip -> Phim | Phim -> Phip | Phi0 -> Phi0
| H -> H
end)
let fermion = function
| M f ->
begin match f with
| L n -> if n > 0 then 1 else -1
| N n -> if n > 0 then 1 else -1
| U n -> if n > 0 then 1 else -1
| D n -> if n > 0 then 1 else -1
end
| G f ->
begin match f with
| Gl | Ga | Z | Wp | Wm -> 0
end
| O _ -> 0
module Ch = Charges.QQ
let ( // ) = Algebra.Small_Rational.make
let generation' = function
| 1 -> [ 1//1; 0//1; 0//1]
| 2 -> [ 0//1; 1//1; 0//1]
| 3 -> [ 0//1; 0//1; 1//1]
| -1 -> [-1//1; 0//1; 0//1]
| -2 -> [ 0//1; -1//1; 0//1]
| -3 -> [ 0//1; 0//1; -1//1]
| n -> invalid_arg ("Template.generation': " ^ string_of_int n)
let generation f =
match f with
| M (L n | N n | U n | D n) -> generation' n
| G _ | O _ -> [0//1; 0//1; 0//1]
let charge = function
| M f ->
begin match f with
| L n -> if n > 0 then -1//1 else 1//1
| N n -> 0//1
| U n -> if n > 0 then 2//3 else -2//3
| D n -> if n > 0 then -1//3 else 1//3
end
| G f ->
begin match f with
| Gl | Ga | Z -> 0//1
| Wp -> 1//1
| Wm -> -1//1
end
| O f ->
begin match f with
| H | Phi0 -> 0//1
| Phip -> 1//1
| Phim -> -1//1
end
let lepton = function
| M f ->
begin match f with
| L n | N n -> if n > 0 then 1//1 else -1//1
| U _ | D _ -> 0//1
end
| G _ | O _ -> 0//1
let baryon = function
| M f ->
begin match f with
| L _ | N _ -> 0//1
| U n | D n -> if n > 0 then 1//1 else -1//1
end
| G _ | O _ -> 0//1
let charges f =
[ charge f; lepton f; baryon f] @ generation f
type constant =
| Unit | Pi | Alpha_QED | Sin2thw
| Sinthw | Costhw | E | G_weak | Vev
| Q_lepton | Q_up | Q_down | G_CC
| G_NC_neutrino | G_NC_lepton | G_NC_up | G_NC_down
| I_Q_W | I_G_ZWW
| G_WWWW | G_ZZWW | G_AZWW | G_AAWW
| G_HWW | G_HHWW | G_HZZ | G_HHZZ
| G_Htt | G_Hbb | G_Hcc | G_Hmm | G_Htautau | G_H3 | G_H4
| G_HGaZ | G_HGaGa | G_Hgg
| Gs | I_Gs | G2
| Mass of flavor | Width of flavor
(* Two integer counters for the QCD and EW order of the couplings. *)
- type orders = int * int
+ type coupling_order = QCD | EW
+ let all_coupling_orders () = [QCD; EW]
+ let coupling_order_to_string = function
+ | QCD -> "QCD"
+ | EW -> "EW"
- let orders = function
- | _ -> (0,0)
+ let coupling_orders = function
+ | _ -> failwith "Modellib_BSM.Template.orders: not implemented yet!"
let input_parameters = []
let derived_parameters = []
let g_over_2_costh =
Quot (Neg (Atom G_weak), Prod [Integer 2; Atom Costhw])
let nc_coupling c t3 q =
(Real_Array c,
[Prod [g_over_2_costh; Diff (t3, Prod [Integer 2; q; Atom Sin2thw])];
Prod [g_over_2_costh; t3]])
let half = Quot (Integer 1, Integer 2)
let derived_parameter_arrays =
[ nc_coupling G_NC_neutrino half (Integer 0);
nc_coupling G_NC_lepton (Neg half) (Integer (-1));
nc_coupling G_NC_up half (Quot (Integer 2, Integer 3));
nc_coupling G_NC_down (Neg half) (Quot (Integer (-1), Integer 3)) ]
let parameters () =
{ input = input_parameters;
derived = derived_parameters;
derived_arrays = derived_parameter_arrays }
module F = Modeltools.Fusions (struct
type f = flavor
type c = constant
let compare = compare
let conjugate = conjugate
end)
let mgm ((m1, g, m2), fbf, c) = ((M m1, G g, M m2), fbf, c)
let electromagnetic_currents n =
List.map mgm
[ ((L (-n), Ga, L n), FBF (1, Psibar, V, Psi), Q_lepton);
((U (-n), Ga, U n), FBF (1, Psibar, V, Psi), Q_up);
((D (-n), Ga, D n), FBF (1, Psibar, V, Psi), Q_down) ]
let color_currents n =
List.map mgm
[ ((U (-n), Gl, U n), FBF ((-1), Psibar, V, Psi), Gs);
((D (-n), Gl, D n), FBF ((-1), Psibar, V, Psi), Gs) ]
let neutral_currents n =
List.map mgm
[ ((L (-n), Z, L n), FBF (1, Psibar, VA, Psi), G_NC_lepton);
((N (-n), Z, N n), FBF (1, Psibar, VA, Psi), G_NC_neutrino);
((U (-n), Z, U n), FBF (1, Psibar, VA, Psi), G_NC_up);
((D (-n), Z, D n), FBF (1, Psibar, VA, Psi), G_NC_down) ]
let charged_currents n =
List.map mgm
[ ((L (-n), Wm, N n), FBF (1, Psibar, VL, Psi), G_CC);
((N (-n), Wp, L n), FBF (1, Psibar, VL, Psi), G_CC);
((D (-n), Wm, U n), FBF (1, Psibar, VL, Psi), G_CC);
((U (-n), Wp, D n), FBF (1, Psibar, VL, Psi), G_CC) ]
let yukawa =
[ ((M (U (-3)), O H, M (U 3)), FBF (1, Psibar, S, Psi), G_Htt);
((M (D (-3)), O H, M (D 3)), FBF (1, Psibar, S, Psi), G_Hbb);
((M (U (-2)), O H, M (U 2)), FBF (1, Psibar, S, Psi), G_Hcc);
((M (L (-2)), O H, M (L 2)), FBF (1, Psibar, S, Psi), G_Hmm);
((M (L (-3)), O H, M (L 3)), FBF (1, Psibar, S, Psi), G_Htautau) ]
let tgc ((g1, g2, g3), t, c) = ((G g1, G g2, G g3), t, c)
let triple_gauge =
List.map tgc
[ ((Ga, Wm, Wp), Gauge_Gauge_Gauge 1, I_Q_W);
((Z, Wm, Wp), Gauge_Gauge_Gauge 1, I_G_ZWW);
((Gl, Gl, Gl), Gauge_Gauge_Gauge 1, I_Gs) ]
let qgc ((g1, g2, g3, g4), t, c) = ((G g1, G g2, G g3, G g4), t, c)
let gauge4 = Vector4 [(2, C_13_42); (-1, C_12_34); (-1, C_14_23)]
let minus_gauge4 = Vector4 [(-2, C_13_42); (1, C_12_34); (1, C_14_23)]
let quartic_gauge =
List.map qgc
[ (Wm, Wp, Wm, Wp), gauge4, G_WWWW;
(Wm, Z, Wp, Z), minus_gauge4, G_ZZWW;
(Wm, Z, Wp, Ga), minus_gauge4, G_AZWW;
(Wm, Ga, Wp, Ga), minus_gauge4, G_AAWW;
(Gl, Gl, Gl, Gl), gauge4, G2]
let gauge_higgs =
[ ((O H, G Wp, G Wm), Scalar_Vector_Vector 1, G_HWW);
((O H, G Z, G Z), Scalar_Vector_Vector 1, G_HZZ) ]
let gauge_higgs4 =
[ (O H, O H, G Wp, G Wm), Scalar2_Vector2 1, G_HHWW;
(O H, O H, G Z, G Z), Scalar2_Vector2 1, G_HHZZ ]
let higgs =
[ (O H, O H, O H), Scalar_Scalar_Scalar 1, G_H3 ]
let higgs4 =
[ (O H, O H, O H, O H), Scalar4 1, G_H4 ]
let anomaly_higgs =
[]
(* [ (O H, G Ga, G Ga), Dim5_Scalar_Gauge2 1, G_HGaGa;
(O H, G Ga, G Z), Dim5_Scalar_Gauge2 1, G_HGaZ;
(O H, G Gl, G Gl), Dim5_Scalar_Gauge2 1, G_Hgg] *)
let goldstone_vertices =
[ ((O Phi0, G Wm, G Wp), Scalar_Vector_Vector 1, I_G_ZWW);
((O Phip, G Ga, G Wm), Scalar_Vector_Vector 1, I_Q_W);
((O Phip, G Z, G Wm), Scalar_Vector_Vector 1, I_G_ZWW);
((O Phim, G Wp, G Ga), Scalar_Vector_Vector 1, I_Q_W);
((O Phim, G Wp, G Z), Scalar_Vector_Vector 1, I_G_ZWW) ]
let vertices3 =
(ThoList.flatmap electromagnetic_currents [1;2;3] @
ThoList.flatmap color_currents [1;2;3] @
ThoList.flatmap neutral_currents [1;2;3] @
ThoList.flatmap charged_currents [1;2;3] @
yukawa @ triple_gauge @ gauge_higgs @ higgs @
anomaly_higgs @ goldstone_vertices)
let vertices4 =
quartic_gauge @ gauge_higgs4 @ higgs4
let vertices () = (vertices3, vertices4, [])
let table = F.of_vertices (vertices ())
let fuse2 = F.fuse2 table
let fuse3 = F.fuse3 table
let fuse = F.fuse table
let max_degree () = 4
let flavor_of_string = function
| "e-" -> M (L 1) | "e+" -> M (L (-1))
| "mu-" -> M (L 2) | "mu+" -> M (L (-2))
| "tau-" -> M (L 3) | "tau+" -> M (L (-3))
| "nue" -> M (N 1) | "nuebar" -> M (N (-1))
| "numu" -> M (N 2) | "numubar" -> M (N (-2))
| "nutau" -> M (N 3) | "nutaubar" -> M (N (-3))
| "u" -> M (U 1) | "ubar" -> M (U (-1))
| "c" -> M (U 2) | "cbar" -> M (U (-2))
| "t" -> M (U 3) | "tbar" -> M (U (-3))
| "d" -> M (D 1) | "dbar" -> M (D (-1))
| "s" -> M (D 2) | "sbar" -> M (D (-2))
| "b" -> M (D 3) | "bbar" -> M (D (-3))
| "g" | "gl" -> G Gl
| "A" -> G Ga | "Z" | "Z0" -> G Z
| "W+" -> G Wp | "W-" -> G Wm
| "H" -> O H
| _ -> invalid_arg "Modellib_BSM.Template.flavor_of_string"
let flavor_to_string = function
| M f ->
begin match f with
| L 1 -> "e-" | L (-1) -> "e+"
| L 2 -> "mu-" | L (-2) -> "mu+"
| L 3 -> "tau-" | L (-3) -> "tau+"
| L _ -> invalid_arg
"Modellib_BSM.Template.flavor_to_string: invalid lepton"
| N 1 -> "nue" | N (-1) -> "nuebar"
| N 2 -> "numu" | N (-2) -> "numubar"
| N 3 -> "nutau" | N (-3) -> "nutaubar"
| N _ -> invalid_arg
"Modellib_BSM.Template.flavor_to_string: invalid neutrino"
| U 1 -> "u" | U (-1) -> "ubar"
| U 2 -> "c" | U (-2) -> "cbar"
| U 3 -> "t" | U (-3) -> "tbar"
| U _ -> invalid_arg
"Modellib_BSM.Template.flavor_to_string: invalid up type quark"
| D 1 -> "d" | D (-1) -> "dbar"
| D 2 -> "s" | D (-2) -> "sbar"
| D 3 -> "b" | D (-3) -> "bbar"
| D _ -> invalid_arg
"Modellib_BSM.Template.flavor_to_string: invalid down type quark"
end
| G f ->
begin match f with
| Gl -> "g"
| Ga -> "A" | Z -> "Z"
| Wp -> "W+" | Wm -> "W-"
end
| O f ->
begin match f with
| Phip -> "phi+" | Phim -> "phi-" | Phi0 -> "phi0"
| H -> "H"
end
let flavor_to_TeX = function
| M f ->
begin match f with
| L 1 -> "e^-" | L (-1) -> "e^+"
| L 2 -> "\\mu^-" | L (-2) -> "\\mu^+"
| L 3 -> "\\tau^-" | L (-3) -> "\\tau^+"
| L _ -> invalid_arg
"Modellib_BSM.Template.flavor_to_TeX: invalid lepton"
| N 1 -> "\\nu_e" | N (-1) -> "\\bar{\\nu}_e"
| N 2 -> "\\nu_\\mu" | N (-2) -> "\\bar{\\nu}_\\mu"
| N 3 -> "\\nu_\\tau" | N (-3) -> "\\bar{\\nu}_\\tau"
| N _ -> invalid_arg
"Modellib_BSM.Template.flavor_to_TeX: invalid neutrino"
| U 1 -> "u" | U (-1) -> "\\bar{u}"
| U 2 -> "c" | U (-2) -> "\\bar{c}"
| U 3 -> "t" | U (-3) -> "\\bar{t}"
| U _ -> invalid_arg
"Modellib_BSM.Template.flavor_to_TeX: invalid up type quark"
| D 1 -> "d" | D (-1) -> "\\bar{d}"
| D 2 -> "s" | D (-2) -> "\\bar{s}"
| D 3 -> "b" | D (-3) -> "\\bar{b}"
| D _ -> invalid_arg
"Modellib_BSM.Template.flavor_to_TeX: invalid down type quark"
end
| G f ->
begin match f with
| Gl -> "g"
| Ga -> "\\gamma" | Z -> "Z"
| Wp -> "W^+" | Wm -> "W^-"
end
| O f ->
begin match f with
| Phip -> "\\phi^+" | Phim -> "\\phi^-" | Phi0 -> "\\phi^0"
| H -> "H"
end
let flavor_symbol = function
| M f ->
begin match f with
| L n when n > 0 -> "l" ^ string_of_int n
| L n -> "l" ^ string_of_int (abs n) ^ "b"
| N n when n > 0 -> "n" ^ string_of_int n
| N n -> "n" ^ string_of_int (abs n) ^ "b"
| U n when n > 0 -> "u" ^ string_of_int n
| U n -> "u" ^ string_of_int (abs n) ^ "b"
| D n when n > 0 -> "d" ^ string_of_int n
| D n -> "d" ^ string_of_int (abs n) ^ "b"
end
| G f ->
begin match f with
| Gl -> "gl"
| Ga -> "a" | Z -> "z"
| Wp -> "wp" | Wm -> "wm"
end
| O f ->
begin match f with
| Phip -> "pp" | Phim -> "pm" | Phi0 -> "p0"
| H -> "h"
end
let pdg = function
| M f ->
begin match f with
| L n when n > 0 -> 9 + 2*n
| L n -> - 9 + 2*n
| N n when n > 0 -> 10 + 2*n
| N n -> - 10 + 2*n
| U n when n > 0 -> 2*n
| U n -> 2*n
| D n when n > 0 -> - 1 + 2*n
| D n -> 1 + 2*n
end
| G f ->
begin match f with
| Gl -> 21
| Ga -> 22 | Z -> 23
| Wp -> 24 | Wm -> (-24)
end
| O f ->
begin match f with
| Phip | Phim -> 27 | Phi0 -> 26
| H -> 25
end
let mass_symbol f =
"mass(" ^ string_of_int (abs (pdg f)) ^ ")"
let width_symbol f =
"width(" ^ string_of_int (abs (pdg f)) ^ ")"
let constant_symbol = function
| Unit -> "unit" | Pi -> "PI"
| Alpha_QED -> "alpha" | E -> "e" | G_weak -> "g" | Vev -> "vev"
| Sin2thw -> "sin2thw" | Sinthw -> "sinthw" | Costhw -> "costhw"
| Q_lepton -> "qlep" | Q_up -> "qup" | Q_down -> "qdwn"
| G_NC_lepton -> "gnclep" | G_NC_neutrino -> "gncneu"
| G_NC_up -> "gncup" | G_NC_down -> "gncdwn"
| G_CC -> "gcc"
| I_Q_W -> "iqw" | I_G_ZWW -> "igzww"
| G_WWWW -> "gw4" | G_ZZWW -> "gzzww"
| G_AZWW -> "gazww" | G_AAWW -> "gaaww"
| G_HWW -> "ghww" | G_HZZ -> "ghzz"
| G_HHWW -> "ghhww" | G_HHZZ -> "ghhzz"
| G_Htt -> "ghtt" | G_Hbb -> "ghbb"
| G_Htautau -> "ghtautau" | G_Hcc -> "ghcc" | G_Hmm -> "ghmm"
| G_HGaZ -> "ghgaz" | G_HGaGa -> "ghgaga" | G_Hgg -> "ghgg"
| G_H3 -> "gh3" | G_H4 -> "gh4"
| Gs -> "gs" | I_Gs -> "igs" | G2 -> "gs**2"
| Mass f -> "mass" ^ flavor_symbol f
| Width f -> "width" ^ flavor_symbol f
end
module HSExt (Flags : BSM_flags) =
struct
open Coupling
let default_width = ref Timelike
let use_fudged_width = ref false
let options = Options.create
[ "constant_width", Arg.Unit (fun () -> default_width := Constant),
"use constant width (also in t-channel)";
"fudged_width", Arg.Set use_fudged_width,
"use fudge factor for charge particle width";
"custom_width", Arg.String (fun f -> default_width := Custom f),
"use custom width";
"cancel_widths", Arg.Unit (fun () -> default_width := Vanishing),
"use vanishing width";
"cms_width", Arg.Unit (fun () -> default_width := Complex_Mass),
"use complex mass scheme";
"running_width", Arg.Unit (fun () -> default_width := Running),
"use running width"]
let caveats () = []
type matter_field = L of int | N of int | U of int | D of int
type gauge_boson = Ga | Wp | Wm | Z | Gl
type other = Phip | Phim | Phi0 | H | S
type flavor = M of matter_field | G of gauge_boson | O of other
let matter_field f = M f
let gauge_boson f = G f
let other f = O f
type field =
| Matter of matter_field
| Gauge of gauge_boson
| Other of other
let field = function
| M f -> Matter f
| G f -> Gauge f
| O f -> Other f
type gauge = unit
let gauge_symbol () =
failwith "Modellib_BSM.HSExt.gauge_symbol: internal error"
let family n = List.map matter_field [ L n; N n; U n; D n ]
let external_flavors () =
[ "1st Generation", ThoList.flatmap family [1; -1];
"2nd Generation", ThoList.flatmap family [2; -2];
"3rd Generation", ThoList.flatmap family [3; -3];
"Gauge Bosons", List.map gauge_boson [Ga; Z; Wp; Wm; Gl];
"Higgs", List.map other [H; S];
"Goldstone Bosons", List.map other [Phip; Phim; Phi0] ]
let flavors () = ThoList.flatmap snd (external_flavors ())
let spinor n =
if n >= 0 then
Spinor
else
ConjSpinor
let lorentz = function
| M f ->
begin match f with
| L n -> spinor n | N n -> spinor n
| U n -> spinor n | D n -> spinor n
end
| G f ->
begin match f with
| Ga | Gl -> Vector
| Wp | Wm | Z -> Massive_Vector
end
| O f -> Scalar
- let color = function
+ let color = function
| M (U n) -> Color.SUN (if n > 0 then 3 else -3)
| M (D n) -> Color.SUN (if n > 0 then 3 else -3)
| G Gl -> Color.AdjSUN 3
| _ -> Color.Singlet
let nc () = 3
let prop_spinor n =
if n >= 0 then
Prop_Spinor
else
Prop_ConjSpinor
let propagator = function
| M f ->
begin match f with
| L n -> prop_spinor n | N n -> prop_spinor n
| U n -> prop_spinor n | D n -> prop_spinor n
end
| G f ->
begin match f with
| Ga | Gl -> Prop_Feynman
| Wp | Wm | Z -> Prop_Unitarity
end
| O f ->
begin match f with
| Phip | Phim | Phi0 -> Only_Insertion
| H | S -> Prop_Scalar
end
(* Optionally, ask for the fudge factor treatment for the widths of
charged particles. Currently, this only applies to $W^\pm$ and top. *)
let width f =
if !use_fudged_width then
match f with
| G Wp | G Wm | M (U 3) | M (U (-3)) -> Fudged
| _ -> !default_width
else
!default_width
let goldstone = function
| G f ->
begin match f with
| Wp -> Some (O Phip, Coupling.Integer 1)
| Wm -> Some (O Phim, Coupling.Integer 1)
| Z -> Some (O Phi0, Coupling.Integer 1)
| _ -> None
end
| _ -> None
let conjugate = function
| M f ->
M (begin match f with
| L n -> L (-n) | N n -> N (-n)
| U n -> U (-n) | D n -> D (-n)
end)
| G f ->
G (begin match f with
| Gl -> Gl | Ga -> Ga | Z -> Z
| Wp -> Wm | Wm -> Wp
end)
| O f ->
O (begin match f with
| Phip -> Phim | Phim -> Phip | Phi0 -> Phi0
| H -> H | S -> S
end)
let fermion = function
| M f ->
begin match f with
| L n -> if n > 0 then 1 else -1
| N n -> if n > 0 then 1 else -1
| U n -> if n > 0 then 1 else -1
| D n -> if n > 0 then 1 else -1
end
| G f ->
begin match f with
| Gl | Ga | Z | Wp | Wm -> 0
end
| O _ -> 0
module Ch = Charges.QQ
let ( // ) = Algebra.Small_Rational.make
let generation' = function
| 1 -> [ 1//1; 0//1; 0//1]
| 2 -> [ 0//1; 1//1; 0//1]
| 3 -> [ 0//1; 0//1; 1//1]
| -1 -> [-1//1; 0//1; 0//1]
| -2 -> [ 0//1; -1//1; 0//1]
| -3 -> [ 0//1; 0//1; -1//1]
| n -> invalid_arg ("HSExt.generation': " ^ string_of_int n)
let generation f =
match f with
| M (L n | N n | U n | D n) -> generation' n
| G _ | O _ -> [0//1; 0//1; 0//1]
let charge = function
| M f ->
begin match f with
| L n -> if n > 0 then -1//1 else 1//1
| N n -> 0//1
| U n -> if n > 0 then 2//3 else -2//3
| D n -> if n > 0 then -1//3 else 1//3
end
| G f ->
begin match f with
| Gl | Ga | Z -> 0//1
| Wp -> 1//1
| Wm -> -1//1
end
| O f ->
begin match f with
| H | Phi0 | S -> 0//1
| Phip -> 1//1
| Phim -> -1//1
end
let lepton = function
| M f ->
begin match f with
| L n | N n -> if n > 0 then 1//1 else -1//1
| U _ | D _ -> 0//1
end
| G _ | O _ -> 0//1
let baryon = function
| M f ->
begin match f with
| L _ | N _ -> 0//1
| U n | D n -> if n > 0 then 1//1 else -1//1
end
| G _ | O _ -> 0//1
let charges f =
[ charge f; lepton f; baryon f] @ generation f
type constant =
| Unit | Pi | Alpha_QED | Sin2thw
| Sinthw | Costhw | E | G_weak | Vev
| Q_lepton | Q_up | Q_down | G_CC
| G_NC_neutrino | G_NC_lepton | G_NC_up | G_NC_down
| I_Q_W | I_G_ZWW
| G_WWWW | G_ZZWW | G_AZWW | G_AAWW
| G_HWW | G_HHWW | G_HZZ | G_HHZZ
| G_SWW | G_SSWW | G_SZZ | G_SSZZ | G_HSWW | G_HSZZ
| G_Htt | G_Hbb | G_Hcc | G_Hmm | G_Htautau | G_H3 | G_H4_1
| G_H4_2 | G_H4_3 | G_H4_4 | G_H4_5
| G_Stt | G_Sbb | G_Scc | G_Smm | G_Stautau | G_HSS | G_HHS
| G_HGaZ | G_HGaGa | G_Hgg | G_SGaZ | G_SGaGa | G_Sgg
| Gs | I_Gs | G2
| Mass of flavor | Width of flavor
(* Two integer counters for the QCD and EW order of the couplings. *)
- type orders = int * int
+ type coupling_order = QCD | EW
+ let all_coupling_orders () = [QCD; EW]
+ let coupling_order_to_string = function
+ | QCD -> "QCD"
+ | EW -> "EW"
- let orders = function
- | _ -> (0,0)
+ let coupling_orders = function
+ | _ -> failwith "Modellib_BSM.HSExt.orders: not implemented yet!"
let input_parameters = []
let derived_parameters = []
let g_over_2_costh =
Quot (Neg (Atom G_weak), Prod [Integer 2; Atom Costhw])
let nc_coupling c t3 q =
(Real_Array c,
[Prod [g_over_2_costh; Diff (t3, Prod [Integer 2; q; Atom Sin2thw])];
Prod [g_over_2_costh; t3]])
let half = Quot (Integer 1, Integer 2)
let derived_parameter_arrays =
[ nc_coupling G_NC_neutrino half (Integer 0);
nc_coupling G_NC_lepton (Neg half) (Integer (-1));
nc_coupling G_NC_up half (Quot (Integer 2, Integer 3));
nc_coupling G_NC_down (Neg half) (Quot (Integer (-1), Integer 3)) ]
let parameters () =
{ input = input_parameters;
derived = derived_parameters;
derived_arrays = derived_parameter_arrays }
module F = Modeltools.Fusions (struct
type f = flavor
type c = constant
let compare = compare
let conjugate = conjugate
end)
let mgm ((m1, g, m2), fbf, c) = ((M m1, G g, M m2), fbf, c)
let electromagnetic_currents n =
List.map mgm
[ ((L (-n), Ga, L n), FBF (1, Psibar, V, Psi), Q_lepton);
((U (-n), Ga, U n), FBF (1, Psibar, V, Psi), Q_up);
((D (-n), Ga, D n), FBF (1, Psibar, V, Psi), Q_down) ]
let color_currents n =
List.map mgm
[ ((U (-n), Gl, U n), FBF ((-1), Psibar, V, Psi), Gs);
((D (-n), Gl, D n), FBF ((-1), Psibar, V, Psi), Gs) ]
let neutral_currents n =
List.map mgm
[ ((L (-n), Z, L n), FBF (1, Psibar, VA, Psi), G_NC_lepton);
((N (-n), Z, N n), FBF (1, Psibar, VA, Psi), G_NC_neutrino);
((U (-n), Z, U n), FBF (1, Psibar, VA, Psi), G_NC_up);
((D (-n), Z, D n), FBF (1, Psibar, VA, Psi), G_NC_down) ]
let charged_currents n =
List.map mgm
[ ((L (-n), Wm, N n), FBF (1, Psibar, VL, Psi), G_CC);
((N (-n), Wp, L n), FBF (1, Psibar, VL, Psi), G_CC);
((D (-n), Wm, U n), FBF (1, Psibar, VL, Psi), G_CC);
((U (-n), Wp, D n), FBF (1, Psibar, VL, Psi), G_CC) ]
let yukawa =
[ ((M (U (-3)), O H, M (U 3)), FBF (1, Psibar, Coupling.S, Psi), G_Htt);
((M (D (-3)), O H, M (D 3)), FBF (1, Psibar, Coupling.S, Psi), G_Hbb);
((M (U (-2)), O H, M (U 2)), FBF (1, Psibar, Coupling.S, Psi), G_Hcc);
((M (L (-2)), O H, M (L 2)), FBF (1, Psibar, Coupling.S, Psi), G_Hmm);
((M (L (-3)), O H, M (L 3)),
FBF (1, Psibar, Coupling.S, Psi), G_Htautau);
((M (U (-3)), O S, M (U 3)), FBF (1, Psibar, Coupling.S, Psi), G_Stt);
((M (D (-3)), O S, M (D 3)), FBF (1, Psibar, Coupling.S, Psi), G_Sbb);
((M (U (-2)), O S, M (U 2)), FBF (1, Psibar, Coupling.S, Psi), G_Scc);
((M (L (-2)), O S, M (L 2)), FBF (1, Psibar, Coupling.S, Psi), G_Smm);
((M (L (-3)), O S, M (L 3)),
FBF (1, Psibar, Coupling.S, Psi), G_Stautau) ]
let tgc ((g1, g2, g3), t, c) = ((G g1, G g2, G g3), t, c)
let triple_gauge =
List.map tgc
[ ((Ga, Wm, Wp), Gauge_Gauge_Gauge 1, I_Q_W);
((Z, Wm, Wp), Gauge_Gauge_Gauge 1, I_G_ZWW);
((Gl, Gl, Gl), Gauge_Gauge_Gauge 1, I_Gs) ]
let qgc ((g1, g2, g3, g4), t, c) = ((G g1, G g2, G g3, G g4), t, c)
let gauge4 = Vector4 [(2, C_13_42); (-1, C_12_34); (-1, C_14_23)]
let minus_gauge4 = Vector4 [(-2, C_13_42); (1, C_12_34); (1, C_14_23)]
let quartic_gauge =
List.map qgc
[ (Wm, Wp, Wm, Wp), gauge4, G_WWWW;
(Wm, Z, Wp, Z), minus_gauge4, G_ZZWW;
(Wm, Z, Wp, Ga), minus_gauge4, G_AZWW;
(Wm, Ga, Wp, Ga), minus_gauge4, G_AAWW;
(Gl, Gl, Gl, Gl), gauge4, G2]
let gauge_higgs =
[ ((O H, G Wp, G Wm), Scalar_Vector_Vector 1, G_HWW);
((O H, G Z, G Z), Scalar_Vector_Vector 1, G_HZZ);
((O S, G Wp, G Wm), Scalar_Vector_Vector 1, G_SWW);
((O S, G Z, G Z), Scalar_Vector_Vector 1, G_SZZ) ]
let gauge_higgs4 =
[ (O H, O H, G Wp, G Wm), Scalar2_Vector2 1, G_HHWW;
(O H, O H, G Z, G Z), Scalar2_Vector2 1, G_HHZZ;
(O H, O S, G Wp, G Wm), Scalar2_Vector2 1, G_HSWW;
(O H, O S, G Z, G Z), Scalar2_Vector2 1, G_HSZZ;
(O S, O S, G Wp, G Wm), Scalar2_Vector2 1, G_SSWW;
(O S, O S, G Z, G Z), Scalar2_Vector2 1, G_SSZZ ]
let higgs =
[ (O H, O H, O H), Scalar_Scalar_Scalar 1, G_H3;
(O S, O H, O H), Scalar_Scalar_Scalar 1, G_HHS;
(O S, O S, O H), Scalar_Scalar_Scalar 1, G_HSS ]
let higgs4 =
[ (O H, O H, O H, O H), Scalar4 1, G_H4_1;
(O H, O H, O H, O S), Scalar4 1, G_H4_2;
(O H, O H, O S, O S), Scalar4 1, G_H4_3;
(O H, O S, O S, O S), Scalar4 1, G_H4_4;
(O S, O S, O S, O S), Scalar4 1, G_H4_5 ]
let anomaly_higgs =
[ (O H, G Ga, G Ga), Dim5_Scalar_Gauge2 1, G_HGaGa;
(O H, G Ga, G Z), Dim5_Scalar_Gauge2 1, G_HGaZ;
(O H, G Gl, G Gl), Dim5_Scalar_Gauge2 1, G_Hgg;
(O S, G Ga, G Ga), Dim5_Scalar_Gauge2 1, G_SGaGa;
(O S, G Ga, G Z), Dim5_Scalar_Gauge2 1, G_SGaZ;
(O S, G Gl, G Gl), Dim5_Scalar_Gauge2 1, G_Sgg ]
let goldstone_vertices =
[ ((O Phi0, G Wm, G Wp), Scalar_Vector_Vector 1, I_G_ZWW);
((O Phip, G Ga, G Wm), Scalar_Vector_Vector 1, I_Q_W);
((O Phip, G Z, G Wm), Scalar_Vector_Vector 1, I_G_ZWW);
((O Phim, G Wp, G Ga), Scalar_Vector_Vector 1, I_Q_W);
((O Phim, G Wp, G Z), Scalar_Vector_Vector 1, I_G_ZWW) ]
let vertices3 =
(ThoList.flatmap electromagnetic_currents [1;2;3] @
ThoList.flatmap color_currents [1;2;3] @
ThoList.flatmap neutral_currents [1;2;3] @
ThoList.flatmap charged_currents [1;2;3] @
yukawa @ triple_gauge @ gauge_higgs @ higgs @
anomaly_higgs @ goldstone_vertices)
let vertices4 =
quartic_gauge @ gauge_higgs4 @ higgs4
let vertices () = (vertices3, vertices4, [])
let table = F.of_vertices (vertices ())
let fuse2 = F.fuse2 table
let fuse3 = F.fuse3 table
let fuse = F.fuse table
let max_degree () = 4
let flavor_of_string = function
| "e-" -> M (L 1) | "e+" -> M (L (-1))
| "mu-" -> M (L 2) | "mu+" -> M (L (-2))
| "tau-" -> M (L 3) | "tau+" -> M (L (-3))
| "nue" -> M (N 1) | "nuebar" -> M (N (-1))
| "numu" -> M (N 2) | "numubar" -> M (N (-2))
| "nutau" -> M (N 3) | "nutaubar" -> M (N (-3))
| "u" -> M (U 1) | "ubar" -> M (U (-1))
| "c" -> M (U 2) | "cbar" -> M (U (-2))
| "t" -> M (U 3) | "tbar" -> M (U (-3))
| "d" -> M (D 1) | "dbar" -> M (D (-1))
| "s" -> M (D 2) | "sbar" -> M (D (-2))
| "b" -> M (D 3) | "bbar" -> M (D (-3))
| "g" | "gl" -> G Gl
| "A" -> G Ga | "Z" | "Z0" -> G Z
| "W+" -> G Wp | "W-" -> G Wm
| "H" -> O H
| "S" -> O S
| _ -> invalid_arg "Modellib_BSM.HSExt.flavor_of_string"
let flavor_to_string = function
| M f ->
begin match f with
| L 1 -> "e-" | L (-1) -> "e+"
| L 2 -> "mu-" | L (-2) -> "mu+"
| L 3 -> "tau-" | L (-3) -> "tau+"
| L _ -> invalid_arg
"Modellib_BSM.HSExt.flavor_to_string: invalid lepton"
| N 1 -> "nue" | N (-1) -> "nuebar"
| N 2 -> "numu" | N (-2) -> "numubar"
| N 3 -> "nutau" | N (-3) -> "nutaubar"
| N _ -> invalid_arg
"Modellib_BSM.HSExt.flavor_to_string: invalid neutrino"
| U 1 -> "u" | U (-1) -> "ubar"
| U 2 -> "c" | U (-2) -> "cbar"
| U 3 -> "t" | U (-3) -> "tbar"
| U _ -> invalid_arg
"Modellib_BSM.HSExt.flavor_to_string: invalid up type quark"
| D 1 -> "d" | D (-1) -> "dbar"
| D 2 -> "s" | D (-2) -> "sbar"
| D 3 -> "b" | D (-3) -> "bbar"
| D _ -> invalid_arg
"Modellib_BSM.HSExt.flavor_to_string: invalid down type quark"
end
| G f ->
begin match f with
| Gl -> "g"
| Ga -> "A" | Z -> "Z"
| Wp -> "W+" | Wm -> "W-"
end
| O f ->
begin match f with
| Phip -> "phi+" | Phim -> "phi-" | Phi0 -> "phi0"
| H -> "H" | S -> "S"
end
let flavor_to_TeX = function
| M f ->
begin match f with
| L 1 -> "e^-" | L (-1) -> "e^+"
| L 2 -> "\\mu^-" | L (-2) -> "\\mu^+"
| L 3 -> "\\tau^-" | L (-3) -> "\\tau^+"
| L _ -> invalid_arg
"Modellib_BSM.HSExt.flavor_to_TeX: invalid lepton"
| N 1 -> "\\nu_e" | N (-1) -> "\\bar{\\nu}_e"
| N 2 -> "\\nu_\\mu" | N (-2) -> "\\bar{\\nu}_\\mu"
| N 3 -> "\\nu_\\tau" | N (-3) -> "\\bar{\\nu}_\\tau"
| N _ -> invalid_arg
"Modellib_BSM.HSExt.flavor_to_TeX: invalid neutrino"
| U 1 -> "u" | U (-1) -> "\\bar{u}"
| U 2 -> "c" | U (-2) -> "\\bar{c}"
| U 3 -> "t" | U (-3) -> "\\bar{t}"
| U _ -> invalid_arg
"Modellib_BSM.HSExt.flavor_to_TeX: invalid up type quark"
| D 1 -> "d" | D (-1) -> "\\bar{d}"
| D 2 -> "s" | D (-2) -> "\\bar{s}"
| D 3 -> "b" | D (-3) -> "\\bar{b}"
| D _ -> invalid_arg
"Modellib_BSM.HSExt.flavor_to_TeX: invalid down type quark"
end
| G f ->
begin match f with
| Gl -> "g"
| Ga -> "\\gamma" | Z -> "Z"
| Wp -> "W^+" | Wm -> "W^-"
end
| O f ->
begin match f with
| Phip -> "\\phi^+" | Phim -> "\\phi^-" | Phi0 -> "\\phi^0"
| H -> "H" | S -> "S"
end
let flavor_symbol = function
| M f ->
begin match f with
| L n when n > 0 -> "l" ^ string_of_int n
| L n -> "l" ^ string_of_int (abs n) ^ "b"
| N n when n > 0 -> "n" ^ string_of_int n
| N n -> "n" ^ string_of_int (abs n) ^ "b"
| U n when n > 0 -> "u" ^ string_of_int n
| U n -> "u" ^ string_of_int (abs n) ^ "b"
| D n when n > 0 -> "d" ^ string_of_int n
| D n -> "d" ^ string_of_int (abs n) ^ "b"
end
| G f ->
begin match f with
| Gl -> "gl"
| Ga -> "a" | Z -> "z"
| Wp -> "wp" | Wm -> "wm"
end
| O f ->
begin match f with
| Phip -> "pp" | Phim -> "pm" | Phi0 -> "p0"
| H -> "h" | S -> "s"
end
let pdg = function
| M f ->
begin match f with
| L n when n > 0 -> 9 + 2*n
| L n -> - 9 + 2*n
| N n when n > 0 -> 10 + 2*n
| N n -> - 10 + 2*n
| U n when n > 0 -> 2*n
| U n -> 2*n
| D n when n > 0 -> - 1 + 2*n
| D n -> 1 + 2*n
end
| G f ->
begin match f with
| Gl -> 21
| Ga -> 22 | Z -> 23
| Wp -> 24 | Wm -> (-24)
end
| O f ->
begin match f with
| Phip | Phim -> 27 | Phi0 -> 26
| H -> 25 | S -> 35
end
let mass_symbol f =
"mass(" ^ string_of_int (abs (pdg f)) ^ ")"
let width_symbol f =
"width(" ^ string_of_int (abs (pdg f)) ^ ")"
let constant_symbol = function
| Unit -> "unit" | Pi -> "PI"
| Alpha_QED -> "alpha" | E -> "e" | G_weak -> "g" | Vev -> "vev"
| Sin2thw -> "sin2thw" | Sinthw -> "sinthw" | Costhw -> "costhw"
| Q_lepton -> "qlep" | Q_up -> "qup" | Q_down -> "qdwn"
| G_NC_lepton -> "gnclep" | G_NC_neutrino -> "gncneu"
| G_NC_up -> "gncup" | G_NC_down -> "gncdwn"
| G_CC -> "gcc"
| I_Q_W -> "iqw" | I_G_ZWW -> "igzww"
| G_WWWW -> "gw4" | G_ZZWW -> "gzzww"
| G_AZWW -> "gazww" | G_AAWW -> "gaaww"
| G_HWW -> "ghww" | G_HZZ -> "ghzz"
| G_HHWW -> "ghhww" | G_HHZZ -> "ghhzz"
| G_SWW -> "gsww" | G_SZZ -> "gszz"
| G_SSWW -> "gssww" | G_SSZZ -> "gsszz"
| G_HSWW -> "ghsww" | G_HSZZ -> "ghszz"
| G_Htt -> "ghtt" | G_Hbb -> "ghbb"
| G_Htautau -> "ghtautau" | G_Hcc -> "ghcc" | G_Hmm -> "ghmm"
| G_Stt -> "gstt" | G_Sbb -> "gsbb"
| G_Stautau -> "gstautau" | G_Scc -> "gscc" | G_Smm -> "gsmm"
| G_HGaZ -> "ghgaz" | G_HGaGa -> "ghgaga" | G_Hgg -> "ghgg"
| G_SGaZ -> "gsgaz" | G_SGaGa -> "gsgaga" | G_Sgg -> "gsgg"
| G_H3 -> "gh3" | G_H4_1 -> "gh4_1" | G_H4_2 -> "gh4_2"
| G_H4_3 -> "gh4_3" | G_H4_4 -> "gh4_4" | G_H4_5 -> "gh4_5"
| G_HHS -> "ghhs" | G_HSS -> "ghss"
| Gs -> "gs" | I_Gs -> "igs" | G2 -> "gs**2"
| Mass f -> "mass" ^ flavor_symbol f
| Width f -> "width" ^ flavor_symbol f
end
(* \thocwmodulesection{Three-Site Higgsless Model} *)
module type Threeshl_options =
sig
val include_ckm: bool
val include_hf: bool
val diet: bool
end
module Threeshl_no_ckm: Threeshl_options =
struct
let include_ckm = false
let include_hf = true
let diet = false
end
module Threeshl_ckm: Threeshl_options =
struct
let include_ckm = true
let include_hf = true
let diet = false
end
module Threeshl_no_ckm_no_hf: Threeshl_options =
struct
let include_ckm = false
let include_hf = false
let diet = false
end
module Threeshl_ckm_no_hf: Threeshl_options =
struct
let include_ckm = true
let include_hf = false
let diet = false
end
module Threeshl_diet_no_hf: Threeshl_options =
struct
let include_ckm = false
let include_hf = false
let diet = true
end
module Threeshl_diet: Threeshl_options =
struct
let include_ckm = false
let include_hf = true
let diet = true
end
(* We use one generic implementation of the model and implement different features via option
modules given to a functor *)
module Threeshl (Module_options: Threeshl_options) =
struct
open Coupling
let modname = "Modellib_BSM.Threeshl"
(* Shamelessly stolen from Modellib.SM3, but with no support for fudged width yet *)
let default_width = ref Timelike
(* If this flag is set true, all gauge bosons are assumed to be massless and are assigned
feynman gauge propagators. This in conjunction with the unbroken three site model is intended for
checking gauge invariance via the ward identites. *)
let all_feynman = ref false
let options = Options.create [
"constant_width", Arg.Unit (fun _ -> default_width := Constant),
"use constant width (also in t-channel)";
"custom_width", Arg.String (fun x -> default_width := Custom x),
"use custom width";
"cancel_widths", Arg.Unit (fun _ -> default_width := Vanishing),
"use vanishing width";
"all_feynman", Arg.Unit (fun _ -> all_feynman := true),
"assign feynman gauge propagators to all gauge bosons\n"
^ "\t(for checking the ward identities); use only if you *really* know\n"
^ "\twhat you are doing"]
let caveats () = []
(* The quantum numbers that are carried by the particles. \verb$csign$ is \emph{not} the charge
carried by the particle, but differentiates between particles (\verb$Pos$) and antiparticles
(\verb$Neg$) *)
type kkmode = Light | Heavy
type generation = Gen0 | Gen1 | Gen2
type csign = Pos | Neg
type isospin = Iso_up | Iso_down
(* Necessary to represent the indices of the couplings defined in FORTRAN *)
type kk2 = Light2 | Heavy2 | Light_Heavy
(* Map the different types to the constants used in the FORTRAN module *)
let fspec_of_kkmode = function Light -> "l_mode" | Heavy -> "h_mode"
let fspec_of_kk2 = function
Light2 -> "l_mode" | Heavy2 -> "h_mode" | Light_Heavy -> "lh_mode"
let fspec_of_gen = function Gen0 -> "gen_0" | Gen1 -> "gen_1" | Gen2 -> "gen_2"
let fspec_of_iso = function Iso_up -> "iso_up" | Iso_down -> "iso_down"
(* Covert the ``charge sign'' into a numeric sign (used e.g. in the determination of the MCID
codes) *)
let int_of_csign = function Pos -> 1 | Neg -> -1
(* Convert the generation into an integer (dito) *)
let int_of_gen = function Gen0 -> 1 | Gen1 -> 2 | Gen2 -> 3
(* The type \verb$flavor$ is implemented as a variant. Fermions are implemented as a variant
differentating between leptons and quarks (seemed the most natural way as this is also the way
in which the FORTRAN code is structured). Bosons are implemented as a variant the
differentiates between $W$, $Z$ and $A$. All other quantum numbers that are required for
identifying the particles are carried by the variant constructors. *)
type fermion =
| Lepton of (kkmode * csign * generation * isospin)
| Quark of (kkmode * csign * generation * isospin)
type boson =
| W of (kkmode * csign)
| Z of kkmode
| A
| G
type flavor = Fermion of fermion | Boson of boson
(* Helpers to construct particles from quantum numbers *)
let lepton kk cs gen iso = Lepton (kk, cs, gen, iso)
let quark kk cs gen iso = Quark (kk, cs, gen, iso)
let w kk cs = W (kk, cs)
let z kk = Z kk
let flavor_of_f x = Fermion x
let flavor_of_b x = Boson x
(* Map a list of functions to the list (partially) applied to a value *)
let revmap funs v = List.map (fun x -> x v) funs
(* The same for a list of values; the result is flattened *)
let revmap2 funs vals = ThoList.flatmap (revmap funs) vals
(* Functions to loop the constructors over quantum numbers for list creation purposes *)
let loop_kk flist = revmap2 flist [Light; Heavy]
let loop_cs flist = revmap2 flist [Pos; Neg]
let loop_gen flist = revmap2 flist [Gen0; Gen1; Gen2]
let loop_iso flist = revmap2 flist [Iso_up; Iso_down]
let loop_kk2 flist = revmap2 flist [Light2; Heavy2; Light_Heavy]
(* Conditional looping over kk modes depending on whether to include heavy fermions *)
let cloop_kk flist = match Module_options.include_hf with
| true -> loop_kk flist
| false -> revmap flist Light
let cloop_kk2 flist = match Module_options.include_hf with
| true -> loop_kk2 flist
| false -> revmap flist Light2
(* Having defined the necessary helpers, the magic of currying makes building lists of
particles as easy as nesting the loop functions in the correct order... *)
let all_leptons = loop_iso (loop_gen (loop_cs (cloop_kk [lepton] )))
let all_quarks = loop_iso( loop_gen (loop_cs (cloop_kk [quark] )))
let all_bosons = (loop_cs (loop_kk [w] )) @ [Z Light; Z Heavy; A; G]
(* Converts a flavor spec to the BCD identifier defined in the FORTRAN module. Splitting the
function into two parts \verb$prefix$ and \verb$rump$ removes a lot of redundancy. *)
let bcdi_of_flavor =
let prefix = function
| Fermion (Lepton (Heavy, _, _, _)) | Fermion (Quark (Heavy, _, _, _))
| Boson (W (Heavy, _)) | Boson (Z Heavy) -> "h"
| _ -> ""
in let rump = function
| Fermion (Lepton spec) -> (match spec with
| (_, _, Gen0, Iso_up) -> "nue"
| (_, _, Gen0, Iso_down) -> "e"
| (_, _, Gen1, Iso_up) -> "numu"
| (_, _, Gen1, Iso_down) -> "mu"
| (_, _, Gen2, Iso_up) -> "nutau"
| (_, _, Gen2, Iso_down) -> "tau")
| Fermion (Quark spec) -> (match spec with
| (_, _, Gen0, Iso_up) -> "u"
| (_, _, Gen0, Iso_down) -> "d"
| (_, _, Gen1, Iso_up) -> "c"
| (_, _, Gen1, Iso_down) -> "s"
| (_, _, Gen2, Iso_up) -> "t"
| (_, _, Gen2, Iso_down) -> "b")
| Boson (W _) -> "w" | Boson (Z _) -> "z"
| Boson A -> invalid_arg (modname ^ ".bcd_of_flavor: no bcd for photon!")
| Boson G -> invalid_arg (modname ^ ".bcd_of_flavor: no bcd for gluon!")
in function x -> (prefix x) ^ (rump x) ^ "_bcd"
(* The function defined in the model signature which returns the colour representation of a
particle *)
let color =
let quarkrep = function
| (_, Pos, _, _) -> Color.SUN 3
| (_, Neg, _, _) -> Color.SUN (-3)
in function
| Fermion (Quark x) -> quarkrep x
| Boson G -> Color.AdjSUN 3
| _ -> Color.Singlet
let nc () = 3
(* Function for calculating the MCID code of a particle. Convenctions have been choosen such
that the heavy modes are identified by the same numbers as the light ones, prefixed with
\verb$99$. This is supposedly in accord with the conventions for adding new particles to the list
of MCID codes. This function is required by the signature. *)
let pdg =
let iso_delta = function Iso_down -> 0 | Iso_up -> 1
in let gen_delta = function Gen0 -> 0 | Gen1 -> 2 | Gen2 -> 4
in let kk_delta = function Light -> 0 | Heavy -> 9900
in function
| Fermion ( Lepton (kk, cs, gen, iso)) ->
(int_of_csign cs) * (11 + (gen_delta gen) + (iso_delta iso) + (kk_delta kk))
| Fermion ( Quark (kk, cs, gen, iso)) ->
(int_of_csign cs) * (1 + (gen_delta gen) + (iso_delta iso)+ (kk_delta kk))
| Boson (W (kk, cs)) -> (int_of_csign cs) * (24 + (kk_delta kk))
| Boson (Z kk) -> 23 + (kk_delta kk)
| Boson A -> 22
| Boson G -> 21
(* Returns the lorentz representation of a particle; required by the signature. *)
let lorentz =
let spinor = function
| (_, Pos, _, _) -> Spinor
| (_, Neg, _, _) -> ConjSpinor
in function
| Fermion (Lepton x) | Fermion (Quark x) -> spinor x
| Boson (W _) | Boson (Z _) -> Massive_Vector
| Boson A -> Vector
| Boson G -> Vector
(* O'Mega supports models that allow different gauges; however, we only implement unitary
gauge and therefore stub this (SM3 does the same thing). The \verb$gauge$ type as well as
\verb$gauge_symbol$ are required by the signature. *)
type gauge = unit
let gauge_symbol () =
failwith (modname ^ ".gauge_symbol: internal error")
(* Returns the propagator for a given particle type. Required by signature. *)
let propagator =
let spinorprop = function
| (_, Pos, _, _) -> Prop_Spinor
| (_, Neg, _, _) -> Prop_ConjSpinor
- in function
+ in function
| Fermion (Lepton x) | Fermion (Quark x) -> spinorprop x
| Boson (W _) | Boson (Z _) ->
(match !all_feynman with false -> Prop_Unitarity | true -> Prop_Feynman)
| Boson A -> Prop_Feynman
| Boson G -> Prop_Feynman
(* Return the width of a particle, required by signature. \\
\emph{TODO:} Refine such that stable particles always are treade via vanishing width, as this
might speed up the generated code a bit. *)
let width _ = !default_width
(* Returns the conjugate particle; required by signature. *)
let conjugate =
let conj_csign = function
| Pos -> Neg
| Neg -> Pos
in function
| Fermion (Lepton (kk, cs, gen, iso)) -> Fermion (Lepton (kk, conj_csign cs, gen, iso))
| Fermion (Quark (kk, cs, gen, iso)) -> Fermion (Quark (kk, conj_csign cs, gen, iso))
| Boson (W (kk, cs)) -> Boson (W (kk, conj_csign cs))
| x -> x
(* Tells the diagram generator whether a particle is a fermion, a conjugate fermion or a
boson. Required by signature *)
let fermion = function
| Fermion (Lepton (_, cs, _, _)) | Fermion (Quark (_, cs, _, _)) -> int_of_csign cs
| Boson _ -> 0
(* Charges are: charge, lepton number, baryon number, generation. Required by signature *)
module Ch = Charges.QQ
let ( // ) = Algebra.Small_Rational.make
let qn_charge = function
| Boson b -> (match b with
| W (_, c) -> (int_of_csign (c)) // 1
| _ -> 0//1)
| Fermion f -> (match f with
| Lepton (_, c, _, Iso_up) -> 0//1
| Lepton (_, c, _, Iso_down) -> (-1 * int_of_csign (c)) // 1
| Quark (_, c, _, Iso_up) -> (2 * int_of_csign (c)) // 3
| Quark (_, c, _, Iso_down) -> (-1 * int_of_csign (c)) // 3)
let qn_lepton = function
| Fermion (Lepton (_, c, _, _)) -> int_of_csign (c) // 1
| _ -> 0//1
let qn_baryon = function
| Fermion (Quark (_, c, _, _)) -> int_of_csign (c) // 1
| _ -> 0//1
(* Generation is conditional: if we enable the nontrivial CKM matrix, all particles carry
generation [0; 0; 0] *)
let qn_generation x =
let qn cs gen =
let c = int_of_csign (cs) in
match gen with
| Gen0 -> [c//1; 0//1; 0//1]
| Gen1 -> [0//1; c//1; 0//1]
| Gen2 -> [0//1; 0//1; c//1]
in
if Module_options.include_ckm then
[0//1; 0//1; 0//1]
else
match x with
| Fermion (Lepton (_, c, g, _)) -> qn c g
| Fermion (Quark (_, c, g, _)) -> qn c g
| _ -> [0//1; 0//1; 0//1]
let charges x =
[qn_charge x; qn_lepton x; qn_baryon x] @ (qn_generation x)
(* A variant to represent the different coupling constants, choosen to mimic the FORTRAN part.
Required by signature. *)
type constant =
| G_a_lep | G_a_quark of isospin
| G_aww | G_aaww
| G_w_lep of (kkmode * kkmode * generation * kkmode * generation)
| G_w_quark of (kkmode * kkmode * generation * kkmode * generation)
| G_z_lep of (kkmode * kk2 * generation * isospin)
| G_z_quark of (kkmode * kk2 * generation * isospin)
| G_wwz of (kk2 * kkmode)
| G_wwzz of (kk2 * kk2)
| G_wwza of (kk2 * kkmode)
| G_wwww of int
| G_s
| IG_s
| G_s2
(* Two integer counters for the QCD and EW order of the couplings. *)
- type orders = int * int
+ type coupling_order = QCD | EW
+ let all_coupling_orders () = [QCD; EW]
+ let coupling_order_to_string = function
+ | QCD -> "QCD"
+ | EW -> "EW"
- let orders = function
- | _ -> (0,0)
+ let coupling_orders = function
+ | _ -> failwith "Modellib_BSM.Threeshl.orders: not implemented yet!"
(* Functions for the construction of constants from indices *)
let g_a_quark x = G_a_quark x
let g_w_lep kk1 kk2 gen1 kk3 gen2 = G_w_lep (kk1, kk2, gen1, kk3, gen2)
let g_w_quark kk1 kk2 gen1 kk3 gen2 = G_w_quark (kk1, kk2, gen1, kk3, gen2)
let g_z_lep kk1 kk2 gen iso = G_z_lep (kk1, kk2, gen, iso)
let g_z_quark kk1 kk2 gen iso = G_z_quark (kk1, kk2, gen, iso)
let g_wwz kk1 kk2 = G_wwz (kk1, kk2)
let g_wwzz kk1 kk2 = G_wwzz (kk1, kk2)
let g_wwza kk1 kk2 = G_wwza (kk1, kk2)
let g_wwww nhw = if (nhw >= 0) && (nhw <= 4) then G_wwww nhw
else failwith (modname ^ ".g_wwww: invalid integer, very bad")
(* Build a list of the different constants *)
let clist = [G_a_lep; G_aww; G_aaww] @ (loop_iso [g_a_quark]) @
(loop_gen (cloop_kk (loop_gen (cloop_kk (loop_kk [g_w_lep] ))))) @
(loop_gen (cloop_kk (loop_gen (cloop_kk (loop_kk [g_w_quark] ))))) @
(loop_iso (loop_gen (cloop_kk2 (loop_kk [g_z_lep] )))) @
(loop_iso (loop_gen (cloop_kk2 (loop_kk [g_z_quark] )))) @
(loop_kk (loop_kk2 [g_wwz] )) @ (loop_kk2 (loop_kk2 [g_wwzz] )) @
(loop_kk (loop_kk2 [g_wwza] )) @ (List.map g_wwww [0; 1; 2; 3; 4])
(* Maximum number of lines meeting at a vertex, required by signature. *)
let max_degree () = 4
(* Transform a pair of kk identifiers into a kk2 identifier *)
let get_kk2 = function (Light, Light) -> Light2 | (Heavy, Heavy) -> Heavy2
| (Light, Heavy) | (Heavy, Light) -> Light_Heavy
(* Flip isospin *)
let conj_iso = function Iso_up -> Iso_down | Iso_down -> Iso_up
(* Below, lists of couplings are generated which ultimately are joined into a list of all
couplings in the model. The generated lists can be viewed using the \verb$dump.ml$ script in the
O'Mega toplevel directory. \\
The individual couplings are defined as 5-tupels resp. 6-tupels consisting in this
order of the particles meeting at the vertex, the coupling type (see \verb$couplings.ml$) and the
coupling constant. *)
(* List of $llA$ type vertices *)
let vertices_all =
let vgen kk gen =
((Fermion (Lepton (kk, Neg, gen, Iso_down)), Boson A, Fermion (Lepton (kk, Pos, gen,
Iso_down))), FBF(1, Psibar, V, Psi), G_a_lep)
in loop_gen (cloop_kk [vgen])
(* List of $qqA$ type vertices *)
let vertices_aqq =
let vgen kk gen iso =
((Fermion (Quark (kk, Neg, gen, iso)), Boson A, Fermion (Quark (kk, Pos, gen,
iso))), FBF(1, Psibar, V, Psi), G_a_quark iso)
in loop_iso (loop_gen (cloop_kk [vgen]))
(* List of $\nu lW$ type vertices *)
let vertices_wll =
let vgen kkw kk_f kk_fbar iso_f gen =
((Fermion (Lepton (kk_fbar, Neg, gen, conj_iso iso_f)),
Boson (W (kkw, (match iso_f with Iso_up -> Neg | _ -> Pos))),
Fermion (Lepton (kk_f, Pos, gen, iso_f))),
FBF (1, Psibar, VA2, Psi),
G_w_lep (kkw, (match iso_f with Iso_up -> kk_f | _ -> kk_fbar), gen,
(match iso_f with Iso_up -> kk_fbar | _ -> kk_f), gen) )
in loop_gen (loop_iso (cloop_kk (cloop_kk (loop_kk [vgen] ))))
(* The same list, but without couplings between the $W^\prime$ and light fermions *)
let vertices_wll_diet =
let filter = function
| ((Fermion (Lepton (Light, _, _, _)), Boson (W (Heavy, _)),
Fermion (Lepton (Light, _, _, _))), _, _) -> false
| _ -> true
in List.filter filter vertices_wll
(* List of $udW$ type vertices, flavor-diagonal *)
let vertices_wqq_no_ckm =
let vgen kkw kk_f kk_fbar iso_f gen =
((Fermion (Quark (kk_fbar, Neg, gen, conj_iso iso_f)),
Boson (W (kkw, (match iso_f with Iso_up -> Neg | _ -> Pos))),
Fermion (Quark (kk_f, Pos, gen, iso_f))),
FBF (1, Psibar, VA2, Psi),
G_w_quark (kkw, (match iso_f with Iso_up -> kk_f | _ -> kk_fbar), gen,
(match iso_f with Iso_up -> kk_fbar | _ -> kk_f), gen) )
in loop_gen (loop_iso (cloop_kk (cloop_kk (loop_kk [vgen] ))))
(* The same list, but without couplings between the $W^\prime$ and the first two generations
of quarks *)
let vertices_wqq_no_ckm_diet =
let filter = function
| ((Fermion (Quark (Light, _, gen, _)), Boson (W (Heavy, _)),
Fermion (Quark (Light, _, _, _))), _, _) ->
(match gen with Gen2 -> true | _ -> false)
| _ -> true
in List.filter filter vertices_wqq_no_ckm
(* List of $udW$ type vertices, including non flavor-diagonal couplings *)
let vertices_wqq =
let vgen kkw kk_f gen_f kk_fbar gen_fbar iso_f =
((Fermion (Quark (kk_fbar, Neg, gen_fbar, conj_iso iso_f)),
Boson (W (kkw, (match iso_f with Iso_up -> Neg | _ -> Pos))),
Fermion (Quark (kk_f, Pos, gen_f, iso_f))),
FBF (1, Psibar, VA2, Psi),
G_w_quark (match iso_f with
| Iso_up -> (kkw, kk_f, gen_f, kk_fbar, gen_fbar)
| Iso_down -> (kkw, kk_fbar, gen_fbar, kk_f, gen_f)))
in loop_iso (loop_gen (cloop_kk (loop_gen (cloop_kk (loop_kk [vgen] )))))
(* List of $llZ$ / $\nu\nu Z$ type vertices *)
let vertices_zll =
let vgen kkz kk_f kk_fbar gen iso =
((Fermion (Lepton (kk_fbar, Neg, gen, iso)), Boson (Z kkz),
Fermion (Lepton (kk_f, Pos, gen, iso))),
FBF (1, Psibar, VA2, Psi),
G_z_lep (kkz, get_kk2 (kk_f, kk_fbar), gen, iso))
in loop_iso (loop_gen (cloop_kk (cloop_kk (loop_kk [vgen] ))))
(* List of $qqZ$ type vertices *)
let vertices_zqq =
let vgen kkz kk_f kk_fbar gen iso =
((Fermion (Quark (kk_fbar, Neg, gen, iso)), Boson (Z kkz),
Fermion (Quark (kk_f, Pos, gen, iso))),
FBF (1, Psibar, VA2, Psi),
G_z_quark (kkz, get_kk2 (kk_f, kk_fbar), gen, iso))
in loop_iso (loop_gen (cloop_kk (cloop_kk (loop_kk [vgen] ))))
(* $gq\bar{q}$ *)
let vertices_gqq =
let vgen kk gen iso =
((Fermion (Quark (kk, Neg, gen, iso)), Boson G, Fermion (Quark (kk, Pos, gen, iso))),
FBF (1, Psibar, V, Psi), G_s)
in loop_iso (loop_gen (cloop_kk [vgen]))
(* AWW *)
let vertices_aww =
let vgen kk =
( (Boson A, Boson (W (kk, Pos)), Boson (W (kk, Neg))), Gauge_Gauge_Gauge 1, G_aww)
in loop_kk [vgen]
(* ZWW *)
let vertices_zww =
let vgen kkz kkwp kkwm =
((Boson (Z kkz), Boson (W (kkwp, Pos)), Boson (W (kkwm, Neg))), Gauge_Gauge_Gauge 1,
G_wwz (get_kk2 (kkwp, kkwm), kkz))
in loop_kk (loop_kk (loop_kk [vgen]))
(* $ggg$ *)
let vertices_ggg = [(Boson G, Boson G, Boson G), Gauge_Gauge_Gauge (-1), IG_s]
(* Stolen from Modellib.SM; the signs seem to be OK. See \verb$couplings.ml$ for more docs. *)
let gauge4 = Vector4 [(2, C_13_42); (-1, C_12_34); (-1, C_14_23)]
let minus_gauge4 = Vector4 [(-2, C_13_42); (1, C_12_34); (1, C_14_23)]
(* AAWW *)
let vertices_aaww =
let vgen kk =
((Boson A, Boson (W (kk, Pos)), Boson A, Boson (W (kk, Neg))), minus_gauge4, G_aaww)
in loop_kk [vgen]
(* WWZZ *)
let vertices_wwzz =
let vgen kkwp kkwm kk2z =
((Boson (Z (match kk2z with Heavy2 -> Heavy | Light2 | Light_Heavy -> Light)),
Boson (W (kkwp, Pos)),
Boson (Z (match kk2z with Heavy2 | Light_Heavy -> Heavy | Light2 -> Light)),
Boson (W (kkwm, Neg))), minus_gauge4, G_wwzz (get_kk2 (kkwp, kkwm), kk2z))
in loop_kk2 (loop_kk (loop_kk [vgen]))
(* WWZA *)
let vertices_wwza =
let vgen kkwp kkwm kkz =
((Boson A, Boson (W (kkwp, Pos)), Boson (Z kkz), Boson (W (kkwm, Neg))),
minus_gauge4, G_wwza (get_kk2 (kkwp, kkwm), kkz))
in loop_kk (loop_kk (loop_kk [vgen]))
(* WWWW *)
let vertices_wwww =
let count = function Light2 -> 0 | Light_Heavy -> 1 | Heavy2 -> 2
in let vgen kk2wp kk2wm =
((Boson (W ((match kk2wp with Heavy2 -> Heavy | Light2 | Light_Heavy -> Light), Pos)),
Boson (W ((match kk2wm with Heavy2 -> Heavy | Light2 | Light_Heavy -> Light), Neg)),
Boson (W ((match kk2wp with Heavy2 | Light_Heavy -> Heavy | Light2 -> Light), Pos)),
Boson (W ((match kk2wm with Heavy2 | Light_Heavy -> Heavy | Light2 -> Light), Neg))),
gauge4, G_wwww ((count kk2wp) + (count kk2wm)))
in loop_kk2 (loop_kk2 [vgen])
(* gggg *)
let vertices_gggg = [(Boson G, Boson G, Boson G, Boson G), gauge4, G_s2]
(* The list of couplings is transformed into the fusion lists required by the generator by
the Model.Fusions functor. *)
(* This is copy\& paste from the other models; check again with Thorsten if it is correct *)
module F = Modeltools.Fusions (struct
type f = flavor
type c = constant
let compare = compare
let conjugate = conjugate
end )
(* Not sure yet whether F.fusex also creates the conjugate vertices; by looking at the
implementation of the other models, I assume it doesn't. Still, better ask Thorsten to be
sure!!!\\
\emph{Update:} Still didn't get to ask, but since the results are consistent, I suspect my assertion
is correct. \\
The stuff below is required by the signature. *)
let vertices () = (vertices_all @ vertices_aqq @
(match Module_options.diet with
| false -> vertices_wll
| true -> vertices_wll_diet) @
(match (Module_options.include_ckm, Module_options.diet) with
| (true, false) -> vertices_wqq
| (false, false) -> vertices_wqq_no_ckm
| (false, true) -> vertices_wqq_no_ckm_diet
| (true, true) -> raise (Failure
("Modules4.Threeshl.vertices: CKM matrix together with option diet is not" ^
" implemented yet!"))) @
vertices_zll @ vertices_zqq @ vertices_aww @ vertices_zww @ vertices_gqq @ vertices_ggg,
vertices_aaww @ vertices_wwzz @ vertices_wwza @ vertices_wwww @ vertices_gggg
, [])
let table = F.of_vertices (vertices ())
let fuse2 = F.fuse2 table
let fuse3 = F.fuse3 table
let fuse = F.fuse table
(* A function that returns a list of a flavours known to the model, required by the signature.
*)
let flavors () = (List.map flavor_of_f (all_leptons @ all_quarks)) @
(List.map flavor_of_b all_bosons)
(* dito, external flavours, also required. *)
let external_flavors () = [
"light leptons", List.map flavor_of_f (loop_iso (loop_gen( loop_cs [lepton Light])));
"light quarks", List.map flavor_of_f (loop_iso (loop_gen( loop_cs [quark Light])));
"light gauge bosons", List.map flavor_of_b [W (Light, Pos); W (Light, Neg); Z Light; A];
"heavy gauge bosons", List.map flavor_of_b [W (Heavy, Pos); W (Heavy, Neg); Z Heavy]] @
(match Module_options.include_hf with
| true -> [
"heavy leptons", List.map flavor_of_f (loop_iso (loop_gen( loop_cs [lepton Heavy])));
"heavy quarks", List.map flavor_of_f (loop_iso (loop_gen( loop_cs [quark Heavy])))]
| false -> [] ) @ ["gluons", [Boson G]]
(* Which of the particles are goldstones? $\rightarrow$ none. Required by the signature. *)
let goldstone x = None
(* This is wrong but handy for debugging the constant identifier generation via -params.
Usually, this function would return a record consisting of the parameters as well as
expression for the dependent quantities that can be used to generate FORTRAN code for
calculating them. However, we have a seperate module for the threeshl, so we can abuse this
for debugging. Required by signature. *)
let parameters () = {input = List.map (fun x -> (x, 0.)) clist;
derived = []; derived_arrays = []}
(* Convert a flavour into a ID string with which it will be referred by the user interface of
the compiled generator. Required by signature *)
let flavor_to_string =
let prefix = function
| Fermion (Lepton (Heavy, _, _, _)) | Fermion (Quark (Heavy, _, _, _))
| Boson (W (Heavy, _)) | Boson (Z Heavy) -> "H"
| _ -> ""
in let postfix = function
| Fermion (Lepton (_, cs, _, Iso_down)) -> (match cs with Pos -> "-" | Neg -> "+")
| Fermion (Quark (_, Neg, _, _)) | Fermion (Lepton (_, Neg, _, Iso_up)) -> "bar"
| Boson (W (_, cs)) -> (match cs with Pos -> "+" | Neg -> "-")
| _ -> ""
in let rump = function
| Fermion (Lepton desc) -> (match desc with
| (_, _, Gen0, Iso_up) -> "nue"
| (_, _, Gen0, Iso_down) -> "e"
| (_, _, Gen1, Iso_up) -> "numu"
| (_, _, Gen1, Iso_down) -> "mu"
| (_, _, Gen2, Iso_up) -> "nutau"
| (_, _, Gen2, Iso_down) -> "tau")
| Fermion (Quark desc) -> (match desc with
| (_, _, Gen0, Iso_up) -> "u"
| (_, _, Gen0, Iso_down) -> "d"
| (_, _, Gen1, Iso_up) -> "c"
| (_, _, Gen1, Iso_down) -> "s"
| (_, _, Gen2, Iso_up) -> "t"
| (_, _, Gen2, Iso_down) -> "b")
| Boson (W _) -> "W" | Boson (Z _) -> "Z" | Boson A -> "A" | Boson G -> "gl"
in function x -> (prefix x) ^ (rump x) ^ (postfix x)
(* Conversion of the ID string into a particle flavor. Instead of going through all cases
again, we generate a ``dictionary'' of flavor / ID pairs which we use to identify the correct
flavor. Required by signature. *)
let flavor_of_string x =
let dict = List.map (fun x -> (x, flavor_to_string x)) (flavors ())
in let get_ident = function (x, _) -> x
in try
get_ident (List.find (fun (_, y) -> (x = y)) dict)
with
Not_found -> (match x with
| "g" -> Boson G
| _ -> invalid_arg (modname ^ ".flavor_of_string")
)
(* Converts a flavor into a symbol used as identification in the generated FORTRAN code (has
to comply to the conventions of valid FORTRAN identifiers therefore). We stick to the same
convenctions as SM3, prefixing heavy modes with a \verb$H$. Required by signature. *)
let flavor_symbol =
let prefix = function
| Fermion (Lepton (Heavy, _, _, _)) | Fermion (Quark (Heavy, _, _, _))
| Boson (W (Heavy, _)) | Boson (Z Heavy) -> "H"
| _ -> ""
in let postfix = function
| Fermion (Lepton (_, Neg, _, _)) | Fermion (Quark (_, Neg, _, _)) -> "b"
| _ -> ""
in let rump = function
| Fermion spec -> (match spec with
| Lepton (_, _, gen, Iso_up) -> "n" ^ (string_of_int (int_of_gen gen))
| Lepton (_, _, gen, Iso_down) -> "l" ^ (string_of_int (int_of_gen gen))
| Quark (_, _, gen, Iso_up) -> "u" ^ (string_of_int (int_of_gen gen))
| Quark (_, _, gen, Iso_down) -> "d"^ (string_of_int (int_of_gen gen)))
| Boson spec -> (match spec with
| W (_, Pos) -> "wp" | W (_, Neg) -> "wm"
| Z _ -> "z" | A -> "a" | G -> "gl" )
in function
x -> (prefix x) ^ (rump x) ^ (postfix x)
(* Generate TeX for a flavor *)
let flavor_to_TeX =
let bar x y = match x with Neg -> "\\overline{" ^ y ^ "}" | Pos -> y
in let pm x y = match x with Neg -> "{" ^ y ^ "}^+" | Pos -> "{" ^ y ^ "}^-"
in let prime x y = match x with Light -> y | Heavy -> "{" ^ y ^ "}^\\prime"
in function
| Fermion (Lepton desc) -> (match desc with
| (kk, cs, gen, Iso_up) -> prime kk (bar cs (match gen with
| Gen0 -> "\\nu_e"
| Gen1 -> "\\nu_\\mu"
| Gen2 -> "\\nu_\\tau"))
| (kk, cs, gen, Iso_down) -> prime kk (pm cs (match gen with
| Gen0 -> "e" | Gen1 -> "\\mu" | Gen2 -> "\\tau")))
| Fermion (Quark (kk, cs, gen, iso)) -> prime kk (bar cs (match (gen, iso) with
| (Gen0, Iso_up) -> "u"
| (Gen0, Iso_down) -> "d"
| (Gen1, Iso_up) -> "c"
| (Gen1, Iso_down) -> "s"
| (Gen2, Iso_up) -> "t"
| (Gen2, Iso_down) -> "b"))
| Boson spec -> (match spec with
| W (kk, cs) -> prime kk (pm (match cs with Pos -> Neg | Neg -> Pos) "W")
| Z kk -> prime kk "Z"
| A -> "A" | G -> "g")
(* Returns the string referring to the particle mass in the generated FORTRAN code. Required
by signature. *)
let mass_symbol = function
| Boson A | Boson G-> "0._default"
| x -> "mass_array(" ^ (bcdi_of_flavor x) ^ ")"
(* Dito, for width. Required by signature. *)
let width_symbol = function
| Boson A | Boson G -> "0._default"
| x -> "width_array(" ^ (bcdi_of_flavor x) ^ ")"
(* Determines the string referring to a coupling constant in the generated FORTRAN code.
Required by signature. *)
let constant_symbol =
let c = ", "
in let g_w_ferm = function
(kk1, kk2, gen1, kk3, gen2) ->
":, " ^ (fspec_of_kkmode kk1) ^ c ^ (fspec_of_kkmode kk2) ^ c ^ (fspec_of_gen gen1) ^ c ^
(fspec_of_kkmode kk3) ^ c ^ (fspec_of_gen gen2)
in let g_z_ferm = function
(kk1, kk2, gen, iso) ->
":, " ^ (fspec_of_kkmode kk1) ^ c ^ (fspec_of_kk2 kk2) ^ c ^ (fspec_of_gen gen) ^ c ^
(fspec_of_iso iso)
in function
| G_a_lep -> "g_a_lep"
| G_s -> "g_s_norm"
| IG_s -> "ig_s_norm"
| G_s2 -> "g_s_norm2"
| G_a_quark iso -> "g_a_quark(" ^ (fspec_of_iso iso) ^ ")"
| G_aww -> "ig_aww"
| G_aaww -> "g_aaww"
| G_w_lep spec -> "g_w_lep_va(" ^ (g_w_ferm spec) ^ ")"
| G_w_quark spec -> "g_w_quark_va(" ^ (g_w_ferm spec) ^ ")"
| G_z_lep spec -> "g_z_lep_va(" ^ (g_z_ferm spec) ^ ")"
| G_z_quark spec -> "g_z_quark_va(" ^ (g_z_ferm spec) ^ ")"
| G_wwz (kk1, kk2) -> "ig_wwz(" ^ (fspec_of_kk2 kk1) ^ c ^
(fspec_of_kkmode kk2) ^ ")"
| G_wwzz (kk1, kk2) -> "g_wwzz(" ^ (fspec_of_kk2 kk1) ^ c ^
(fspec_of_kk2 kk2) ^ ")"
| G_wwza (kk1, kk2) -> "g_wwza(" ^(fspec_of_kk2 kk1) ^ c ^
(fspec_of_kkmode kk2) ^ ")"
| G_wwww nhw -> if (0 <= nhw) && (nhw <= 4) then
"g_wwww(" ^ (string_of_int nhw) ^ ")"
else failwith "Modules4.Threeshl.constant_symbol: invalid int for G_wwww; very bad"
end
(* \thocwmodulesection{THDM with and without non-trivial flavor structure} *)
module type THDM_flags =
sig
val ckm_present : bool
end
module THDM : THDM_flags =
struct
let ckm_present = false
end
module THDM_CKM : THDM_flags =
struct
let ckm_present = true
end
module TwoHiggsDoublet (Flags : THDM_flags) =
struct
open Coupling
let default_width = ref Timelike
let use_fudged_width = ref false
let options = Options.create
[ "constant_width", Arg.Unit (fun () -> default_width := Constant),
"use constant width (also in t-channel)";
"fudged_width", Arg.Set use_fudged_width,
"use fudge factor for charge particle width";
"custom_width", Arg.String (fun f -> default_width := Custom f),
"use custom width";
"cancel_widths", Arg.Unit (fun () -> default_width := Vanishing),
"use vanishing width";
"cms_width", Arg.Unit (fun () -> default_width := Complex_Mass),
"use complex mass scheme";
"running_width", Arg.Unit (fun () -> default_width := Running),
"use running width"]
let caveats () = []
type matter_field = L of int | N of int | U of int | D of int
type gauge_boson = Ga | Wp | Wm | Z | Gl
type other = Phip | Phim | Phi0 | Hh | HA | HH | Hp | Hm
type flavor = M of matter_field | G of gauge_boson | O of other
let matter_field f = M f
let gauge_boson f = G f
let other f = O f
type field =
| Matter of matter_field
| Gauge of gauge_boson
| Other of other
let field = function
| M f -> Matter f
| G f -> Gauge f
| O f -> Other f
type gauge = unit
let gauge_symbol () =
failwith "Modellib_BSM.TwoHiggsDoublet.gauge_symbol: internal error"
let family n = List.map matter_field [ L n; N n; U n; D n ]
let external_flavors () =
[ "1st Generation", ThoList.flatmap family [1; -1];
"2nd Generation", ThoList.flatmap family [2; -2];
"3rd Generation", ThoList.flatmap family [3; -3];
"Gauge Bosons", List.map gauge_boson [Ga; Z; Wp; Wm; Gl];
"Higgs", List.map other [Hh; HH; HA; Hp; Hm];
"Goldstone Bosons", List.map other [Phip; Phim; Phi0] ]
let flavors () = ThoList.flatmap snd (external_flavors ())
let spinor n =
if n >= 0 then
Spinor
else
ConjSpinor
let lorentz = function
| M f ->
begin match f with
| L n -> spinor n | N n -> spinor n
| U n -> spinor n | D n -> spinor n
end
| G f ->
begin match f with
| Ga | Gl -> Vector
| Wp | Wm | Z -> Massive_Vector
end
| O f -> Scalar
- let color = function
+ let color = function
| M (U n) -> Color.SUN (if n > 0 then 3 else -3)
| M (D n) -> Color.SUN (if n > 0 then 3 else -3)
| G Gl -> Color.AdjSUN 3
| _ -> Color.Singlet
let nc () = 3
let prop_spinor n =
if n >= 0 then
Prop_Spinor
else
Prop_ConjSpinor
let propagator = function
| M f ->
begin match f with
| L n -> prop_spinor n | N n -> prop_spinor n
| U n -> prop_spinor n | D n -> prop_spinor n
end
| G f ->
begin match f with
| Ga | Gl -> Prop_Feynman
| Wp | Wm | Z -> Prop_Unitarity
end
| O f ->
begin match f with
| Phip | Phim | Phi0 -> Only_Insertion
| Hh | HH | HA | Hp | Hm -> Prop_Scalar
end
(* Optionally, ask for the fudge factor treatment for the widths of
charged particles. Currently, this only applies to $W^\pm$ and top. *)
let width f =
if !use_fudged_width then
match f with
| G Wp | G Wm | M (U 3) | M (U (-3)) -> Fudged
| _ -> !default_width
else
!default_width
let goldstone = function
| G f ->
begin match f with
| Wp -> Some (O Phip, Coupling.Integer 1)
| Wm -> Some (O Phim, Coupling.Integer 1)
| Z -> Some (O Phi0, Coupling.Integer 1)
| _ -> None
end
| _ -> None
let conjugate = function
| M f ->
M (begin match f with
| L n -> L (-n) | N n -> N (-n)
| U n -> U (-n) | D n -> D (-n)
end)
| G f ->
G (begin match f with
| Gl -> Gl | Ga -> Ga | Z -> Z
| Wp -> Wm | Wm -> Wp
end)
| O f ->
O (begin match f with
| Phip -> Phim | Phim -> Phip | Phi0 -> Phi0
| Hh -> Hh | HH -> HH | HA -> HA
| Hp -> Hm | Hm -> Hp
end)
let fermion = function
| M f ->
begin match f with
| L n -> if n > 0 then 1 else -1
| N n -> if n > 0 then 1 else -1
| U n -> if n > 0 then 1 else -1
| D n -> if n > 0 then 1 else -1
end
| G f ->
begin match f with
| Gl | Ga | Z | Wp | Wm -> 0
end
| O _ -> 0
(* Electrical charge, lepton number, baryon number. We could avoid the
rationals altogether by multiplying the first and last by 3 \ldots *)
module Ch = Charges.QQ
let ( // ) = Algebra.Small_Rational.make
let generation' = function
| 1 -> [ 1//1; 0//1; 0//1]
| 2 -> [ 0//1; 1//1; 0//1]
| 3 -> [ 0//1; 0//1; 1//1]
| -1 -> [-1//1; 0//1; 0//1]
| -2 -> [ 0//1; -1//1; 0//1]
| -3 -> [ 0//1; 0//1; -1//1]
| n -> invalid_arg ("Modellib_BSM.TwoHiggsDoublet.generation': " ^ string_of_int n)
let generation f =
if Flags.ckm_present then
[]
else
match f with
| M (L n | N n | U n | D n) -> generation' n
| G _ | O _ -> [ 0//1; 0//1; 0//1]
let charge = function
| M f ->
begin match f with
| L n -> if n > 0 then -1//1 else 1//1
| N n -> 0//1
| U n -> if n > 0 then 2//3 else -2//3
| D n -> if n > 0 then -1//3 else 1//3
end
| G f ->
begin match f with
| Gl | Ga | Z -> 0//1
| Wp -> 1//1
| Wm -> -1//1
end
| O f ->
begin match f with
| Hh | HH | HA | Phi0 -> 0//1
| Hp | Phip -> 1//1
| Hm | Phim -> -1//1
end
let lepton = function
| M f ->
begin match f with
| L n | N n -> if n > 0 then 1//1 else -1//1
| U _ | D _ -> 0//1
end
| G _ | O _ -> 0//1
let baryon = function
| M f ->
begin match f with
| L _ | N _ -> 0//1
| U n | D n -> if n > 0 then 1//1 else -1//1
end
| G _ | O _ -> 0//1
let charges f =
[ charge f; lepton f; baryon f] @ generation f
type constant =
| Unit | Pi | Alpha_QED | Sin2thw
| Sinthw | Costhw | E | G_weak | Vev
| Q_lepton | Q_up | Q_down | G_CC
| G_NC_neutrino | G_NC_lepton | G_NC_up | G_NC_down
| I_Q_W | I_G_ZWW | I_G_WWW
| G_WWWW | G_ZZWW | G_AZWW | G_AAWW
| G_htt | G_hbb | G_hcc | G_htautau | G_hmumu
| G_Htt | G_Hbb | G_Hcc | G_Htautau | G_Hmumu
| I_G_Att | I_G_Abb | I_G_Acc | I_G_Atautau | I_G_Amumu
| G_Htb | G_Hcs | G_Htaunu | G_Hmunu
| Gs | I_Gs | G2
| G_AHpHm | G_ZHpHm | G_Zh1h2 | G_Zh1h3 | G_Zh2h3
| G_WpHmh1 | G_WpHmh2 | G_WpHmh3 | G_WmHph1 | G_WmHph2
| G_WmHph3 | G_h1ZZ | G_h2ZZ | G_h3ZZ | G_h1WpWm | G_h2WpWm
| G_h3WpWm | G_hhWpWm | G_hhZZ | G_HpHmAA | G_HpHmZZ | G_HpHmAZ
| G_HpHmWpWm | G_h1HpAWm | G_h2HpAWm | G_h3HpAWm | G_h1HpZWm
| G_h2HpZWm | G_h3HpZWm | G_h1HpAWmC | G_h2HpAWmC | G_h3HpAWmC
| G_h1HpZWmC | G_h2HpZWmC | G_h3HpZWmC | G_h1HpHm | G_h2HpHm | G_h3HpHm
| G_h111 | G_h112 | G_h113 | G_h221 | G_h222 | G_h223 | G_h331 | G_h332
| G_h333 | G_h123 | G_HpHmHpHm | G_HpHm11 | G_HpHm12 | G_HpHm13
| G_HpHm22 | G_HpHm23 | G_HpHm33 | G_h1111 | G_h1112 | G_h1113
| G_h1122 | G_h1123 | G_h1133 | G_h1222 | G_h1223 | G_h1233 | G_h1333
| G_h2222 | G_h2223 | G_h2233 | G_h2333 | G_h3333
| G_h1uu | G_h2uu | G_h3uu | G_h1uc | G_h2uc | G_h3uc | G_h1ut
| G_h2ut | G_h3ut | G_h1cu | G_h2cu | G_h3cu | G_h1cc | G_h2cc
| G_h3cc | G_h1ct | G_h2ct | G_h3ct | G_h1tu | G_h2tu | G_h3tu
| G_h1tc | G_h2tc | G_h3tc | G_h1tt | G_h2tt | G_h3tt
| G_h1dd | G_h2dd | G_h3dd | G_h1ds | G_h2ds | G_h3ds | G_h1db
| G_h2db | G_h3db | G_h1sd | G_h2sd | G_h3sd | G_h1ss | G_h2ss
| G_h3ss | G_h1sb | G_h2sb | G_h3sb | G_h1bd | G_h2bd | G_h3bd
| G_h1bs | G_h2bs | G_h3bs | G_h1bb | G_h2bb | G_h3bb
| G_hud | G_hus | G_hub | G_hcd | G_hcs | G_hcb | G_htd | G_hts | G_htb
| G_hdu | G_hdc | G_hdt | G_hsu | G_hsc | G_hst | G_hbu | G_hbc | G_hbt
| G_he1n1 | G_he1n2 | G_he1n3 | G_he2n1 | G_he2n2 | G_he2n3 | G_he3n1
| G_he3n2 | G_he3n3 | G_hn1e1 | G_hn1e2 | G_hn1e3 | G_hn2e1 | G_hn2e2
| G_hn2e3 | G_hn3e1 | G_hn3e2 | G_hn3e3
| G_h1e1e1 | G_h2e1e1 | G_h3e1e1 | G_h1e1e2 | G_h2e1e2 | G_h3e1e2
| G_h1e1e3 | G_h2e1e3 | G_h3e1e3 | G_h1e2e1 | G_h2e2e1 | G_h3e2e1
| G_h1e2e2 | G_h2e2e2 | G_h3e2e2 | G_h1e2e3 | G_h2e2e3 | G_h3e2e3
| G_h1e3e1 | G_h2e3e1 | G_h3e3e1 | G_h1e3e2 | G_h2e3e2 | G_h3e3e2
| G_h1e3e3 | G_h2e3e3 | G_h3e3e3
| Mass of flavor | Width of flavor
(* Two integer counters for the QCD and EW order of the couplings. *)
- type orders = int * int
+ type coupling_order = QCD | EW
+ let all_coupling_orders () = [QCD; EW]
+ let coupling_order_to_string = function
+ | QCD -> "QCD"
+ | EW -> "EW"
- let orders = function
- | _ -> (0,0)
+ let coupling_orders = function
+ | _ -> failwith "Modellib_BSM.TwoHiggsDoublet.orders: not implemented yet!"
let g_over_2_costh =
Quot (Neg (Atom G_weak), Prod [Integer 2; Atom Costhw])
let nc_coupling c t3 q =
(Real_Array c,
[Prod [g_over_2_costh; Diff (t3, Prod [Integer 2; q; Atom Sin2thw])];
Prod [g_over_2_costh; t3]])
let half = Quot (Integer 1, Integer 2)
let array_list = [G_h1uu; G_h2uu; G_h3uu; G_h1uc; G_h2uc; G_h3uc; G_h1ut;
G_h2ut; G_h3ut; G_h1cu; G_h2cu; G_h3cu; G_h1cc; G_h2cc;
G_h3cc; G_h1ct; G_h2ct; G_h3ct; G_h1tu; G_h2tu; G_h3tu;
G_h1tc; G_h2tc; G_h3tc; G_h1tt; G_h2tt; G_h3tt;
G_h1dd; G_h2dd; G_h3dd; G_h1ds; G_h2ds; G_h3ds; G_h1db;
G_h2db; G_h3db; G_h1sd; G_h2sd; G_h3sd; G_h1ss; G_h2ss;
G_h3ss; G_h1sb; G_h2sb; G_h3sb; G_h1bd; G_h2bd; G_h3bd;
G_h1bs; G_h2bs; G_h3bs; G_h1bb; G_h2bb; G_h3bb;
G_hud; G_hus; G_hub; G_hcd; G_hcs; G_hcb; G_htd; G_hts; G_htb;
G_hdu; G_hdc; G_hdt; G_hsu; G_hsc; G_hst; G_hbu; G_hbc; G_hbt;
G_he1n1; G_he1n2; G_he1n3; G_he2n1; G_he2n2; G_he2n3; G_he3n1;
G_he3n2; G_he3n3; G_hn1e1; G_hn1e2; G_hn1e3; G_hn2e1; G_hn2e2;
G_hn2e3; G_hn3e1; G_hn3e2; G_hn3e3;
G_h1e1e1; G_h2e1e1; G_h3e1e1; G_h1e1e2; G_h2e1e2; G_h3e1e2;
G_h1e1e3; G_h2e1e3; G_h3e1e3; G_h1e2e1; G_h2e2e1; G_h3e2e1;
G_h1e2e2; G_h2e2e2; G_h3e2e2; G_h1e2e3; G_h2e2e3; G_h3e2e3;
G_h1e3e1; G_h2e3e1; G_h3e3e1; G_h1e3e2; G_h2e3e2; G_h3e3e2;
G_h1e3e3; G_h2e3e3; G_h3e3e3]
let add_complex_array_tag c = (Complex_Array c, [Integer 0; Integer 0])
let derived_parameter_arrays =
[ nc_coupling G_NC_neutrino half (Integer 0);
nc_coupling G_NC_lepton (Neg half) (Integer (-1));
nc_coupling G_NC_up half (Quot (Integer 2, Integer 3));
nc_coupling G_NC_down (Neg half) (Quot (Integer (-1), Integer 3));
] @ (List.map add_complex_array_tag array_list)
let parameters () =
{ input = []; derived = []; derived_arrays = derived_parameter_arrays}
module F = Modeltools.Fusions (struct
type f = flavor
type c = constant
let compare = compare
let conjugate = conjugate
end)
(* \begin{equation}
\mathcal{L}_{\textrm{EM}} =
- e \sum_i q_i \bar\psi_i\fmslash{A}\psi_i
\end{equation} *)
let mgm ((m1, g, m2), fbf, c) = ((M m1, G g, M m2), fbf, c)
let electromagnetic_currents n =
List.map mgm
[ ((L (-n), Ga, L n), FBF (1, Psibar, V, Psi), Q_lepton);
((U (-n), Ga, U n), FBF (1, Psibar, V, Psi), Q_up);
((D (-n), Ga, D n), FBF (1, Psibar, V, Psi), Q_down) ]
let color_currents n =
List.map mgm
[ ((U (-n), Gl, U n), FBF (1, Psibar, V, Psi), Gs);
((D (-n), Gl, D n), FBF (1, Psibar, V, Psi), Gs) ]
(* \begin{equation}
\mathcal{L}_{\textrm{NC}} =
- \frac{g}{2\cos\theta_W}
\sum_i \bar\psi_i\fmslash{Z}(g_V^i-g_A^i\gamma_5)\psi_i
\end{equation} *)
let neutral_currents n =
List.map mgm
[ ((L (-n), Z, L n), FBF (1, Psibar, VA, Psi), G_NC_lepton);
((N (-n), Z, N n), FBF (1, Psibar, VA, Psi), G_NC_neutrino);
((U (-n), Z, U n), FBF (1, Psibar, VA, Psi), G_NC_up);
((D (-n), Z, D n), FBF (1, Psibar, VA, Psi), G_NC_down) ]
(* \begin{equation}
\mathcal{L}_{\textrm{CC}} =
- \frac{g}{2\sqrt2} \sum_i \bar\psi_i
(T^+\fmslash{W}^+ + T^-\fmslash{W}^-)(1-\gamma_5)\psi_i
\end{equation} *)
let charged_currents n =
List.map mgm
[ ((L (-n), Wm, N n), FBF (1, Psibar, VL, Psi), G_CC);
((N (-n), Wp, L n), FBF (1, Psibar, VL, Psi), G_CC);
((D (-n), Wm, U n), FBF (1, Psibar, VL, Psi), G_CC);
((U (-n), Wp, D n), FBF (1, Psibar, VL, Psi), G_CC) ]
let yukawa =
[ ((M (U (-1)),O Hh,M (U 1)), FBF (1,Psibar,SP,Psi), G_h1uu);
((M (U (-1)),O HH,M (U 1)), FBF (1,Psibar,SP,Psi), G_h2uu);
((M (U (-1)),O HA,M (U 1)), FBF (1,Psibar,SP,Psi), G_h3uu);
((M (U (-2)),O Hh,M (U 2)), FBF (1,Psibar,SP,Psi), G_h1cc);
((M (U (-2)),O HH,M (U 2)), FBF (1,Psibar,SP,Psi), G_h2cc);
((M (U (-2)),O HA,M (U 2)), FBF (1,Psibar,SP,Psi), G_h3cc);
((M (U (-3)),O Hh,M (U 3)), FBF (1,Psibar,SP,Psi), G_h1tt);
((M (U (-3)),O HH,M (U 3)), FBF (1,Psibar,SP,Psi), G_h2tt);
((M (U (-3)),O HA,M (U 3)), FBF (1,Psibar,SP,Psi), G_h3tt);
((M (D (-1)),O Hh,M (D 1)), FBF (1,Psibar,SP,Psi), G_h1dd);
((M (D (-1)),O HH,M (D 1)), FBF (1,Psibar,SP,Psi), G_h2dd);
((M (D (-1)),O HA,M (D 1)), FBF (1,Psibar,SP,Psi), G_h3dd);
((M (D (-2)),O Hh,M (D 2)), FBF (1,Psibar,SP,Psi), G_h1ss);
((M (D (-2)),O HH,M (D 2)), FBF (1,Psibar,SP,Psi), G_h2ss);
((M (D (-2)),O HA,M (D 2)), FBF (1,Psibar,SP,Psi), G_h3ss);
((M (D (-3)),O Hh,M (D 3)), FBF (1,Psibar,SP,Psi), G_h1bb);
((M (D (-3)),O HH,M (D 3)), FBF (1,Psibar,SP,Psi), G_h2bb);
((M (D (-3)),O HA,M (D 3)), FBF (1,Psibar,SP,Psi), G_h3bb);
((M (U (-1)),O Hp,M (D 1)), FBF (1,Psibar,SP,Psi), G_hud);
((M (U (-2)),O Hp,M (D 2)), FBF (1,Psibar,SP,Psi), G_hcs);
((M (U (-3)),O Hp,M (D 3)), FBF (1,Psibar,SP,Psi), G_htb);
((M (D (-1)),O Hm,M (U 1)), FBF (1,Psibar,SP,Psi), G_hdu);
((M (D (-2)),O Hm,M (U 2)), FBF (1,Psibar,SP,Psi), G_hsc);
((M (D (-3)),O Hm,M (U 3)), FBF (1,Psibar,SP,Psi), G_hbt);
((M (L (-1)),O Hh,M (L 1)), FBF (1,Psibar,SP,Psi), G_h1e1e1);
((M (L (-1)),O HH,M (L 1)), FBF (1,Psibar,SP,Psi), G_h2e1e1);
((M (L (-1)),O HA,M (L 1)), FBF (1,Psibar,SP,Psi), G_h3e1e1);
((M (L (-2)),O Hh,M (L 2)), FBF (1,Psibar,SP,Psi), G_h1e2e2);
((M (L (-2)),O HH,M (L 2)), FBF (1,Psibar,SP,Psi), G_h2e2e2);
((M (L (-2)),O HA,M (L 2)), FBF (1,Psibar,SP,Psi), G_h3e2e2);
((M (L (-3)),O Hh,M (L 3)), FBF (1,Psibar,SP,Psi), G_h1e3e3);
((M (L (-3)),O HH,M (L 3)), FBF (1,Psibar,SP,Psi), G_h2e3e3);
((M (L (-3)),O HA,M (L 3)), FBF (1,Psibar,SP,Psi), G_h3e3e3)
(*i ((M (N (-1)),O Hp,M (L 1)), FBF (1,Psibar,SR,Psi), G_hn1e1);
((M (N (-2)),O Hp,M (L 2)), FBF (1,Psibar,SR,Psi), G_hn2e2);
((M (N (-3)),O Hp,M (L 3)), FBF (1,Psibar,SR,Psi), G_hn3e3);
((M (L (-1)),O Hm,M (N 1)), FBF (1,Psibar,SL,Psi), G_he1n1);
((M (L (-2)),O Hm,M (N 2)), FBF (1,Psibar,SL,Psi), G_he2n2);
((M (L (-3)),O Hm,M (N 3)), FBF (1,Psibar,SL,Psi), G_he3n3); i*)
] @
if Flags.ckm_present then
[((M (U (-1)),O Hh, M (U 2)), FBF (1,Psibar,SP,Psi), G_h1uc);
((M (U (-1)),O Hh, M (U 3)), FBF (1,Psibar,SP,Psi), G_h1ut);
((M (U (-2)),O Hh,M (U 1)), FBF (1,Psibar,SP,Psi), G_h1cu);
((M (U (-2)),O Hh,M (U 3)), FBF (1,Psibar,SP,Psi), G_h1ct);
((M (U (-1)),O HH,M (U 2)), FBF (1,Psibar,SP,Psi), G_h2uc);
((M (U (-1)),O HH,M (U 3)), FBF (1,Psibar,SP,Psi), G_h2ut);
((M (U (-1)),O HA,M (U 2)), FBF (1,Psibar,SP,Psi), G_h3uc);
((M (U (-1)),O HA,M (U 3)), FBF (1,Psibar,SP,Psi), G_h3ut);
((M (U (-2)),O HH,M (U 1)), FBF (1,Psibar,SP,Psi), G_h2cu);
((M (U (-2)),O HH,M (U 3)), FBF (1,Psibar,SP,Psi), G_h2ct);
((M (U (-2)),O HA,M (U 1)), FBF (1,Psibar,SP,Psi), G_h3cu);
((M (U (-2)),O HA,M (U 3)), FBF (1,Psibar,SP,Psi), G_h3ct);
((M (U (-3)),O Hh,M (U 1)), FBF (1,Psibar,SP,Psi), G_h1tu);
((M (U (-3)),O Hh,M (U 2)), FBF (1,Psibar,SP,Psi), G_h1tc);
((M (U (-3)),O HH,M (U 1)), FBF (1,Psibar,SP,Psi), G_h2tu);
((M (U (-3)),O HH,M (U 2)), FBF (1,Psibar,SP,Psi), G_h2tc);
((M (U (-3)),O HA,M (U 1)), FBF (1,Psibar,SP,Psi), G_h3tu);
((M (U (-3)),O HA,M (U 2)), FBF (1,Psibar,SP,Psi), G_h3tc);
((M (D (-1)),O Hh,M (D 2)), FBF (1,Psibar,SP,Psi), G_h1ds);
((M (D (-1)),O Hh,M (D 3)), FBF (1,Psibar,SP,Psi), G_h1db);
((M (D (-1)),O HH,M (D 2)), FBF (1,Psibar,SP,Psi), G_h2ds);
((M (D (-1)),O HH,M (D 3)), FBF (1,Psibar,SP,Psi), G_h2db);
((M (D (-1)),O HA,M (D 2)), FBF (1,Psibar,SP,Psi), G_h3ds);
((M (D (-1)),O HA,M (D 3)), FBF (1,Psibar,SP,Psi), G_h3db);
((M (D (-2)),O Hh,M (D 1)), FBF (1,Psibar,SP,Psi), G_h1sd);
((M (D (-2)),O Hh,M (D 3)), FBF (1,Psibar,SP,Psi), G_h1sb);
((M (D (-2)),O HH,M (D 1)), FBF (1,Psibar,SP,Psi), G_h2sd);
((M (D (-2)),O HH,M (D 3)), FBF (1,Psibar,SP,Psi), G_h2sb);
((M (D (-2)),O HA,M (D 1)), FBF (1,Psibar,SP,Psi), G_h3sd);
(*i ((M (N (-1)),O Hp,M (L 2)), FBF (1,Psibar,SR,Psi), G_hn1e2);
((M (N (-1)),O Hp,M (L 3)), FBF (1,Psibar,SR,Psi), G_hn1e3);
((M (N (-2)),O Hp,M (L 1)), FBF (1,Psibar,SR,Psi), G_hn2e1);
((M (N (-2)),O Hp,M (L 3)), FBF (1,Psibar,SR,Psi), G_hn2e3);
((M (N (-3)),O Hp,M (L 1)), FBF (1,Psibar,SR,Psi), G_hn3e1);
((M (N (-3)),O Hp,M (L 2)), FBF (1,Psibar,SR,Psi), G_hn3e2);
((M (L (-1)),O Hm,M (N 2)), FBF (1,Psibar,SL,Psi), G_he1n2);
((M (L (-1)),O Hm,M (N 3)), FBF (1,Psibar,SL,Psi), G_he1n3);
((M (L (-2)),O Hm,M (N 1)), FBF (1,Psibar,SL,Psi), G_he2n1);
((M (L (-2)),O Hm,M (N 3)), FBF (1,Psibar,SL,Psi), G_he2n3);
((M (L (-3)),O Hm,M (N 1)), FBF (1,Psibar,SL,Psi), G_he3n1);
((M (L (-3)),O Hm,M (N 2)), FBF (1,Psibar,SL,Psi), G_he3n2); i*)
((M (L (-1)),O Hh,M (L 2)), FBF (1,Psibar,SP,Psi), G_h1e1e2);
((M (L (-1)),O Hh,M (L 3)), FBF (1,Psibar,SP,Psi), G_h1e1e3);
((M (L (-1)),O HH,M (L 2)), FBF (1,Psibar,SP,Psi), G_h2e1e2);
((M (L (-1)),O HH,M (L 3)), FBF (1,Psibar,SP,Psi), G_h2e1e3);
((M (L (-1)),O HA,M (L 2)), FBF (1,Psibar,SP,Psi), G_h3e1e2);
((M (L (-1)),O HA,M (L 3)), FBF (1,Psibar,SP,Psi), G_h3e1e3);
((M (L (-2)),O Hh,M (L 1)), FBF (1,Psibar,SP,Psi), G_h1e2e1);
((M (L (-2)),O Hh,M (L 3)), FBF (1,Psibar,SP,Psi), G_h1e2e3);
((M (L (-2)),O HH,M (L 1)), FBF (1,Psibar,SP,Psi), G_h2e2e1);
((M (L (-2)),O HH,M (L 3)), FBF (1,Psibar,SP,Psi), G_h2e2e3);
((M (L (-2)),O HA,M (L 1)), FBF (1,Psibar,SP,Psi), G_h3e2e1);
((M (L (-2)),O HA,M (L 3)), FBF (1,Psibar,SP,Psi), G_h3e2e3);
((M (L (-3)),O Hh,M (L 1)), FBF (1,Psibar,SP,Psi), G_h1e3e1);
((M (L (-3)),O Hh,M (L 2)), FBF (1,Psibar,SP,Psi), G_h1e3e2);
((M (L (-3)),O HH,M (L 1)), FBF (1,Psibar,SP,Psi), G_h2e3e1);
((M (L (-3)),O HH,M (L 2)), FBF (1,Psibar,SP,Psi), G_h2e3e2);
((M (L (-3)),O HA,M (L 1)), FBF (1,Psibar,SP,Psi), G_h3e3e1);
((M (L (-3)),O HA,M (L 2)), FBF (1,Psibar,SP,Psi), G_h3e3e2) ]
else
[]
(* \begin{equation}
\mathcal{L}_{\textrm{TGC}} =
- e \partial_\mu A_\nu W_+^\mu W_-^\nu + \ldots
- e \cot\theta_w \partial_\mu Z_\nu W_+^\mu W_-^\nu + \ldots
\end{equation} *)
let tgc ((g1, g2, g3), t, c) = ((G g1, G g2, G g3), t, c)
let triple_gauge =
List.map tgc
[ ((Ga, Wm, Wp), Gauge_Gauge_Gauge 1, I_Q_W);
((Z, Wm, Wp), Gauge_Gauge_Gauge 1, I_G_ZWW);
((Gl, Gl, Gl), Gauge_Gauge_Gauge 1, I_Gs) ]
(* \begin{equation}
\mathcal{L}_{\textrm{QGC}} =
- g^2 W_{+,\mu} W_{-,\nu} W_+^\mu W_-^\nu + \ldots
\end{equation} *)
(* Actually, quartic gauge couplings are a little bit more straightforward
using auxiliary fields. Here we have to impose the antisymmetry manually:
\begin{subequations}
\begin{multline}
(W^{+,\mu}_1 W^{-,\nu}_2 - W^{+,\nu}_1 W^{-,\mu}_2)
(W^+_{3,\mu} W^-_{4,\nu} - W^+_{3,\nu} W^-_{4,\mu}) \\
= 2(W^+_1W^+_3)(W^-_2W^-_4) - 2(W^+_1W^-_4)(W^-_2W^+_3)
\end{multline}
also ($V$ can be $A$ or $Z$)
\begin{multline}
(W^{+,\mu}_1 V^\nu_2 - W^{+,\nu}_1 V^\mu_2)
(W^-_{3,\mu} V_{4,\nu} - W^-_{3,\nu} V_{4,\mu}) \\
= 2(W^+_1W^-_3)(V_2V_4) - 2(W^+_1V_4)(V_2W^-_3)
\end{multline}
\end{subequations} *)
(* \begin{subequations}
\begin{multline}
W^{+,\mu} W^{-,\nu} W^+_\mu W^-_\nu
\end{multline}
\end{subequations} *)
let qgc ((g1, g2, g3, g4), t, c) = ((G g1, G g2, G g3, G g4), t, c)
let gauge4 = Vector4 [(2, C_13_42); (-1, C_12_34); (-1, C_14_23)]
let minus_gauge4 = Vector4 [(-2, C_13_42); (1, C_12_34); (1, C_14_23)]
let quartic_gauge =
List.map qgc
[ (Wm, Wp, Wm, Wp), gauge4, G_WWWW;
(Wm, Z, Wp, Z), minus_gauge4, G_ZZWW;
(Wm, Z, Wp, Ga), minus_gauge4, G_AZWW;
(Wm, Ga, Wp, Ga), minus_gauge4, G_AAWW;
(Gl, Gl, Gl, Gl), gauge4, G2]
let gauge_higgs =
[ (G Ga, O Hp, O Hm), Vector_Scalar_Scalar 1, G_AHpHm;
(G Z, O Hp, O Hm), Vector_Scalar_Scalar 1, G_ZHpHm;
(G Z, O Hh, O HH), Vector_Scalar_Scalar 1, G_Zh1h2;
(G Z, O Hh, O HA), Vector_Scalar_Scalar 1, G_Zh1h3;
(G Z, O HH, O HA), Vector_Scalar_Scalar 1, G_Zh2h3;
(G Wp, O Hm, O Hh), Vector_Scalar_Scalar 1, G_WpHmh1;
(G Wp, O Hm, O HH), Vector_Scalar_Scalar 1, G_WpHmh2;
(G Wp, O Hm, O HA), Vector_Scalar_Scalar 1, G_WpHmh3;
(G Wm, O Hp, O Hh), Vector_Scalar_Scalar 1, G_WmHph1;
(G Wm, O Hp, O HH), Vector_Scalar_Scalar 1, G_WmHph2;
(G Wm, O Hp, O HA), Vector_Scalar_Scalar 1, G_WmHph3;
(O Hh, G Z, G Z), Scalar_Vector_Vector 1, G_h1ZZ;
(O HH, G Z, G Z), Scalar_Vector_Vector 1, G_h2ZZ;
(O HA, G Z, G Z), Scalar_Vector_Vector 1, G_h3ZZ;
(O Hh, G Wp, G Wm), Scalar_Vector_Vector 1, G_h1WpWm;
(O HH, G Wp, G Wm), Scalar_Vector_Vector 1, G_h2WpWm;
(O HA, G Wp, G Wm), Scalar_Vector_Vector 1, G_h3WpWm ]
let gauge_higgs4 =
[ (O Hh, O Hh, G Wp, G Wm), Scalar2_Vector2 1, G_hhWpWm;
(O HH, O HH, G Wp, G Wm), Scalar2_Vector2 1, G_hhWpWm;
(O HA, O HA, G Wp, G Wm), Scalar2_Vector2 1, G_hhWpWm;
(O Hh, O Hh, G Z, G Z), Scalar2_Vector2 1, G_hhZZ;
(O HH, O HH, G Z, G Z), Scalar2_Vector2 1, G_hhZZ;
(O HA, O HA, G Z, G Z), Scalar2_Vector2 1, G_hhZZ;
(O Hp, O Hm, G Ga, G Ga), Scalar2_Vector2 1, G_HpHmAA;
(O Hp, O Hm, G Z, G Z), Scalar2_Vector2 1, G_HpHmZZ;
(O Hp, O Hm, G Ga, G Z), Scalar2_Vector2 1, G_HpHmAZ;
(O Hp, O Hm, G Wp, G Wm), Scalar2_Vector2 1, G_HpHmWpWm;
(O Hh, O Hp, G Ga, G Wm), Scalar2_Vector2 1, G_h1HpAWm;
(O HH, O Hp, G Ga, G Wm), Scalar2_Vector2 1, G_h2HpAWm;
(O HA, O Hp, G Ga, G Wm), Scalar2_Vector2 1, G_h3HpAWm;
(O Hh, O Hp, G Z, G Wm), Scalar2_Vector2 1, G_h1HpZWm;
(O HH, O Hp, G Z, G Wm), Scalar2_Vector2 1, G_h2HpZWm;
(O HA, O Hp, G Z, G Wm), Scalar2_Vector2 1, G_h3HpZWm;
(O Hh, O Hm, G Ga, G Wp), Scalar2_Vector2 1, G_h1HpAWmC;
(O HH, O Hm, G Ga, G Wp), Scalar2_Vector2 1, G_h2HpAWmC;
(O HA, O Hm, G Ga, G Wp), Scalar2_Vector2 1, G_h3HpAWmC;
(O Hh, O Hm, G Z, G Wp), Scalar2_Vector2 1, G_h1HpZWmC;
(O HH, O Hm, G Z, G Wp), Scalar2_Vector2 1, G_h2HpZWmC;
(O HA, O Hm, G Z, G Wp), Scalar2_Vector2 1, G_h3HpZWmC ]
let higgs =
[ (O Hh, O Hp, O Hm), Scalar_Scalar_Scalar 1, G_h1HpHm;
(O HH, O Hp, O Hm), Scalar_Scalar_Scalar 1, G_h2HpHm;
(O HA, O Hp, O Hm), Scalar_Scalar_Scalar 1, G_h3HpHm;
(O Hh, O Hh, O Hh), Scalar_Scalar_Scalar 1, G_h111;
(O Hh, O Hh, O HH), Scalar_Scalar_Scalar 1, G_h112;
(O Hh, O Hh, O HA), Scalar_Scalar_Scalar 1, G_h113;
(O HH, O HH, O Hh), Scalar_Scalar_Scalar 1, G_h221;
(O HH, O HH, O HH), Scalar_Scalar_Scalar 1, G_h222;
(O HH, O HH, O HA), Scalar_Scalar_Scalar 1, G_h223;
(O HA, O HA, O Hh), Scalar_Scalar_Scalar 1, G_h331;
(O HA, O HA, O HH), Scalar_Scalar_Scalar 1, G_h332;
(O HA, O HA, O HA), Scalar_Scalar_Scalar 1, G_h333;
(O Hh, O HH, O HA), Scalar_Scalar_Scalar 1, G_h123 ]
let higgs4 =
[ (O Hp, O Hm, O Hp, O Hm), Scalar4 1, G_HpHmHpHm;
(O Hp, O Hm, O Hh, O Hh), Scalar4 1, G_HpHm11;
(O Hp, O Hm, O Hh, O HH), Scalar4 1, G_HpHm12;
(O Hp, O Hm, O Hh, O HA), Scalar4 1, G_HpHm13;
(O Hp, O Hm, O HH, O HH), Scalar4 1, G_HpHm22;
(O Hp, O Hm, O HH, O HA), Scalar4 1, G_HpHm23;
(O Hp, O Hm, O HA, O HA), Scalar4 1, G_HpHm33;
(O Hh, O Hh, O Hh, O Hh), Scalar4 1, G_h1111;
(O Hh, O Hh, O Hh, O HH), Scalar4 1, G_h1112;
(O Hh, O Hh, O Hh, O HA), Scalar4 1, G_h1113;
(O Hh, O Hh, O HH, O HH), Scalar4 1, G_h1122;
(O Hh, O Hh, O HH, O HA), Scalar4 1, G_h1123;
(O Hh, O Hh, O HA, O HA), Scalar4 1, G_h1133;
(O Hh, O HH, O HH, O HH), Scalar4 1, G_h1222;
(O Hh, O HH, O HH, O HA), Scalar4 1, G_h1223;
(O Hh, O HH, O HA, O HA), Scalar4 1, G_h1233;
(O Hh, O HA, O HA, O HA), Scalar4 1, G_h1333;
(O HH, O HH, O HH, O HH), Scalar4 1, G_h2222;
(O HH, O HH, O HH, O HA), Scalar4 1, G_h2223;
(O HH, O HH, O HA, O HA), Scalar4 1, G_h2233;
(O HH, O HA, O HA, O HA), Scalar4 1, G_h2333;
(O HA, O HA, O HA, O HA), Scalar4 1, G_h3333 ]
let goldstone_vertices =
[ ((O Phi0, G Wm, G Wp), Scalar_Vector_Vector 1, I_G_ZWW);
((O Phip, G Ga, G Wm), Scalar_Vector_Vector 1, I_Q_W);
((O Phip, G Z, G Wm), Scalar_Vector_Vector 1, I_G_ZWW);
((O Phim, G Wp, G Ga), Scalar_Vector_Vector 1, I_Q_W);
((O Phim, G Wp, G Z), Scalar_Vector_Vector 1, I_G_ZWW) ]
let vertices3 =
(ThoList.flatmap electromagnetic_currents [1;2;3] @
ThoList.flatmap color_currents [1;2;3] @
ThoList.flatmap neutral_currents [1;2;3] @
ThoList.flatmap charged_currents [1;2;3] @
yukawa @ triple_gauge @
gauge_higgs @ higgs @ goldstone_vertices)
let vertices4 =
quartic_gauge @ gauge_higgs4 @ higgs4
let vertices () = (vertices3, vertices4, [])
(* For efficiency, make sure that [F.of_vertices vertices] is
evaluated only once. *)
let table = F.of_vertices (vertices ())
let fuse2 = F.fuse2 table
let fuse3 = F.fuse3 table
let fuse = F.fuse table
let max_degree () = 4
let flavor_of_string = function
| "e-" -> M (L 1) | "e+" -> M (L (-1))
| "mu-" -> M (L 2) | "mu+" -> M (L (-2))
| "tau-" -> M (L 3) | "tau+" -> M (L (-3))
| "nue" -> M (N 1) | "nuebar" -> M (N (-1))
| "numu" -> M (N 2) | "numubar" -> M (N (-2))
| "nutau" -> M (N 3) | "nutaubar" -> M (N (-3))
| "u" -> M (U 1) | "ubar" -> M (U (-1))
| "c" -> M (U 2) | "cbar" -> M (U (-2))
| "t" -> M (U 3) | "tbar" -> M (U (-3))
| "d" -> M (D 1) | "dbar" -> M (D (-1))
| "s" -> M (D 2) | "sbar" -> M (D (-2))
| "b" -> M (D 3) | "bbar" -> M (D (-3))
| "g" -> G Gl
| "A" -> G Ga | "Z" | "Z0" -> G Z
| "W+" -> G Wp | "W-" -> G Wm
| "h0" -> O Hh
| "H0" -> O HH
| "A0" -> O HA
| "Hp" | "H+" -> O Hp
| "Hm" | "H-" -> O Hm
| _ -> invalid_arg "Modellib_BSM.TwoHiggsDoublet.flavor_of_string"
let flavor_to_string = function
| M f ->
begin match f with
| L 1 -> "e-" | L (-1) -> "e+"
| L 2 -> "mu-" | L (-2) -> "mu+"
| L 3 -> "tau-" | L (-3) -> "tau+"
| L _ -> invalid_arg
"Modellib_BSM.TwoHiggsDoublet.flavor_to_string: invalid lepton"
| N 1 -> "nue" | N (-1) -> "nuebar"
| N 2 -> "numu" | N (-2) -> "numubar"
| N 3 -> "nutau" | N (-3) -> "nutaubar"
| N _ -> invalid_arg
"Modellib_BSM.TwoHiggsDoublet.flavor_to_string: invalid neutrino"
| U 1 -> "u" | U (-1) -> "ubar"
| U 2 -> "c" | U (-2) -> "cbar"
| U 3 -> "t" | U (-3) -> "tbar"
| U _ -> invalid_arg
"Modellib_BSM.TwoHiggsDoublet.flavor_to_string: invalid up type quark"
| D 1 -> "d" | D (-1) -> "dbar"
| D 2 -> "s" | D (-2) -> "sbar"
| D 3 -> "b" | D (-3) -> "bbar"
| D _ -> invalid_arg
"Modellib_BSM.TwoHiggsDoublet.flavor_to_string: invalid down type quark"
end
| G f ->
begin match f with
| Gl -> "g"
| Ga -> "A" | Z -> "Z"
| Wp -> "W+" | Wm -> "W-"
end
| O f ->
begin match f with
| Phip -> "phi+" | Phim -> "phi-" | Phi0 -> "phi0"
| Hh -> "h0" | HH -> "H0" | HA -> "A0"
| Hp -> "H+" | Hm -> "H-"
end
let flavor_to_TeX = function
| M f ->
begin match f with
| L 1 -> "e^-" | L (-1) -> "e^+"
| L 2 -> "\\mu^-" | L (-2) -> "\\mu^+"
| L 3 -> "\\tau^-" | L (-3) -> "\\tau^+"
| L _ -> invalid_arg
"Modellib_BSM.TwoHiggsDoublet.flavor_to_TeX: invalid lepton"
| N 1 -> "\\nu_e" | N (-1) -> "\\bar{\\nu}_e"
| N 2 -> "\\nu_\\mu" | N (-2) -> "\\bar{\\nu}_\\mu"
| N 3 -> "\\nu_\\tau" | N (-3) -> "\\bar{\\nu}_\\tau"
| N _ -> invalid_arg
"Modellib_BSM.TwoHiggsDoublet.flavor_to_TeX: invalid neutrino"
| U 1 -> "u" | U (-1) -> "\\bar{u}"
| U 2 -> "c" | U (-2) -> "\\bar{c}"
| U 3 -> "t" | U (-3) -> "\\bar{t}"
| U _ -> invalid_arg
"Modellib_BSM.TwoHiggsDoublet.flavor_to_TeX: invalid up type quark"
| D 1 -> "d" | D (-1) -> "\\bar{d}"
| D 2 -> "s" | D (-2) -> "\\bar{s}"
| D 3 -> "b" | D (-3) -> "\\bar{b}"
| D _ -> invalid_arg
"Modellib_BSM.TwoHiggsDoublet.flavor_to_TeX: invalid down type quark"
end
| G f ->
begin match f with
| Gl -> "g"
| Ga -> "\\gamma" | Z -> "Z"
| Wp -> "W^+" | Wm -> "W^-"
end
| O f ->
begin match f with
| Phip -> "\\phi^+" | Phim -> "\\phi^-" | Phi0 -> "\\phi^0"
| Hh -> "h^0" | HH -> "H^0" | HA -> "A^0"
| Hp -> "H^+" | Hm -> "H^-"
end
let flavor_symbol = function
| M f ->
begin match f with
| L n when n > 0 -> "l" ^ string_of_int n
| L n -> "l" ^ string_of_int (abs n) ^ "b"
| N n when n > 0 -> "n" ^ string_of_int n
| N n -> "n" ^ string_of_int (abs n) ^ "b"
| U n when n > 0 -> "u" ^ string_of_int n
| U n -> "u" ^ string_of_int (abs n) ^ "b"
| D n when n > 0 -> "d" ^ string_of_int n
| D n -> "d" ^ string_of_int (abs n) ^ "b"
end
| G f ->
begin match f with
| Gl -> "gl"
| Ga -> "a" | Z -> "z"
| Wp -> "wp" | Wm -> "wm"
end
| O f ->
begin match f with
| Phip -> "pp" | Phim -> "pm" | Phi0 -> "p0"
| Hh -> "h" | HH -> "h0" | HA -> "a0"
| Hp -> "hp" | Hm -> "hm"
end
let pdg = function
| M f ->
begin match f with
| L n when n > 0 -> 9 + 2*n
| L n -> - 9 + 2*n
| N n when n > 0 -> 10 + 2*n
| N n -> - 10 + 2*n
| U n when n > 0 -> 2*n
| U n -> 2*n
| D n when n > 0 -> - 1 + 2*n
| D n -> 1 + 2*n
end
| G f ->
begin match f with
| Gl -> 21
| Ga -> 22 | Z -> 23
| Wp -> 24 | Wm -> (-24)
end
| O f ->
begin match f with
| Phip -> 27 | Phim -> -27 | Phi0 -> 26
| Hh -> 25
| HH -> 35
| HA -> 36
| Hp -> 37
| Hm -> -37
end
let mass_symbol f =
"mass(" ^ string_of_int (abs (pdg f)) ^ ")"
let width_symbol f =
"width(" ^ string_of_int (abs (pdg f)) ^ ")"
let constant_symbol = function
| Unit -> "unit" | Pi -> "PI"
| Alpha_QED -> "alpha" | E -> "e" | G_weak -> "g" | Vev -> "vev"
| Sin2thw -> "sin2thw" | Sinthw -> "sinthw" | Costhw -> "costhw"
| Q_lepton -> "qlep" | Q_up -> "qup" | Q_down -> "qdwn"
| G_NC_lepton -> "gnclep" | G_NC_neutrino -> "gncneu"
| G_NC_up -> "gncup" | G_NC_down -> "gncdwn"
| G_CC -> "gcc"
| I_Q_W -> "iqw" | I_G_ZWW -> "igzww" | I_G_WWW -> "igwww"
| G_WWWW -> "gw4" | G_ZZWW -> "gzzww"
| G_AZWW -> "gazww" | G_AAWW -> "gaaww"
| G_htt -> "ghtt" | G_hbb -> "ghbb" | G_hcc -> "ghcc"
| G_Htt -> "gh0tt" | G_Hbb -> "gh0bb" | G_Hcc -> "gh0cc"
| I_G_Att -> "iga0tt" | I_G_Abb -> "iga0bb" | I_G_Acc -> "iga0cc"
| G_htautau -> "ghtautau" | G_hmumu -> "ghmumu"
| G_Htautau -> "gh0tautau" | G_Hmumu -> "gh0mumu"
| I_G_Atautau -> "iga0tautau" | I_G_Amumu -> "iga0mumu"
| G_Htb -> "ghptb" | G_Hcs -> "ghpcs"
| G_Htaunu -> "ghptaunu" | G_Hmunu -> "ghpmunu"
| Gs -> "gs" | I_Gs -> "igs" | G2 -> "gs**2"
| G_AHpHm -> "gAHpHm" | G_ZHpHm -> "gZHpHm"
| G_Zh1h2 -> "gZh1h2" | G_Zh1h3 -> "gZh1h3"
| G_Zh2h3 -> "gZh2h3" | G_WpHmh1 -> "gWpHmh1"
| G_WpHmh2 -> "gWpHmh2" | G_WpHmh3 -> "gWpHmh3"
| G_WmHph1 -> "gWmHph1" | G_WmHph2 -> "gWmHph2"
| G_WmHph3 -> "gWmHph3" | G_h1ZZ -> "gh1ZZ"
| G_h2ZZ -> "gh2ZZ" | G_h3ZZ -> "gh3ZZ"
| G_h1WpWm -> "gh1WpWm" | G_h2WpWm -> "gh2WpWm"
| G_h3WpWm -> "gh3WpWm" | G_hhWpWm -> "ghhWpWm"
| G_hhZZ -> "ghhZZ" | G_HpHmAA -> "gHpHmAA"
| G_HpHmZZ -> "gHpHmZZ" | G_HpHmAZ -> "gHpHmAZ"
| G_HpHmWpWm -> "gHpHmWpWm" | G_h1HpAWm -> "gh1HpAWm"
| G_h2HpAWm -> "gh2HpAWm" | G_h3HpAWm -> "gh3HpAWm"
| G_h1HpZWm -> "gh1HpZWm" | G_h2HpZWm -> "gh2HpZWm"
| G_h3HpZWm -> "gh3HpZWm" | G_h1HpAWmC -> "gh1HpAWmC"
| G_h2HpAWmC -> "gh2HpAWmC" | G_h3HpAWmC -> "gh3HpAWmC"
| G_h1HpZWmC -> "gh1HpZWmC" | G_h2HpZWmC -> "gh2HpZWmC"
| G_h3HpZWmC -> "gh3HpZWmC" | G_h1HpHm -> "gh1HpHm"
| G_h2HpHm -> "gh2HpHm" | G_h3HpHm -> "gh3HpHm"
| G_h111 -> "gh111" | G_h112 -> "gh112" | G_h113 -> "gh113"
| G_h221 -> "gh221" | G_h222 -> "gh222" | G_h223 -> "gh223"
| G_h331 -> "gh331" | G_h332 -> "gh332"
| G_h333 -> "gh333" | G_h123 -> "gh123"
| G_HpHmHpHm -> "gHpHmHpHm" | G_HpHm11 -> "gHpHm11"
| G_HpHm12 -> "gHpHm12" | G_HpHm13 -> "gHpHm13"
| G_HpHm22 -> "gHpHm22" | G_HpHm23 -> "gHpHm23"
| G_HpHm33 -> "gHpHm33" | G_h1111 -> "gh1111"
| G_h1112 -> "gh1112" | G_h1113 -> "gh1113"
| G_h1122 -> "gh1122" | G_h1123 -> "gh1123"
| G_h1133 -> "gh1133" | G_h1222 -> "gh1222"
| G_h1223 -> "gh1223" | G_h1233 -> "gh1233"
| G_h1333 -> "gh1333" | G_h2222 -> "gh2222"
| G_h2223 -> "gh2223" | G_h2233 -> "gh2233"
| G_h2333 -> "gh2333" | G_h3333 -> "gh3333"
| G_h1uu -> "gh1uu" | G_h2uu -> "gh2uu"
| G_h3uu -> "gh3uu" | G_h1uc -> "gh1uc"
| G_h2uc -> "gh2uc" | G_h3uc -> "gh3uc"
| G_h1ut -> "gh1ut" | G_h2ut -> "gh2ut"
| G_h3ut -> "gh3ut" | G_h1cu -> "gh1cu"
| G_h2cu -> "gh2cu" | G_h3cu -> "gh3cu"
| G_h1cc -> "gh1cc" | G_h2cc -> "gh2cc"
| G_h3cc -> "gh3cc" | G_h1ct -> "gh1ct"
| G_h2ct -> "gh2ct" | G_h3ct -> "gh3ct"
| G_h1tu -> "gh1tu" | G_h2tu -> "gh2tu"
| G_h3tu -> "gh3tu" | G_h1tc -> "gh1tc"
| G_h2tc -> "gh2tc" | G_h3tc -> "gh3tc"
| G_h1tt -> "gh1tt" | G_h2tt -> "gh2tt"
| G_h3tt -> "gh3tt"
| G_h1dd -> "gh1dd" | G_h2dd -> "gh2dd"
| G_h3dd -> "gh3dd" | G_h1ds -> "gh1ds"
| G_h2ds -> "gh2ds" | G_h3ds -> "gh3ds"
| G_h1db -> "gh1db" | G_h2db -> "gh2db"
| G_h3db -> "gh3db" | G_h1sd -> "gh1sd"
| G_h2sd -> "gh2sd" | G_h3sd -> "gh3sd"
| G_h1ss -> "gh1ss" | G_h2ss -> "gh2ss"
| G_h3ss -> "gh3ss" | G_h1sb -> "gh1sb"
| G_h2sb -> "gh2sb" | G_h3sb -> "gh3sb"
| G_h1bd -> "gh1bd" | G_h2bd -> "gh2bd"
| G_h3bd -> "gh3bd" | G_h1bs -> "gh1bs"
| G_h2bs -> "gh2bs" | G_h3bs -> "gh3bs"
| G_h1bb -> "gh1bb" | G_h2bb -> "gh2bb"
| G_h3bb -> "gh3bb"
| G_hud -> "ghud" | G_hus -> "ghus"
| G_hub -> "ghub" | G_hcd -> "ghcd"
| G_hcs -> "ghcs" | G_hcb -> "ghcb"
| G_htd -> "ghtd" | G_hts -> "ghts"
| G_htb -> "ghtb"
| G_hdu -> "ghdu" | G_hdc -> "ghdc"
| G_hdt -> "ghdt" | G_hsu -> "ghsu"
| G_hsc -> "ghsc" | G_hst -> "ghst"
| G_hbu -> "ghbu" | G_hbc -> "ghbc"
| G_hbt -> "ghbt"
| G_he1n1 -> "ghe1n1" | G_he1n2 -> "ghe1n2"
| G_he1n3 -> "ghe1n3" | G_he2n1 -> "ghe2n1"
| G_he2n2 -> "ghe2n2" | G_he2n3 -> "ghe2n3"
| G_he3n1 -> "ghe3n1" | G_he3n2 -> "ghe3n2"
| G_he3n3 -> "ghe3n3" | G_hn1e1 -> "ghn1e1"
| G_hn1e2 -> "ghn1e2" | G_hn1e3 -> "ghn1e3"
| G_hn2e1 -> "ghn2e1" | G_hn2e2 -> "ghn2e2"
| G_hn2e3 -> "ghn2e3" | G_hn3e1 -> "ghn3e1"
| G_hn3e2 -> "ghn3e2" | G_hn3e3 -> "ghn3e3"
| G_h1e1e1 -> "gh1e1e1" | G_h2e1e1 -> "gh2e1e1"
| G_h3e1e1 -> "gh3e1e1" | G_h1e1e2 -> "gh1e1e2"
| G_h2e1e2 -> "gh2e1e2" | G_h3e1e2 -> "gh3e1e2"
| G_h1e1e3 -> "gh1e1e3" | G_h2e1e3 -> "gh2e1e3"
| G_h3e1e3 -> "gh3e1e3" | G_h1e2e1 -> "gh1e2e1"
| G_h2e2e1 -> "gh2e2e1" | G_h3e2e1 -> "gh3e2e1"
| G_h1e2e2 -> "gh1e2e2" | G_h2e2e2 -> "gh2e2e2"
| G_h3e2e2 -> "gh3e2e2" | G_h1e2e3 -> "gh1e2e3"
| G_h2e2e3 -> "gh2e2e3" | G_h3e2e3 -> "gh3e2e3"
| G_h1e3e1 -> "gh1e3e1" | G_h2e3e1 -> "gh2e3e1"
| G_h3e3e1 -> "gh3e3e1" | G_h1e3e2 -> "gh1e3e2"
| G_h2e3e2 -> "gh2e3e2" | G_h3e3e2 -> "gh3e3e2"
| G_h1e3e3 -> "gh1e3e3" | G_h2e3e3 -> "gh2e3e3"
| G_h3e3e3 -> "gh3e3e3"
| Mass f -> "mass" ^ flavor_symbol f
| Width f -> "width" ^ flavor_symbol f
end
module type SSC_flags =
sig
val higgs_triangle : bool (* $H\gamma\gamma$, $Hg\gamma$ and $Hgg$ couplings *)
val higgs_hmm : bool
val triple_anom : bool
val quartic_anom : bool
val higgs_anom : bool
val k_matrix : bool
val k_matrix_tm : bool
val ckm_present : bool
val top_anom : bool
val top_anom_4f : bool
val cf_arbitrary : bool
val higgs_matrix : bool
end
module SSC_kmatrix: SSC_flags =
struct
let higgs_triangle = false
let higgs_hmm = false
let triple_anom = false
let quartic_anom = true
let higgs_anom = false
let k_matrix = true
let k_matrix_tm = false
let ckm_present = false
let top_anom = false
let top_anom_4f = false
let cf_arbitrary = false
let higgs_matrix = false
end
module SSC_kmatrix_2: SSC_flags =
struct
let higgs_triangle = false
let higgs_hmm = false
let triple_anom = false
let quartic_anom = true
let higgs_anom = false
let k_matrix = true
let k_matrix_tm = true
let ckm_present = false
let top_anom = false
let top_anom_4f = false
let cf_arbitrary = true
let higgs_matrix = true
end
(* \thocwmodulesection{Complete Minimal Standard Model including additional Resonances} *)
module SSC (Flags : SSC_flags) =
struct
open Coupling
let default_width = ref Timelike
let use_fudged_width = ref false
let options = Options.create
[ "constant_width", Arg.Unit (fun () -> default_width := Constant),
"use constant width (also in t-channel)";
"fudged_width", Arg.Set use_fudged_width,
"use fudge factor for charge particle width";
"custom_width", Arg.String (fun f -> default_width := Custom f),
"use custom width";
"cancel_widths", Arg.Unit (fun () -> default_width := Vanishing),
"use vanishing width";
"cms_width", Arg.Unit (fun () -> default_width := Complex_Mass),
"use complex mass scheme";
"running_width", Arg.Unit (fun () -> default_width := Running),
"use running width"]
let caveats () = []
type f_aux_top = TTGG | TBWA | TBWZ | TTWW | BBWW | (*i top auxiliary field "flavors" *)
QGUG | QBUB | QW | DL | DR
type matter_field = L of int | N of int | U of int | D of int
type gauge_boson = Ga | Wp | Wm | Z | Gl
type other = Phip | Phim | Phi0 | H
| Rsigma | Rphin | Rphisn | Rphip | Rphim | Rphipp | Rphimm
| Rf | Rtn | Rtsn | Rtp | Rtm | Rtpp | Rtmm
| Aux_top of int*int*int*bool*f_aux_top (*i lorentz*color*charge*top-side*flavor *)
type flavor = M of matter_field | G of gauge_boson | O of other
let matter_field f = M f
let gauge_boson f = G f
let other f = O f
type field =
| Matter of matter_field
| Gauge of gauge_boson
| Other of other
let field = function
| M f -> Matter f
| G f -> Gauge f
| O f -> Other f
type gauge = unit
let gauge_symbol () =
failwith "Modellib_BSM.SSC.gauge_symbol: internal error"
let family n = List.map matter_field [ L n; N n; U n; D n ]
let rec aux_top_flavors (f,l,co,ch) = List.append
( List.map other [ Aux_top(l,co,ch/2,true,f); Aux_top(l,co,ch/2,false,f) ] )
( if ch > 1 then List.append
( List.map other [ Aux_top(l,co,-ch/2,true,f); Aux_top(l,co,-ch/2,false,f) ] )
( aux_top_flavors (f,l,co,(ch-2)) )
else [] )
let external_flavors () =
[ "1st Generation", ThoList.flatmap family [1; -1];
"2nd Generation", ThoList.flatmap family [2; -2];
"3rd Generation", ThoList.flatmap family [3; -3];
"Gauge Bosons", List.map gauge_boson [Ga; Z; Wp; Wm; Gl];
"Higgs", List.map other [H];
"Scalar Resonances", List.map other [Rsigma; Rphin; Rphisn; Rphip; Rphim; Rphipp; Rphimm];
"Tensor Resonances", List.map other [Rf; Rtn; Rtsn; Rtp; Rtm; Rtpp; Rtmm];
"Goldstone Bosons", List.map other [Phip; Phim; Phi0] ]
let flavors () = List.append
( ThoList.flatmap snd (external_flavors ()) )
( ThoList.flatmap aux_top_flavors
[ (TTGG,2,1,1); (TBWA,2,0,2); (TBWZ,2,0,2); (TTWW,2,0,1); (BBWW,2,0,1);
(QGUG,1,1,1); (QBUB,1,0,1); (QW,1,0,3); (DL,0,0,3); (DR,0,0,3) ] )
let spinor n =
if n >= 0 then
Spinor
else
ConjSpinor
let lorentz_aux = function
| 2 -> Tensor_1
| 1 -> Vector
| 0 -> Scalar
| _ -> invalid_arg ("SM.lorentz_aux: wrong value")
let lorentz = function
| M f ->
begin match f with
| L n -> spinor n | N n -> spinor n
| U n -> spinor n | D n -> spinor n
end
| G f ->
begin match f with
| Ga | Gl -> Vector
| Wp | Wm | Z -> Massive_Vector
end
| O f ->
begin match f with
| Aux_top (l,_,_,_,_) -> lorentz_aux l
| Rf | Rtn | Rtsn | Rtp | Rtm | Rtpp | Rtmm -> Tensor_2
| _ -> Scalar
end
- let color = function
+ let color = function
| M (U n) -> Color.SUN (if n > 0 then 3 else -3)
| M (D n) -> Color.SUN (if n > 0 then 3 else -3)
| G Gl -> Color.AdjSUN 3
| O (Aux_top (_,co,_,_,_)) -> if co == 0 then Color.Singlet else Color.AdjSUN 3
| _ -> Color.Singlet
let nc () = 3
let prop_spinor n =
if n >= 0 then
Prop_Spinor
else
Prop_ConjSpinor
let prop_aux = function
| 2 -> Aux_Tensor_1
| 1 -> Aux_Vector
| 0 -> Aux_Scalar
| _ -> invalid_arg ("SM.prop_aux: wrong value")
let propagator = function
| M f ->
begin match f with
| L n -> prop_spinor n | N n -> prop_spinor n
| U n -> prop_spinor n | D n -> prop_spinor n
end
| G f ->
begin match f with
| Ga | Gl -> Prop_Feynman
| Wp | Wm | Z -> Prop_Unitarity
end
| O f ->
begin match f with
| Phip | Phim | Phi0 -> Only_Insertion
| H | Rsigma -> Prop_Scalar
| Rphin | Rphisn | Rphip | Rphim | Rphipp | Rphimm -> Prop_Scalar
| Rf -> Prop_Tensor_2
| Rtn | Rtsn | Rtp | Rtm | Rtpp | Rtmm -> Prop_Tensor_2
| Aux_top (l,_,_,_,_) -> prop_aux l
end
(* Optionally, ask for the fudge factor treatment for the widths of
charged particles. Currently, this only applies to $W^\pm$ and top. *)
let width f =
if !use_fudged_width then
match f with
| G Wp | G Wm | M (U 3) | M (U (-3)) -> Fudged
| _ -> !default_width
else
!default_width
let goldstone = function
| G f ->
begin match f with
| Wp -> Some (O Phip, Coupling.Integer 1)
| Wm -> Some (O Phim, Coupling.Integer 1)
| Z -> Some (O Phi0, Coupling.Integer 1)
| _ -> None
end
| _ -> None
let conjugate = function
| M f ->
M (begin match f with
| L n -> L (-n) | N n -> N (-n)
| U n -> U (-n) | D n -> D (-n)
end)
| G f ->
G (begin match f with
| Gl -> Gl | Ga -> Ga | Z -> Z
| Wp -> Wm | Wm -> Wp
end)
| O f ->
O (begin match f with
| Phip -> Phim | Phim -> Phip | Phi0 -> Phi0
| H -> H | Rsigma -> Rsigma
| Rphin -> Rphin | Rphisn-> Rphisn | Rphip -> Rphim | Rphim -> Rphip
| Rphipp -> Rphimm | Rphimm -> Rphipp
| Rf -> Rf
| Rtn -> Rtn | Rtsn -> Rtsn | Rtp -> Rtm | Rtm -> Rtp
| Rtpp -> Rtmm | Rtmm -> Rtpp
| Aux_top (l,co,ch,n,f) -> Aux_top (l,co,(-ch),(not n),f)
end)
let fermion = function
| M f ->
begin match f with
| L n -> if n > 0 then 1 else -1
| N n -> if n > 0 then 1 else -1
| U n -> if n > 0 then 1 else -1
| D n -> if n > 0 then 1 else -1
end
| G f ->
begin match f with
| Gl | Ga | Z | Wp | Wm -> 0
end
| O _ -> 0
(* Electrical charge, lepton number, baryon number. We could avoid the
rationals altogether by multiplying the first and last by 3 \ldots *)
module Ch = Charges.QQ
let ( // ) = Algebra.Small_Rational.make
let generation' = function
| 1 -> [ 1//1; 0//1; 0//1]
| 2 -> [ 0//1; 1//1; 0//1]
| 3 -> [ 0//1; 0//1; 1//1]
| -1 -> [-1//1; 0//1; 0//1]
| -2 -> [ 0//1; -1//1; 0//1]
| -3 -> [ 0//1; 0//1; -1//1]
| n -> invalid_arg ("SM.generation': " ^ string_of_int n)
let generation f =
if Flags.ckm_present then
[]
else
match f with
| M (L n | N n | U n | D n) -> generation' n
| G _ | O _ -> [0//1; 0//1; 0//1]
let charge = function
| M f ->
begin match f with
| L n -> if n > 0 then -1//1 else 1//1
| N n -> 0//1
| U n -> if n > 0 then 2//3 else -2//3
| D n -> if n > 0 then -1//3 else 1//3
end
| G f ->
begin match f with
| Gl | Ga | Z -> 0//1
| Wp -> 1//1
| Wm -> -1//1
end
| O f ->
begin match f with
| H | Rsigma | Phi0 | Rphin | Rphisn
| Rf | Rtn | Rtsn -> 0//1
| Phip | Rphip | Rtp -> 1//1
| Phim | Rphim | Rtm -> -1//1
| Rphipp | Rtpp -> 2//1
| Rphimm | Rtmm -> -2//1
| Aux_top (_,_,ch,_,_) -> ch//1
end
let lepton = function
| M f ->
begin match f with
| L n | N n -> if n > 0 then 1//1 else -1//1
| U _ | D _ -> 0//1
end
| G _ | O _ -> 0//1
let baryon = function
| M f ->
begin match f with
| L _ | N _ -> 0//1
| U n | D n -> if n > 0 then 1//1 else -1//1
end
| G _ | O _ -> 0//1
let charges f =
[ charge f; lepton f; baryon f] @ generation f
type constant =
| Unit | Half | Pi | Alpha_QED | Sin2thw
| Sinthw | Costhw | E | G_weak | I_G_weak | Vev
| Q_lepton | Q_up | Q_down | G_CC | G_CCQ of int*int
| G_NC_neutrino | G_NC_lepton | G_NC_up | G_NC_down
| G_TVA_ttA | G_TVA_bbA
| G_VLR_ttZ | G_TVA_ttZ | G_TVA_bbZ
| G_VLR_btW | G_VLR_tbW
| G_TLR_btW | G_TRL_tbW
| G_TLR_btWZ | G_TRL_tbWZ
| G_TLR_btWA | G_TRL_tbWA
| G_TVA_ttWW | G_TVA_bbWW
| G_TVA_ttG | G_TVA_ttGG
| G_SP_ttH
| G_VLR_qGuG | G_VLR_qBuB
| G_VLR_qBuB_u | G_VLR_qBuB_d | G_VLR_qBuB_e | G_VL_qBuB_n
| G_VL_qW | G_VL_qW_u | G_VL_qW_d
| G_SL_DttR | G_SR_DttR | G_SL_DttL | G_SLR_DbtR | G_SL_DbtL
| I_Q_W | I_G_ZWW
| G_WWWW | G_ZZWW | G_AZWW | G_AAWW
| I_G1_AWW | I_G1_ZWW
| I_G1_plus_kappa_plus_G4_AWW
| I_G1_plus_kappa_plus_G4_ZWW
| I_G1_plus_kappa_minus_G4_AWW
| I_G1_plus_kappa_minus_G4_ZWW
| I_G1_minus_kappa_plus_G4_AWW
| I_G1_minus_kappa_plus_G4_ZWW
| I_G1_minus_kappa_minus_G4_AWW
| I_G1_minus_kappa_minus_G4_ZWW
| I_lambda_AWW | I_lambda_ZWW
| G5_AWW | G5_ZWW
| I_kappa5_AWW | I_kappa5_ZWW
| I_lambda5_AWW | I_lambda5_ZWW
| FS0_HHWW | FS0_HHZZ
| FS1_HHWW | FS1_HHZZ
| FM0_HHWW | FM0_HHZZ
| FM1_HHWW | FM1_HHZZ
| FM7_HHWW | FM7_HHZZ
| Alpha_WWWW0 | Alpha_ZZWW1 | Alpha_WWWW2
| Alpha_ZZWW0 | Alpha_ZZZZ
| FT0_WWWW0 | FT0_WWWW2
| FT0_ZZWW0 | FT0_ZZWW1
| FT0_ZZZZ | FT0_AAAA
| FT0_AAWW0 | FT0_AAWW1
| FT0_AAZZ
| FT0_AZWW0 | FT0_AZWW1
| FT0_AAAZ | FT0_AZZZ
| FT1_WWWW0 | FT1_WWWW2
| FT1_ZZWW0 | FT1_ZZWW1
| FT1_ZZZZ | FT1_AAAA
| FT1_AAWW0 | FT1_AAWW1
| FT1_AAZZ
| FT1_AZWW0 | FT1_AZWW1
| FT1_AAAZ | FT1_AZZZ
| FT2_WWWW0 | FT2_WWWW2
| FT2_ZZWW0 | FT2_ZZWW1
| FT2_ZZZZ | FT2_AAAA
| FT2_AAWW0 | FT2_AAWW1
| FT2_AAZZ
| FT2_AZWW0 | FT2_AZWW1
| FT2_AAAZ | FT2_AZZZ
| FM0_WWWW0 | FM0_WWWW2
| FM0_ZZWW0 | FM0_ZZWW1
| FM0_ZZZZ
| FM1_WWWW0 | FM1_WWWW2
| FM1_ZZWW0 | FM1_ZZWW1
| FM1_ZZZZ
| FM7_WWWW0 | FM7_WWWW2
| FM7_ZZWW0 | FM7_ZZWW1
| FM7_ZZZZ
| D_Alpha_ZZWW0_S | D_Alpha_ZZWW0_T | D_Alpha_ZZWW1_S
| D_Alpha_ZZWW1_T | D_Alpha_ZZWW1_U | D_Alpha_WWWW0_S
| D_Alpha_WWWW0_T | D_Alpha_WWWW0_U | D_Alpha_WWWW2_S
| D_Alpha_WWWW2_T | D_Alpha_ZZZZ_S | D_Alpha_ZZZZ_T
| D_FT0_ZZWW0_S | D_FT0_ZZWW0_T | D_FT0_ZZWW0_U
| D_FT0_ZZWW1_S | D_FT0_ZZWW1_T | D_FT0_ZZWW1_U
| D_FT0_WWWW0_S | D_FT0_WWWW0_T | D_FT0_WWWW0_U
| D_FT0_WWWW2_S | D_FT0_WWWW2_T | D_FT0_WWWW2_U
| D_FT0_ZZZZ_S | D_FT0_ZZZZ_T | D_FT0_ZZZZ_U
| D_FT0_AAAA_S | D_FT0_AAAA_T | D_FT0_AAAA_U
| D_FT0_AAWW0_S | D_FT0_AAWW0_T | D_FT0_AAWW0_U
| D_FT0_AAWW1_S | D_FT0_AAWW1_T | D_FT0_AAWW1_U
| D_FT0_AAZZ_S | D_FT0_AAZZ_T | D_FT0_AAZZ_U
| D_FT0_AZWW0_S | D_FT0_AZWW0_T | D_FT0_AZWW0_U
| D_FT0_AZWW1_S | D_FT0_AZWW1_T | D_FT0_AZWW1_U
| D_FT0_AAAZ_S | D_FT0_AAAZ_T | D_FT0_AAAZ_U
| D_FT0_AZZZ_S | D_FT0_AZZZ_T | D_FT0_AZZZ_U
| D_FT1_ZZWW0_S | D_FT1_ZZWW0_T | D_FT1_ZZWW0_U
| D_FT1_ZZWW1_S | D_FT1_ZZWW1_T | D_FT1_ZZWW1_U
| D_FT1_WWWW0_S | D_FT1_WWWW0_T | D_FT1_WWWW0_U
| D_FT1_WWWW2_S | D_FT1_WWWW2_T | D_FT1_WWWW2_U
| D_FT1_ZZZZ_S | D_FT1_ZZZZ_T | D_FT1_ZZZZ_U
| D_FT1_AAAA_S | D_FT1_AAAA_T | D_FT1_AAAA_U
| D_FT1_AAWW0_S | D_FT1_AAWW0_T | D_FT1_AAWW0_U
| D_FT1_AAWW1_S | D_FT1_AAWW1_T | D_FT1_AAWW1_U
| D_FT1_AAZZ_S | D_FT1_AAZZ_T | D_FT1_AAZZ_U
| D_FT1_AZWW0_S | D_FT1_AZWW0_T | D_FT1_AZWW0_U
| D_FT1_AZWW1_S | D_FT1_AZWW1_T | D_FT1_AZWW1_U
| D_FT1_AAAZ_S | D_FT1_AAAZ_T | D_FT1_AAAZ_U
| D_FT1_AZZZ_S | D_FT1_AZZZ_T | D_FT1_AZZZ_U
| D_FT2_ZZWW0_S | D_FT2_ZZWW0_T | D_FT2_ZZWW0_U
| D_FT2_ZZWW1_S | D_FT2_ZZWW1_T | D_FT2_ZZWW1_U
| D_FT2_WWWW0_S | D_FT2_WWWW0_T | D_FT2_WWWW0_U
| D_FT2_WWWW2_S | D_FT2_WWWW2_T | D_FT2_WWWW2_U
| D_FT2_ZZZZ_S | D_FT2_ZZZZ_T | D_FT2_ZZZZ_U
| D_FT2_AAAA_S | D_FT2_AAAA_T | D_FT2_AAAA_U
| D_FT2_AAWW0_S | D_FT2_AAWW0_T | D_FT2_AAWW0_U
| D_FT2_AAWW1_S | D_FT2_AAWW1_T | D_FT2_AAWW1_U
| D_FT2_AAZZ_S | D_FT2_AAZZ_T | D_FT2_AAZZ_U
| D_FT2_AZWW0_S | D_FT2_AZWW0_T | D_FT2_AZWW0_U
| D_FT2_AZWW1_S | D_FT2_AZWW1_T | D_FT2_AZWW1_U
| D_FT2_AAAZ_S | D_FT2_AAAZ_T | D_FT2_AAAZ_U
| D_FT2_AZZZ_S | D_FT2_AZZZ_T | D_FT2_AZZZ_U
| D_FTrsi_ZZWW0_S | D_FTrsi_ZZWW0_T | D_FTrsi_ZZWW0_U
| D_FTrsi_ZZWW1_S | D_FTrsi_ZZWW1_T | D_FTrsi_ZZWW1_U
| D_FTrsi_WWWW0_S | D_FTrsi_WWWW0_T | D_FTrsi_WWWW0_U
| D_FTrsi_WWWW2_S | D_FTrsi_WWWW2_T | D_FTrsi_WWWW2_U
| D_FTrsi_ZZZZ_S | D_FTrsi_ZZZZ_T | D_FTrsi_ZZZZ_U
| D_FTrsi_AAAA_S | D_FTrsi_AAAA_T | D_FTrsi_AAAA_U
| D_FTrsi_AAWW0_S | D_FTrsi_AAWW0_T | D_FTrsi_AAWW0_U
| D_FTrsi_AAWW1_S | D_FTrsi_AAWW1_T | D_FTrsi_AAWW1_U
| D_FTrsi_AAZZ_S | D_FTrsi_AAZZ_T | D_FTrsi_AAZZ_U
| D_FTrsi_AZWW0_S | D_FTrsi_AZWW0_T | D_FTrsi_AZWW0_U
| D_FTrsi_AZWW1_S | D_FTrsi_AZWW1_T | D_FTrsi_AZWW1_U
| D_FTrsi_AAAZ_S | D_FTrsi_AAAZ_T | D_FTrsi_AAAZ_U
| D_FTrsi_AZZZ_S | D_FTrsi_AZZZ_T | D_FTrsi_AZZZ_U
| D_FM0_ZZWW0_S | D_FM0_ZZWW0_T | D_FM0_ZZWW0_U
| D_FM0_ZZWW1_S | D_FM0_ZZWW1_T | D_FM0_ZZWW1_U
| D_FM0_WWWW0_S | D_FM0_WWWW0_T | D_FM0_WWWW0_U
| D_FM0_WWWW2_S | D_FM0_WWWW2_T | D_FM0_WWWW2_U
| D_FM0_ZZZZ_S | D_FM0_ZZZZ_T | D_FM0_ZZZZ_U
| D_FM1_ZZWW0_S | D_FM1_ZZWW0_T | D_FM1_ZZWW0_U
| D_FM1_ZZWW1_S | D_FM1_ZZWW1_T | D_FM1_ZZWW1_U
| D_FM1_WWWW0_S | D_FM1_WWWW0_T | D_FM1_WWWW0_U
| D_FM1_WWWW2_S | D_FM1_WWWW2_T | D_FM1_WWWW2_U
| D_FM1_ZZZZ_S | D_FM1_ZZZZ_T | D_FM1_ZZZZ_U
| D_FM7_ZZWW0_S | D_FM7_ZZWW0_T | D_FM7_ZZWW0_U
| D_FM7_ZZWW1_S | D_FM7_ZZWW1_T | D_FM7_ZZWW1_U
| D_FM7_WWWW0_S | D_FM7_WWWW0_T | D_FM7_WWWW0_U
| D_FM7_WWWW2_S | D_FM7_WWWW2_T | D_FM7_WWWW2_U
| D_FM7_ZZZZ_S | D_FM7_ZZZZ_T | D_FM7_ZZZZ_U
| D_Alpha_HHHH_S | D_Alpha_HHHH_T
| D_Alpha_HHZZ0_S | D_Alpha_HHWW0_S
| D_Alpha_HHZZ0_T | D_Alpha_HHWW0_T
| D_Alpha_HHZZ1_S | D_Alpha_HHWW1_S
| D_Alpha_HHZZ1_T | D_Alpha_HHWW1_T
| D_Alpha_HHZZ1_U | D_Alpha_HHWW1_U
| D_FM0_HHZZ0_S | D_FM0_HHWW0_S
| D_FM0_HHZZ0_T | D_FM0_HHWW0_T
| D_FM0_HHZZ0_U | D_FM0_HHWW0_U
| D_FM0_HHZZ1_S | D_FM0_HHWW1_S
| D_FM0_HHZZ1_T | D_FM0_HHWW1_T
| D_FM0_HHZZ1_U | D_FM0_HHWW1_U
| D_FM1_HHZZ0_S | D_FM1_HHWW0_S
| D_FM1_HHZZ0_T | D_FM1_HHWW0_T
| D_FM1_HHZZ0_U | D_FM1_HHWW0_U
| D_FM1_HHZZ1_S | D_FM1_HHWW1_S
| D_FM1_HHZZ1_T | D_FM1_HHWW1_T
| D_FM1_HHZZ1_U | D_FM1_HHWW1_U
| D_FM7_HHZZ0_S | D_FM7_HHWW0_S
| D_FM7_HHZZ0_T | D_FM7_HHWW0_T
| D_FM7_HHZZ0_U | D_FM7_HHWW0_U
| D_FM7_HHZZ1_S | D_FM7_HHWW1_S
| D_FM7_HHZZ1_T | D_FM7_HHWW1_T
| D_FM7_HHZZ1_U | D_FM7_HHWW1_U
| G_HWW | G_HHWW | G_HZZ | G_HHZZ
| G_SWW | G_SWW_T | G_SSWW | G_SZZ
| G_SZZ_T | G_SSZZ | G_SHH
| G_SAA_T | G_SAZ_T
| G_PNWW | G_PNZZ | G_PWZ | G_PWW
| G_PSNWW | G_PSNZZ | G_PSNHH
| G_FWW | G_FZZ | G_FWW_CF | G_FZZ_CF
| G_FWW_T | G_FZZ_T | G_FHH | G_FHH_CF
| G_TNWW | G_TNZZ | G_TSNWW | G_TSNZZ | G_TWZ | G_TWW
| G_TNWW_CF | G_TNZZ_CF | G_TSNWW_CF | G_TSNZZ_CF
| G_TWZ_CF | G_TWW_CF
| G_Htt | G_Hbb | G_Hcc | G_Hmm | G_Htautau | G_H3 | G_H4
| FS_H4
| G_HGaZ | G_HGaGa | G_Hgg
| G_HGaZ_anom | G_HGaGa_anom | G_HZZ_anom | G_HWW_anom
| G_HGaZ_u | G_HZZ_u | G_HWW_u
| Gs | I_Gs | G2
| Mass of flavor | Width of flavor
| K_Matrix_Coeff of int | K_Matrix_Pole of int
(* \begin{dubious}
The current abstract syntax for parameter dependencies is admittedly
tedious. Later, there will be a parser for a convenient concrete syntax
as a part of a concrete syntax for models. But as these examples show,
it should include simple functions.
\end{dubious} *)
- type orders = int * int
+ type coupling_order = QCD | EW
+ let all_coupling_orders () = [QCD; EW]
+ let coupling_order_to_string = function
+ | QCD -> "QCD"
+ | EW -> "EW"
- let orders = function
- | _ -> (0,0)
+ let coupling_orders = function
+ | _ -> failwith "Modellib_BSM.SSC.orders: not implemented yet!"
(* \begin{subequations}
\begin{align}
\alpha_{\text{QED}} &= \frac{1}{137.0359895} \\
\sin^2\theta_w &= 0.23124
\end{align}
\end{subequations} *)
let input_parameters =
[ Alpha_QED, 1. /. 137.0359895;
Sin2thw, 0.23124;
Mass (G Z), 91.187;
Mass (M (N 1)), 0.0; Mass (M (L 1)), 0.51099907e-3;
Mass (M (N 2)), 0.0; Mass (M (L 2)), 0.105658389;
Mass (M (N 3)), 0.0; Mass (M (L 3)), 1.77705;
Mass (M (U 1)), 5.0e-3; Mass (M (D 1)), 3.0e-3;
Mass (M (U 2)), 1.2; Mass (M (D 2)), 0.1;
Mass (M (U 3)), 174.0; Mass (M (D 3)), 4.2 ]
(* \begin{subequations}
\begin{align}
e &= \sqrt{4\pi\alpha} \\
\sin\theta_w &= \sqrt{\sin^2\theta_w} \\
\cos\theta_w &= \sqrt{1-\sin^2\theta_w} \\
g &= \frac{e}{\sin\theta_w} \\
m_W &= \cos\theta_w m_Z \\
v &= \frac{2m_W}{g} \\
g_{CC} =
-\frac{g}{2\sqrt2} &= -\frac{e}{2\sqrt2\sin\theta_w} \\
Q_{\text{lepton}} =
-q_{\text{lepton}}e &= e \\
Q_{\text{up}} =
-q_{\text{up}}e &= -\frac{2}{3}e \\
Q_{\text{down}} =
-q_{\text{down}}e &= \frac{1}{3}e \\
\ii q_We =
\ii g_{\gamma WW} &= \ii e \\
\ii g_{ZWW} &= \ii g \cos\theta_w \\
\ii g_{WWW} &= \ii g
\end{align}
\end{subequations} *)
(* \begin{dubious}
\ldots{} to be continued \ldots{}
The quartic couplings can't be correct, because the dimensions are wrong!
\begin{subequations}
\begin{align}
g_{HWW} &= g m_W = 2 \frac{m_W^2}{v}\\
g_{HHWW} &= 2 \frac{m_W^2}{v^2} = \frac{g^2}{2} \\
g_{HZZ} &= \frac{g}{\cos\theta_w}m_Z \\
g_{HHZZ} &= 2 \frac{m_Z^2}{v^2} = \frac{g^2}{2\cos\theta_w} \\
g_{Htt} &= \lambda_t \\
g_{Hbb} &= \lambda_b=\frac{m_b}{m_t}\lambda_t \\
g_{H^3} &= - \frac{3g}{2}\frac{m_H^2}{m_W} = - 3 \frac{m_H^2}{v}
g_{H^4} &= - \frac{3g^2}{4} \frac{m_W^2}{v^2} = -3 \frac{m_H^2}{v^2}
\end{align}
\end{subequations}
\end{dubious} *)
let derived_parameters =
[ Real E, Sqrt (Prod [Integer 4; Atom Pi; Atom Alpha_QED]);
Real Sinthw, Sqrt (Atom Sin2thw);
Real Costhw, Sqrt (Diff (Integer 1, Atom Sin2thw));
Real G_weak, Quot (Atom E, Atom Sinthw);
Real (Mass (G Wp)), Prod [Atom Costhw; Atom (Mass (G Z))];
Real Vev, Quot (Prod [Integer 2; Atom (Mass (G Wp))], Atom G_weak);
Real Q_lepton, Atom E;
Real Q_up, Prod [Quot (Integer (-2), Integer 3); Atom E];
Real Q_down, Prod [Quot (Integer 1, Integer 3); Atom E];
Real G_CC, Neg (Quot (Atom G_weak, Prod [Integer 2; Sqrt (Integer 2)]));
Complex I_Q_W, Prod [I; Atom E];
Complex I_G_weak, Prod [I; Atom G_weak];
Complex I_G_ZWW, Prod [I; Atom G_weak; Atom Costhw] ]
(* \begin{equation}
- \frac{g}{2\cos\theta_w}
\end{equation} *)
let g_over_2_costh =
Quot (Neg (Atom G_weak), Prod [Integer 2; Atom Costhw])
(* \begin{subequations}
\begin{align}
- \frac{g}{2\cos\theta_w} g_V
&= - \frac{g}{2\cos\theta_w} (T_3 - 2 q \sin^2\theta_w) \\
- \frac{g}{2\cos\theta_w} g_A
&= - \frac{g}{2\cos\theta_w} T_3
\end{align}
\end{subequations} *)
let nc_coupling c t3 q =
(Real_Array c,
[Prod [g_over_2_costh; Diff (t3, Prod [Integer 2; q; Atom Sin2thw])];
Prod [g_over_2_costh; t3]])
let half = Quot (Integer 1, Integer 2)
let derived_parameter_arrays =
[ nc_coupling G_NC_neutrino half (Integer 0);
nc_coupling G_NC_lepton (Neg half) (Integer (-1));
nc_coupling G_NC_up half (Quot (Integer 2, Integer 3));
nc_coupling G_NC_down (Neg half) (Quot (Integer (-1), Integer 3)) ]
let parameters () =
{ input = input_parameters;
derived = derived_parameters;
derived_arrays = derived_parameter_arrays }
module F = Modeltools.Fusions (struct
type f = flavor
type c = constant
let compare = compare
let conjugate = conjugate
end)
(* \begin{equation}
\mathcal{L}_{\textrm{EM}} =
- e \sum_i q_i \bar\psi_i\fmslash{A}\psi_i
\end{equation} *)
let mgm ((m1, g, m2), fbf, c) = ((M m1, G g, M m2), fbf, c)
let mom ((m1, o, m2), fbf, c) = ((M m1, O o, M m2), fbf, c)
let electromagnetic_currents n =
List.map mgm
[ ((L (-n), Ga, L n), FBF (1, Psibar, V, Psi), Q_lepton);
((U (-n), Ga, U n), FBF (1, Psibar, V, Psi), Q_up);
((D (-n), Ga, D n), FBF (1, Psibar, V, Psi), Q_down) ]
let color_currents n =
List.map mgm
[ ((U (-n), Gl, U n), FBF ((-1), Psibar, V, Psi), Gs);
((D (-n), Gl, D n), FBF ((-1), Psibar, V, Psi), Gs) ]
(* \begin{equation}
\mathcal{L}_{\textrm{NC}} =
- \frac{g}{2\cos\theta_W}
\sum_i \bar\psi_i\fmslash{Z}(g_V^i-g_A^i\gamma_5)\psi_i
\end{equation} *)
let neutral_currents n =
List.map mgm
[ ((L (-n), Z, L n), FBF (1, Psibar, VA, Psi), G_NC_lepton);
((N (-n), Z, N n), FBF (1, Psibar, VA, Psi), G_NC_neutrino);
((U (-n), Z, U n), FBF (1, Psibar, VA, Psi), G_NC_up);
((D (-n), Z, D n), FBF (1, Psibar, VA, Psi), G_NC_down) ]
(* \begin{equation}
\mathcal{L}_{\textrm{CC}} =
- \frac{g}{2\sqrt2} \sum_i \bar\psi_i
(T^+\fmslash{W}^+ + T^-\fmslash{W}^-)(1-\gamma_5)\psi_i
\end{equation} *)
let charged_currents' n =
List.map mgm
[ ((L (-n), Wm, N n), FBF (1, Psibar, VL, Psi), G_CC);
((N (-n), Wp, L n), FBF (1, Psibar, VL, Psi), G_CC) ]
let charged_currents'' n =
List.map mgm
[ ((D (-n), Wm, U n), FBF (1, Psibar, VL, Psi), G_CC);
((U (-n), Wp, D n), FBF (1, Psibar, VL, Psi), G_CC) ]
let charged_currents_triv =
ThoList.flatmap charged_currents' [1;2;3] @
ThoList.flatmap charged_currents'' [1;2;3]
let charged_currents_ckm =
let charged_currents_2 n1 n2 =
List.map mgm
[ ((D (-n1), Wm, U n2), FBF (1, Psibar, VL, Psi), G_CCQ (n2,n1));
((U (-n1), Wp, D n2), FBF (1, Psibar, VL, Psi), G_CCQ (n1,n2)) ] in
ThoList.flatmap charged_currents' [1;2;3] @
List.flatten (Product.list2 charged_currents_2 [1;2;3] [1;2;3])
let yukawa =
[ ((M (U (-3)), O H, M (U 3)), FBF (1, Psibar, S, Psi), G_Htt);
((M (D (-3)), O H, M (D 3)), FBF (1, Psibar, S, Psi), G_Hbb);
((M (U (-2)), O H, M (U 2)), FBF (1, Psibar, S, Psi), G_Hcc);
((M (L (-3)), O H, M (L 3)), FBF (1, Psibar, S, Psi), G_Htautau) ] @
if Flags.higgs_hmm then
[ ((M (L (-2)), O H, M (L 2)), FBF (1, Psibar, S, Psi), G_Hmm)]
else
[]
(* \begin{equation}
\mathcal{L}_{\textrm{TGC}} =
- e \partial_\mu A_\nu W_+^\mu W_-^\nu + \ldots
- e \cot\theta_w \partial_\mu Z_\nu W_+^\mu W_-^\nu + \ldots
\end{equation} *)
let tgc ((g1, g2, g3), t, c) = ((G g1, G g2, G g3), t, c)
let standard_triple_gauge =
List.map tgc
[ ((Ga, Wm, Wp), Gauge_Gauge_Gauge 1, I_Q_W);
((Z, Wm, Wp), Gauge_Gauge_Gauge 1, I_G_ZWW);
((Gl, Gl, Gl), Gauge_Gauge_Gauge 1, I_Gs)]
(* \begin{multline}
\mathcal{L}_{\textrm{TGC}}(g_1,\kappa)
= g_1 \mathcal{L}_T(V,W^+,W^-) \\
+ \frac{\kappa+g_1}{2} \Bigl(\mathcal{L}_T(W^-,V,W^+)
- \mathcal{L}_T(W^+,V,W^-)\Bigr)\\
+ \frac{\kappa-g_1}{2} \Bigl(\mathcal{L}_L(W^-,V,W^+)
- \mathcal{L}_T(W^+,V,W^-)\Bigr)
\end{multline} *)
(* \begin{dubious}
The whole thing in the LEP2 workshop notation:
\begin{multline}
\ii\mathcal{L}_{\textrm{TGC},V} / g_{WWV} = \\
g_1^V V^\mu (W^-_{\mu\nu}W^{+,\nu}-W^+_{\mu\nu}W^{-,\nu})
+ \kappa_V W^+_\mu W^-_\nu V^{\mu\nu}
+ \frac{\lambda_V}{m_W^2} V_{\mu\nu}
W^-_{\rho\mu} W^{+,\hphantom{\nu}\rho}_{\hphantom{+,}\nu} \\
+ \ii g_5^V \epsilon_{\mu\nu\rho\sigma}
\left( (\partial^\rho W^{-,\mu}) W^{+,\nu}
- W^{-,\mu}(\partial^\rho W^{+,\nu}) \right) V^\sigma \\
+ \ii g_4^V W^-_\mu W^+_\nu (\partial^\mu V^\nu + \partial^\nu V^\mu)
- \frac{\tilde\kappa_V}{2} W^-_\mu W^+_\nu \epsilon^{\mu\nu\rho\sigma}
V_{\rho\sigma}
- \frac{\tilde\lambda_V}{2m_W^2}
W^-_{\rho\mu} W^{+,\mu}_{\hphantom{+,\mu}\nu} \epsilon^{\nu\rho\alpha\beta}
V_{\alpha\beta}
\end{multline}
using the conventions of Itzykson and Zuber with $\epsilon^{0123} = +1$.
\end{dubious} *)
(* \begin{dubious}
This is equivalent to the notation of Hagiwara et al.~\cite{HPZH87}, if we
remember that they have opposite signs for~$g_{WWV}$:
\begin{multline}
\mathcal{L}_{WWV} / (-g_{WWV}) = \\
\ii g_1^V \left( W^\dagger_{\mu\nu} W^\mu
- W^\dagger_\mu W^\mu_{\hphantom{\mu}\nu} \right) V^\nu
+ \ii \kappa_V W^\dagger_\mu W_\nu V^{\mu\nu}
+ \ii \frac{\lambda_V}{m_W^2}
W^\dagger_{\lambda\mu} W^\mu_{\hphantom{\mu}\nu} V^{\nu\lambda} \\
- g_4^V W^\dagger_\mu W_\nu
\left(\partial^\mu V^\nu + \partial^\nu V^\mu \right)
+ g_5^V \epsilon^{\mu\nu\lambda\sigma}
\left( W^\dagger_\mu \stackrel{\leftrightarrow}{\partial_\lambda}
W_\nu \right) V_\sigma\\
+ \ii \tilde\kappa_V W^\dagger_\mu W_\nu \tilde{V}^{\mu\nu}
+ \ii\frac{\tilde\lambda_V}{m_W^2}
W^\dagger_{\lambda\mu} W^\mu_{\hphantom{\mu}\nu} \tilde{V}^{\nu\lambda}
\end{multline}
Here $V^\mu$ stands for either the photon or the~$Z$ field, $W^\mu$ is the
$W^-$ field, $W_{\mu\nu} = \partial_\mu W_\nu - \partial_\nu W_\mu$,
$V_{\mu\nu} = \partial_\mu V_\nu - \partial_\nu V_\mu$, and
$\tilde{V}_{\mu\nu} = \frac{1}{2} \epsilon_{\mu\nu\lambda\sigma}
V^{\lambda\sigma}$.
\end{dubious} *)
let anomalous_triple_gauge =
List.map tgc
[ ((Ga, Wm, Wp), Dim4_Vector_Vector_Vector_T (-1),
I_G1_AWW);
((Z, Wm, Wp), Dim4_Vector_Vector_Vector_T (-1),
I_G1_ZWW);
((Wm, Ga, Wp), Dim4_Vector_Vector_Vector_T 1,
I_G1_plus_kappa_minus_G4_AWW);
((Wm, Z, Wp), Dim4_Vector_Vector_Vector_T 1,
I_G1_plus_kappa_minus_G4_ZWW);
((Wp, Ga, Wm), Dim4_Vector_Vector_Vector_T (-1),
I_G1_plus_kappa_plus_G4_AWW);
((Wp, Z, Wm), Dim4_Vector_Vector_Vector_T (-1),
I_G1_plus_kappa_plus_G4_ZWW);
((Wm, Ga, Wp), Dim4_Vector_Vector_Vector_L (-1),
I_G1_minus_kappa_plus_G4_AWW);
((Wm, Z, Wp), Dim4_Vector_Vector_Vector_L (-1),
I_G1_minus_kappa_plus_G4_ZWW);
((Wp, Ga, Wm), Dim4_Vector_Vector_Vector_L 1,
I_G1_minus_kappa_minus_G4_AWW);
((Wp, Z, Wm), Dim4_Vector_Vector_Vector_L 1,
I_G1_minus_kappa_minus_G4_ZWW);
((Ga, Wm, Wp), Dim4_Vector_Vector_Vector_L5 (-1),
I_kappa5_AWW);
((Z, Wm, Wp), Dim4_Vector_Vector_Vector_L5 (-1),
I_kappa5_ZWW);
((Ga, Wm, Wp), Dim4_Vector_Vector_Vector_T5 (-1),
G5_AWW);
((Z, Wm, Wp), Dim4_Vector_Vector_Vector_T5 (-1),
G5_ZWW);
((Ga, Wp, Wm), Dim6_Gauge_Gauge_Gauge (-1),
I_lambda_AWW);
((Z, Wp, Wm), Dim6_Gauge_Gauge_Gauge (-1),
I_lambda_ZWW);
((Ga, Wp, Wm), Dim6_Gauge_Gauge_Gauge_5 (-1),
I_lambda5_AWW);
((Z, Wp, Wm), Dim6_Gauge_Gauge_Gauge_5 (-1),
I_lambda5_ZWW) ]
let triple_gauge =
if Flags.triple_anom then
anomalous_triple_gauge
else
standard_triple_gauge
(* \begin{equation}
\mathcal{L}_{\textrm{QGC}} =
- g^2 W_{+,\mu} W_{-,\nu} W_+^\mu W_-^\nu + \ldots
\end{equation} *)
(* Actually, quartic gauge couplings are a little bit more straightforward
using auxiliary fields. Here we have to impose the antisymmetry manually:
\begin{subequations}
\begin{multline}
(W^{+,\mu}_1 W^{-,\nu}_2 - W^{+,\nu}_1 W^{-,\mu}_2)
(W^+_{3,\mu} W^-_{4,\nu} - W^+_{3,\nu} W^-_{4,\mu}) \\
= 2(W^+_1W^+_3)(W^-_2W^-_4) - 2(W^+_1W^-_4)(W^-_2W^+_3)
\end{multline}
also ($V$ can be $A$ or $Z$)
\begin{multline}
(W^{+,\mu}_1 V^\nu_2 - W^{+,\nu}_1 V^\mu_2)
(W^-_{3,\mu} V_{4,\nu} - W^-_{3,\nu} V_{4,\mu}) \\
= 2(W^+_1W^-_3)(V_2V_4) - 2(W^+_1V_4)(V_2W^-_3)
\end{multline}
\end{subequations} *)
(* \begin{subequations}
\begin{multline}
W^{+,\mu} W^{-,\nu} W^+_\mu W^-_\nu
\end{multline}
\end{subequations} *)
let qgc ((g1, g2, g3, g4), t, c) = ((G g1, G g2, G g3, G g4), t, c)
let gauge4 = Vector4 [(2, C_13_42); (-1, C_12_34); (-1, C_14_23)]
let minus_gauge4 = Vector4 [(-2, C_13_42); (1, C_12_34); (1, C_14_23)]
let standard_quartic_gauge =
List.map qgc
[ (Wm, Wp, Wm, Wp), gauge4, G_WWWW;
(Wm, Z, Wp, Z), minus_gauge4, G_ZZWW;
(Wm, Z, Wp, Ga), minus_gauge4, G_AZWW;
(Wm, Ga, Wp, Ga), minus_gauge4, G_AAWW;
(Gl, Gl, Gl, Gl), gauge4, G2 ]
(* \begin{subequations}
\begin{align}
\mathcal{L}_4
&= \alpha_4 \left( \frac{g^4}{2}\left( (W^+_\mu W^{-,\mu})^2
+ W^+_\mu W^{+,\mu} W^-_\mu W^{-,\mu}
\right)\right.\notag \\
&\qquad\qquad\qquad \left.
+ \frac{g^4}{\cos^2\theta_w} W^+_\mu Z^\mu W^-_\nu Z^\nu
+ \frac{g^4}{4\cos^4\theta_w} (Z_\mu Z^\mu)^2 \right) \\
\mathcal{L}_5
&= \alpha_5 \left( g^4 (W^+_\mu W^{-,\mu})^2
+ \frac{g^4}{\cos^2\theta_w} W^+_\mu W^{-,\mu} Z_\nu Z^\nu
+ \frac{g^4}{4\cos^4\theta_w} (Z_\mu Z^\mu)^2 \right)
\end{align}
\end{subequations}
or
\begin{multline}
\mathcal{L}_4 + \mathcal{L}_5
= (\alpha_4+2\alpha_5) g^4 \frac{1}{2} (W^+_\mu W^{-,\mu})^2 \\
+ 2\alpha_4 g^4 \frac{1}{4} W^+_\mu W^{+,\mu} W^-_\mu W^{-,\mu}
+ \alpha_4 \frac{g^4}{\cos^2\theta_w} W^+_\mu Z^\mu W^-_\nu Z^\nu \\
+ 2\alpha_5 \frac{g^4}{\cos^2\theta_w} \frac{1}{2} W^+_\mu W^{-,\mu} Z_\nu Z^\nu
+ (2\alpha_4 + 2\alpha_5) \frac{g^4}{\cos^4\theta_w} \frac{1}{8} (Z_\mu Z^\mu)^2
\end{multline}
and therefore
\begin{subequations}
\begin{align}
\alpha_{(WW)_0} &= (\alpha_4+2\alpha_5) g^4 \\
\alpha_{(WW)_2} &= 2\alpha_4 g^4 \\
\alpha_{(WZ)_0} &= 2\alpha_5 \frac{g^4}{\cos^2\theta_w} \\
\alpha_{(WZ)_1} &= \alpha_4 \frac{g^4}{\cos^2\theta_w} \\
\alpha_{ZZ} &= (2\alpha_4 + 2\alpha_5) \frac{g^4}{\cos^4\theta_w}
\end{align}
\end{subequations} *)
let anomalous_quartic_gauge =
if Flags.quartic_anom then
List.map qgc
[ ((Wm, Wm, Wp, Wp),
Vector4 [(1, C_13_42); (1, C_14_23)], Alpha_WWWW0);
((Wm, Wm, Wp, Wp),
Vector4 [1, C_12_34], Alpha_WWWW2);
((Z, Z, Z, Z),
Vector4 [(1, C_12_34); (1, C_13_42); (1, C_14_23)], Alpha_ZZZZ);
((Wm, Wp, Z, Z),
Vector4 [1, C_12_34], Alpha_ZZWW0);
((Wm, Wp, Z, Z),
Vector4 [(1, C_13_42); (1, C_14_23)], Alpha_ZZWW1)]
@
(if Flags.k_matrix_tm then
List.map qgc
[((Wm, Wm, Wp, Wp),
Dim8_Vector4_t_0 [1, C_13_42], FT0_WWWW0);
((Wm, Wm, Wp, Wp),
Dim8_Vector4_t_0 [1, C_14_23], FT0_WWWW0);
((Wm, Wm, Wp, Wp),
Dim8_Vector4_t_0 [1, C_12_34], FT0_WWWW2);
((Wm, Wm, Wp, Wp),
Dim8_Vector4_t_1 [1, C_13_42], FT1_WWWW0);
((Wm, Wm, Wp, Wp),
Dim8_Vector4_t_1 [1, C_14_23], FT1_WWWW0);
((Wm, Wm, Wp, Wp),
Dim8_Vector4_t_1 [1, C_12_34], FT1_WWWW2);
((Wm, Wm, Wp, Wp),
Dim8_Vector4_t_2 [1, C_13_42], FT2_WWWW0);
((Wm, Wm, Wp, Wp),
Dim8_Vector4_t_2 [1, C_14_23], FT2_WWWW0);
((Wm, Wm, Wp, Wp),
Dim8_Vector4_t_2 [1, C_12_34], FT2_WWWW2);
((Wm, Wm, Wp, Wp),
Dim8_Vector4_m_0 [1, C_13_42], FM0_WWWW0);
((Wm, Wm, Wp, Wp),
Dim8_Vector4_m_0 [1, C_14_23], FM0_WWWW0);
((Wm, Wm, Wp, Wp),
Dim8_Vector4_m_0 [1, C_12_34], FM0_WWWW2);
((Wm, Wm, Wp, Wp),
Dim8_Vector4_m_1 [1, C_13_42], FM1_WWWW0);
((Wm, Wm, Wp, Wp),
Dim8_Vector4_m_1 [1, C_14_23], FM1_WWWW0);
((Wm, Wm, Wp, Wp),
Dim8_Vector4_m_1 [1, C_12_34], FM1_WWWW2);
((Wm, Wm, Wp, Wp),
Dim8_Vector4_m_7 [1, C_13_42], FM7_WWWW0);
((Wm, Wm, Wp, Wp),
Dim8_Vector4_m_7 [1, C_14_23], FM7_WWWW0);
((Wm, Wm, Wp, Wp),
Dim8_Vector4_m_7 [1, C_12_34], FM7_WWWW2);
((Wm, Wp, Z, Z),
Dim8_Vector4_t_0 [1, C_12_34], FT0_ZZWW0);
((Wm, Wp, Z, Z),
Dim8_Vector4_t_0 [1, C_13_42], FT0_ZZWW1);
((Wm, Wp, Z, Z),
Dim8_Vector4_t_0 [1, C_14_23], FT0_ZZWW1);
((Wm, Wp, Z, Z),
Dim8_Vector4_t_1 [1, C_12_34], FT1_ZZWW0);
((Wm, Wp, Z, Z),
Dim8_Vector4_t_1 [1, C_13_42], FT1_ZZWW1);
((Wm, Wp, Z, Z),
Dim8_Vector4_t_1 [1, C_14_23], FT1_ZZWW1);
((Wm, Wp, Z, Z),
Dim8_Vector4_t_2 [1, C_12_34], FT2_ZZWW0);
((Wm, Wp, Z, Z),
Dim8_Vector4_t_2 [1, C_13_42], FT2_ZZWW1);
((Wm, Wp, Z, Z),
Dim8_Vector4_t_2 [1, C_14_23], FT2_ZZWW1);
((Wm, Wp, Z, Z),
Dim8_Vector4_m_0 [1, C_12_34], FM0_ZZWW0);
((Wm, Wp, Z, Z),
Dim8_Vector4_m_0 [1, C_13_42], FM0_ZZWW1);
((Wm, Wp, Z, Z),
Dim8_Vector4_m_0 [1, C_14_23], FM0_ZZWW1);
((Wm, Wp, Z, Z),
Dim8_Vector4_m_1 [1, C_12_34], FM1_ZZWW0);
((Wm, Wp, Z, Z),
Dim8_Vector4_m_1 [1, C_13_42], FM1_ZZWW1);
((Wm, Wp, Z, Z),
Dim8_Vector4_m_1 [1, C_14_23], FM1_ZZWW1);
((Wm, Wp, Z, Z),
Dim8_Vector4_m_7 [1, C_12_34], FM7_ZZWW0);
((Wm, Wp, Z, Z),
Dim8_Vector4_m_7 [1, C_13_42], FM7_ZZWW1);
((Wm, Wp, Z, Z),
Dim8_Vector4_m_7 [1, C_14_23], FM7_ZZWW1);
((Z, Z, Z, Z),
Dim8_Vector4_t_0 [1, C_12_34], FT0_ZZZZ);
((Z, Z, Z, Z),
Dim8_Vector4_t_0 [1, C_13_42], FT0_ZZZZ);
((Z, Z, Z, Z),
Dim8_Vector4_t_0 [1, C_14_23], FT0_ZZZZ);
((Z, Z, Z, Z),
Dim8_Vector4_t_1 [1, C_12_34], FT1_ZZZZ);
((Z, Z, Z, Z),
Dim8_Vector4_t_1 [1, C_13_42], FT1_ZZZZ);
((Z, Z, Z, Z),
Dim8_Vector4_t_1 [1, C_14_23], FT1_ZZZZ);
((Z, Z, Z, Z),
Dim8_Vector4_t_2 [1, C_12_34], FT2_ZZZZ);
((Z, Z, Z, Z),
Dim8_Vector4_t_2 [1, C_13_42], FT2_ZZZZ);
((Z, Z, Z, Z),
Dim8_Vector4_t_2 [1, C_14_23], FT2_ZZZZ);
((Z, Z, Z, Z),
Dim8_Vector4_m_0 [1, C_12_34], FM0_ZZZZ);
((Z, Z, Z, Z),
Dim8_Vector4_m_0 [1, C_13_42], FM0_ZZZZ);
((Z, Z, Z, Z),
Dim8_Vector4_m_0 [1, C_14_23], FM0_ZZZZ);
((Z, Z, Z, Z),
Dim8_Vector4_m_1 [1, C_12_34], FM1_ZZZZ);
((Z, Z, Z, Z),
Dim8_Vector4_m_1 [1, C_13_42], FM1_ZZZZ);
((Z, Z, Z, Z),
Dim8_Vector4_m_1 [1, C_14_23], FM1_ZZZZ);
((Z, Z, Z, Z),
Dim8_Vector4_m_7 [1, C_12_34], FM7_ZZZZ);
((Z, Z, Z, Z),
Dim8_Vector4_m_7 [1, C_13_42], FM7_ZZZZ);
((Z, Z, Z, Z),
Dim8_Vector4_m_7 [1, C_14_23], FM7_ZZZZ);
((Ga, Ga, Ga, Ga),
Dim8_Vector4_t_0 [1, C_12_34], FT0_AAAA);
((Ga, Ga, Ga, Ga),
Dim8_Vector4_t_0 [1, C_13_42], FT0_AAAA);
((Ga, Ga, Ga, Ga),
Dim8_Vector4_t_0 [1, C_14_23], FT0_AAAA);
((Ga, Ga, Ga, Ga),
Dim8_Vector4_t_1 [1, C_12_34], FT1_AAAA);
((Ga, Ga, Ga, Ga),
Dim8_Vector4_t_1 [1, C_13_42], FT1_AAAA);
((Ga, Ga, Ga, Ga),
Dim8_Vector4_t_1 [1, C_14_23], FT1_AAAA);
((Ga, Ga, Ga, Ga),
Dim8_Vector4_t_2 [1, C_12_34], FT2_AAAA);
((Ga, Ga, Ga, Ga),
Dim8_Vector4_t_2 [1, C_13_42], FT2_AAAA);
((Ga, Ga, Ga, Ga),
Dim8_Vector4_t_2 [1, C_14_23], FT2_AAAA);
((Wm, Wp, Ga, Ga),
Dim8_Vector4_t_0 [1, C_12_34], FT0_AAWW0);
((Wm, Wp, Ga, Ga),
Dim8_Vector4_t_0 [1, C_13_42], FT0_AAWW1);
((Wm, Wp, Ga, Ga),
Dim8_Vector4_t_0 [1, C_14_23], FT0_AAWW1);
((Wm, Wp, Ga, Ga),
Dim8_Vector4_t_1 [1, C_12_34], FT1_AAWW0);
((Wm, Wp, Ga, Ga),
Dim8_Vector4_t_1 [1, C_13_42], FT1_AAWW1);
((Wm, Wp, Ga, Ga),
Dim8_Vector4_t_1 [1, C_14_23], FT1_AAWW1);
((Wm, Wp, Ga, Ga),
Dim8_Vector4_t_2 [1, C_12_34], FT2_AAWW0);
((Wm, Wp, Ga, Ga),
Dim8_Vector4_t_2 [1, C_13_42], FT2_AAWW1);
((Wm, Wp, Ga, Ga),
Dim8_Vector4_t_2 [1, C_14_23], FT2_AAWW1);
((Z, Z, Ga, Ga),
Dim8_Vector4_t_0 [1, C_12_34], FT0_AAZZ);
((Z, Z, Ga, Ga),
Dim8_Vector4_t_0 [1, C_13_42], FT0_AAZZ);
((Z, Z, Ga, Ga),
Dim8_Vector4_t_0 [1, C_14_23], FT0_AAZZ);
((Z, Z, Ga, Ga),
Dim8_Vector4_t_1 [1, C_12_34], FT1_AAZZ);
((Z, Z, Ga, Ga),
Dim8_Vector4_t_1 [1, C_13_42], FT1_AAZZ);
((Z, Z, Ga, Ga),
Dim8_Vector4_t_1 [1, C_14_23], FT1_AAZZ);
((Z, Z, Ga, Ga),
Dim8_Vector4_t_2 [1, C_12_34], FT2_AAZZ);
((Z, Z, Ga, Ga),
Dim8_Vector4_t_2 [1, C_13_42], FT2_AAZZ);
((Z, Z, Ga, Ga),
Dim8_Vector4_t_2 [1, C_14_23], FT2_AAZZ);
((Ga, Z, Wp, Wm),
Dim8_Vector4_t_0 [1, C_12_34], FT0_AZWW0);
((Ga, Z, Wp, Wm),
Dim8_Vector4_t_0 [1, C_13_42], FT0_AZWW1);
((Ga, Z, Wp, Wm),
Dim8_Vector4_t_0 [1, C_14_23], FT0_AZWW1);
((Ga, Z, Wp, Wm),
Dim8_Vector4_t_1 [1, C_12_34], FT1_AZWW0);
((Ga, Z, Wp, Wm),
Dim8_Vector4_t_1 [1, C_13_42], FT1_AZWW1);
((Ga, Z, Wp, Wm),
Dim8_Vector4_t_1 [1, C_14_23], FT1_AZWW1);
((Ga, Z, Wp, Wm),
Dim8_Vector4_t_2 [1, C_12_34], FT2_AZWW0);
((Ga, Z, Wp, Wm),
Dim8_Vector4_t_2 [1, C_13_42], FT2_AZWW1);
((Ga, Z, Wp, Wm),
Dim8_Vector4_t_2 [1, C_14_23], FT2_AZWW1);
((Ga, Ga, Ga, Z),
Dim8_Vector4_t_0 [1, C_12_34], FT0_AAAZ);
((Ga, Ga, Ga, Z),
Dim8_Vector4_t_0 [1, C_13_42], FT0_AAAZ);
((Ga, Ga, Ga, Z),
Dim8_Vector4_t_0 [1, C_14_23], FT0_AAAZ);
((Ga, Ga, Ga, Z),
Dim8_Vector4_t_1 [1, C_12_34], FT1_AAAZ);
((Ga, Ga, Ga, Z),
Dim8_Vector4_t_1 [1, C_13_42], FT1_AAAZ);
((Ga, Ga, Ga, Z),
Dim8_Vector4_t_1 [1, C_14_23], FT1_AAAZ);
((Ga, Ga, Ga, Z),
Dim8_Vector4_t_2 [1, C_12_34], FT2_AAAZ);
((Ga, Ga, Ga, Z),
Dim8_Vector4_t_2 [1, C_13_42], FT2_AAAZ);
((Ga, Ga, Ga, Z),
Dim8_Vector4_t_2 [1, C_14_23], FT2_AAAZ);
((Ga, Z, Z, Z),
Dim8_Vector4_t_0 [1, C_12_34], FT0_AZZZ);
((Ga, Z, Z, Z),
Dim8_Vector4_t_0 [1, C_13_42], FT0_AZZZ);
((Ga, Z, Z, Z),
Dim8_Vector4_t_0 [1, C_14_23], FT0_AZZZ);
((Ga, Z, Z, Z),
Dim8_Vector4_t_1 [1, C_12_34], FT1_AZZZ);
((Ga, Z, Z, Z),
Dim8_Vector4_t_1 [1, C_13_42], FT1_AZZZ);
((Ga, Z, Z, Z),
Dim8_Vector4_t_1 [1, C_14_23], FT1_AZZZ);
((Ga, Z, Z, Z),
Dim8_Vector4_t_2 [1, C_12_34], FT2_AZZZ);
((Ga, Z, Z, Z),
Dim8_Vector4_t_2 [1, C_13_42], FT2_AZZZ);
((Ga, Z, Z, Z),
Dim8_Vector4_t_2 [1, C_14_23], FT2_AZZZ)]
else
[] )
else
[]
(* In any diagonal channel~$\chi$, the scattering amplitude~$a_\chi(s)$ is
unitary iff\footnote{%
Trivial proof:
\begin{equation}
-1 = \textrm{Im}\left(\frac{1}{a_\chi(s)}\right)
= \frac{\textrm{Im}(a_\chi^*(s))}{ |a_\chi(s)|^2 }
= - \frac{\textrm{Im}(a_\chi(s))}{ |a_\chi(s)|^2 }
\end{equation}
i.\,e.~$\textrm{Im}(a_\chi(s)) = |a_\chi(s)|^2$.}
\begin{equation}
\textrm{Im}\left(\frac{1}{a_\chi(s)}\right) = -1
\end{equation}
For a real perturbative scattering amplitude~$r_\chi(s)$ this can be
enforced easily--and arbitrarily--by
\begin{equation}
\frac{1}{a_\chi(s)} = \frac{1}{r_\chi(s)} - \mathrm{i}
\end{equation}
*)
let k_matrix_quartic_gauge =
if Flags.k_matrix then
List.map qgc
[ ((Wm, Wp, Wm, Wp), Vector4_K_Matrix_jr (0,
[(1, C_12_34)]), D_Alpha_WWWW0_S);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_jr (0,
[(1, C_14_23)]), D_Alpha_WWWW0_T);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_jr (0,
[(1, C_13_42)]), D_Alpha_WWWW0_U);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_jr (0,
[(1, C_12_34)]), D_Alpha_WWWW0_S);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_jr (0,
[(1, C_14_23)]), D_Alpha_WWWW0_T);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_jr (0,
[(1, C_13_42)]), D_Alpha_WWWW0_U);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_jr (0,
[(1, C_12_34)]), D_Alpha_WWWW2_S);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_jr (0,
[(1, C_13_42); (1, C_14_23)]), D_Alpha_WWWW2_T);
((Wm, Wp, Z, Z), Vector4_K_Matrix_jr (0,
[(1, C_12_34)]), D_Alpha_ZZWW0_S);
((Wm, Wp, Z, Z), Vector4_K_Matrix_jr (0,
[(1, C_13_42); (1, C_14_23)]), D_Alpha_ZZWW0_T);
((Wm, Z, Wp, Z), Vector4_K_Matrix_jr (0,
[(1, C_12_34)]), D_Alpha_ZZWW1_S);
((Wm, Z, Wp, Z), Vector4_K_Matrix_jr (0,
[(1, C_13_42)]), D_Alpha_ZZWW1_T);
((Wm, Z, Wp, Z), Vector4_K_Matrix_jr (0,
[(1, C_14_23)]), D_Alpha_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_jr (1,
[(1, C_12_34)]), D_Alpha_ZZWW1_S);
((Wp, Z, Z, Wm), Vector4_K_Matrix_jr (1,
[(1, C_13_42)]), D_Alpha_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_jr (1,
[(1, C_14_23)]), D_Alpha_ZZWW1_T);
((Z, Wp, Wm, Z), Vector4_K_Matrix_jr (2,
[(1, C_12_34)]), D_Alpha_ZZWW1_S);
((Z, Wp, Wm, Z), Vector4_K_Matrix_jr (2,
[(1, C_13_42)]), D_Alpha_ZZWW1_U);
((Z, Wp, Wm, Z), Vector4_K_Matrix_jr (2,
[(1, C_14_23)]), D_Alpha_ZZWW1_T);
((Z, Z, Z, Z), Vector4_K_Matrix_jr (0,
[(1, C_12_34)]), D_Alpha_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_jr (0,
[(1, C_13_42); (1, C_14_23)]), D_Alpha_ZZZZ_T);
((Z, Z, Z, Z), Vector4_K_Matrix_jr (3,
[(1, C_14_23)]), D_Alpha_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_jr (3,
[(1, C_13_42); (1, C_12_34)]), D_Alpha_ZZZZ_T)]
else
[]
let k_matrix_quartic_gauge_t_0 =
if Flags.k_matrix_tm then
List.map qgc
[ ((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_t0 (0,
[(1, C_12_34)]), D_FT0_WWWW0_S);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_t0 (0,
[(1, C_14_23)]), D_FT0_WWWW0_T);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_t0 (0,
[(1, C_13_42)]), D_FT0_WWWW0_U);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_t0 (0,
[(1, C_12_34)]), D_FT0_WWWW0_S);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_t0 (0,
[(1, C_14_23)]), D_FT0_WWWW0_T);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_t0 (0,
[(1, C_13_42)]), D_FT0_WWWW0_U);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_t0 (0,
[(1, C_12_34)]), D_FT0_WWWW2_S);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_t0 (0,
[(1, C_13_42)]), D_FT0_WWWW2_T);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_t0 (0,
[(1, C_14_23)]), D_FT0_WWWW2_U);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_t0 (0,
[(1, C_12_34)]), D_FT0_ZZWW0_S);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_t0 (0,
[(1, C_13_42)]), D_FT0_ZZWW0_T);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_t0 (0,
[(1, C_14_23)]), D_FT0_ZZWW0_U);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_t0 (0,
[(1, C_12_34)]), D_FT0_ZZWW1_S);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_t0 (0,
[(1, C_13_42)]), D_FT0_ZZWW1_T);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_t0 (0,
[(1, C_14_23)]), D_FT0_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_t0 (1,
[(1, C_12_34)]), D_FT0_ZZWW1_S);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_t0 (1,
[(1, C_13_42)]), D_FT0_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_t0 (1,
[(1, C_14_23)]), D_FT0_ZZWW1_T);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_t0 (2,
[(1, C_12_34)]), D_FT0_ZZWW1_S);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_t0 (2,
[(1, C_13_42)]), D_FT0_ZZWW1_U);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_t0 (2,
[(1, C_14_23)]), D_FT0_ZZWW1_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t0 (0,
[(1, C_12_34)]), D_FT0_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t0 (0,
[(1, C_13_42)]), D_FT0_ZZZZ_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t0 (0,
[(1, C_14_23)]), D_FT0_ZZZZ_U);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t0 (3,
[(1, C_14_23)]), D_FT0_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t0 (3,
[(1, C_13_42)]), D_FT0_ZZZZ_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t0 (3,
[(1, C_12_34)]), D_FT0_ZZZZ_U);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t0 (0,
[(1, C_12_34)]), D_FT0_AAAA_S);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t0 (0,
[(1, C_13_42)]), D_FT0_AAAA_T);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t0 (0,
[(1, C_14_23)]), D_FT0_AAAA_U);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t0 (3,
[(1, C_14_23)]), D_FT0_AAAA_S);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t0 (3,
[(1, C_13_42)]), D_FT0_AAAA_T);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t0 (3,
[(1, C_12_34)]), D_FT0_AAAA_U);
((Wm, Wp, Ga, Ga), Vector4_K_Matrix_cf_t0 (0,
[(1, C_12_34)]), D_FT0_AAWW0_S);
((Wm, Wp, Ga, Ga), Vector4_K_Matrix_cf_t0 (0,
[(1, C_13_42)]), D_FT0_AAWW0_T);
((Wm, Wp, Ga, Ga), Vector4_K_Matrix_cf_t0 (0,
[(1, C_14_23)]), D_FT0_AAWW0_U);
((Wm, Ga, Wp, Ga), Vector4_K_Matrix_cf_t0 (0,
[(1, C_12_34)]), D_FT0_AAWW1_S);
((Wm, Ga, Wp, Ga), Vector4_K_Matrix_cf_t0 (0,
[(1, C_13_42)]), D_FT0_AAWW1_T);
((Wm, Ga, Wp, Ga), Vector4_K_Matrix_cf_t0 (0,
[(1, C_14_23)]), D_FT0_AAWW1_U);
((Wp, Ga, Ga, Wm), Vector4_K_Matrix_cf_t0 (1,
[(1, C_12_34)]), D_FT0_AAWW1_S);
((Wp, Ga, Ga, Wm), Vector4_K_Matrix_cf_t0 (1,
[(1, C_13_42)]), D_FT0_AAWW1_U);
((Wp, Ga, Ga, Wm), Vector4_K_Matrix_cf_t0 (1,
[(1, C_14_23)]), D_FT0_AAWW1_T);
((Ga, Wp, Wm, Ga), Vector4_K_Matrix_cf_t0 (2,
[(1, C_12_34)]), D_FT0_AAWW1_S);
((Ga, Wp, Wm, Ga), Vector4_K_Matrix_cf_t0 (2,
[(1, C_13_42)]), D_FT0_AAWW1_U);
((Ga, Wp, Wm, Ga), Vector4_K_Matrix_cf_t0 (2,
[(1, C_14_23)]), D_FT0_AAWW1_T);
((Ga, Z, Ga, Z), Vector4_K_Matrix_cf_t0 (0,
[(1, C_12_34)]), D_FT0_AAZZ_S);
((Ga, Z, Ga, Z), Vector4_K_Matrix_cf_t0 (0,
[(1, C_14_23)]), D_FT0_AAZZ_T);
((Ga, Z, Ga, Z), Vector4_K_Matrix_cf_t0 (0,
[(1, C_13_42)]), D_FT0_AAZZ_U);
((Z, Ga, Z, Ga), Vector4_K_Matrix_cf_t0 (0,
[(1, C_12_34)]), D_FT0_AAZZ_S);
((Z, Ga, Z, Ga), Vector4_K_Matrix_cf_t0 (0,
[(1, C_14_23)]), D_FT0_AAZZ_T);
((Z, Ga, Z, Ga), Vector4_K_Matrix_cf_t0 (0,
[(1, C_13_42)]), D_FT0_AAZZ_U);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t0 (0,
[(1, C_12_34)]), D_FT0_AAZZ_S);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t0 (0,
[(1, C_13_42)]), D_FT0_AAZZ_T);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t0 (0,
[(1, C_14_23)]), D_FT0_AAZZ_U);
((Ga, Z, Wp, Wm), Vector4_K_Matrix_cf_t0 (0,
[(1, C_12_34)]), D_FT0_AZWW0_S);
((Ga, Z, Wp, Wm), Vector4_K_Matrix_cf_t0 (0,
[(1, C_13_42)]), D_FT0_AZWW0_T);
((Ga, Z, Wp, Wm), Vector4_K_Matrix_cf_t0 (0,
[(1, C_14_23)]), D_FT0_AZWW0_U);
((Wp, Ga, Wm, Z), Vector4_K_Matrix_cf_t0 (1,
[(1, C_12_34)]), D_FT0_AZWW1_S);
((Wp, Ga, Wm, Z), Vector4_K_Matrix_cf_t0 (1,
[(1, C_13_42)]), D_FT0_AZWW1_T);
((Wp, Ga, Wm, Z), Vector4_K_Matrix_cf_t0 (1,
[(1, C_14_23)]), D_FT0_AZWW1_U);
((Wm, Ga, Wp, Z), Vector4_K_Matrix_cf_t0 (1,
[(1, C_12_34)]), D_FT0_AZWW1_S);
((Wm, Ga, Wp, Z), Vector4_K_Matrix_cf_t0 (1,
[(1, C_13_42)]), D_FT0_AZWW1_T);
((Wm, Ga, Wp, Z), Vector4_K_Matrix_cf_t0 (1,
[(1, C_14_23)]), D_FT0_AZWW1_U);
((Z, Wm, Ga, Wp), Vector4_K_Matrix_cf_t0 (1,
[(1, C_12_34)]), D_FT0_AZWW1_S);
((Z, Wm, Ga, Wp), Vector4_K_Matrix_cf_t0 (1,
[(1, C_13_42)]), D_FT0_AZWW1_T);
((Z, Wm, Ga, Wp), Vector4_K_Matrix_cf_t0 (1,
[(1, C_14_23)]), D_FT0_AZWW1_U);
((Wp, Z, Wm, Ga), Vector4_K_Matrix_cf_t0 (1,
[(1, C_12_34)]), D_FT0_AZWW1_S);
((Wp, Z, Wm, Ga), Vector4_K_Matrix_cf_t0 (1,
[(1, C_13_42)]), D_FT0_AZWW1_T);
((Wp, Z, Wm, Ga), Vector4_K_Matrix_cf_t0 (1,
[(1, C_14_23)]), D_FT0_AZWW1_U);
((Ga, Ga, Ga, Z), Vector4_K_Matrix_cf_t0 (3,
[(1, C_12_34)]), D_FT0_AAAZ_S);
((Ga, Ga, Ga, Z), Vector4_K_Matrix_cf_t0 (3,
[(1, C_13_42)]), D_FT0_AAAZ_T);
((Ga, Ga, Ga, Z), Vector4_K_Matrix_cf_t0 (3,
[(1, C_14_23)]), D_FT0_AAAZ_U);
((Z, Ga, Ga, Ga), Vector4_K_Matrix_cf_t0 (3,
[(1, C_12_34)]), D_FT0_AAAZ_S);
((Z, Ga, Ga, Ga), Vector4_K_Matrix_cf_t0 (3,
[(1, C_13_42)]), D_FT0_AAAZ_T);
((Z, Ga, Ga, Ga), Vector4_K_Matrix_cf_t0 (3,
[(1, C_14_23)]), D_FT0_AAAZ_U);
((Ga, Ga, Z, Ga), Vector4_K_Matrix_cf_t0 (3,
[(1, C_12_34)]), D_FT0_AAAZ_S);
((Ga, Ga, Z, Ga), Vector4_K_Matrix_cf_t0 (3,
[(1, C_13_42)]), D_FT0_AAAZ_T);
((Ga, Ga, Z, Ga), Vector4_K_Matrix_cf_t0 (3,
[(1, C_14_23)]), D_FT0_AAAZ_U);
((Z, Z, Z, Ga), Vector4_K_Matrix_cf_t0 (3,
[(1, C_12_34)]), D_FT0_AZZZ_S);
((Z, Z, Z, Ga), Vector4_K_Matrix_cf_t0 (3,
[(1, C_13_42)]), D_FT0_AZZZ_T);
((Z, Z, Z, Ga), Vector4_K_Matrix_cf_t0 (3,
[(1, C_14_23)]), D_FT0_AZZZ_U);
((Ga, Z, Z, Z), Vector4_K_Matrix_cf_t0 (3,
[(1, C_12_34)]), D_FT0_AZZZ_S);
((Ga, Z, Z, Z), Vector4_K_Matrix_cf_t0 (3,
[(1, C_13_42)]), D_FT0_AZZZ_T);
((Ga, Z, Z, Z), Vector4_K_Matrix_cf_t0 (3,
[(1, C_14_23)]), D_FT0_AZZZ_U);
((Z, Z, Ga, Z), Vector4_K_Matrix_cf_t0 (3,
[(1, C_12_34)]), D_FT0_AZZZ_S);
((Z, Z, Ga, Z), Vector4_K_Matrix_cf_t0 (3,
[(1, C_13_42)]), D_FT0_AZZZ_T);
((Z, Z, Ga, Z), Vector4_K_Matrix_cf_t0 (3,
[(1, C_14_23)]), D_FT0_AZZZ_U)]
else
[]
let k_matrix_quartic_gauge_t_1 =
if Flags.k_matrix_tm then
List.map qgc
[ ((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_t1 (0,
[(1, C_12_34)]), D_FT1_WWWW0_S);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_t1 (0,
[(1, C_14_23)]), D_FT1_WWWW0_T);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_t1 (0,
[(1, C_13_42)]), D_FT1_WWWW0_U);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_t1 (0,
[(1, C_12_34)]), D_FT1_WWWW0_S);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_t1 (0,
[(1, C_14_23)]), D_FT1_WWWW0_T);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_t1 (0,
[(1, C_13_42)]), D_FT1_WWWW0_U);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_t1 (0,
[(1, C_12_34)]), D_FT1_WWWW2_S);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_t1 (0,
[(1, C_13_42)]), D_FT1_WWWW2_T);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_t1 (0,
[(1, C_14_23)]), D_FT1_WWWW2_U);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_t1 (0,
[(1, C_12_34)]), D_FT1_ZZWW0_S);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_t1 (0,
[(1, C_13_42)]), D_FT1_ZZWW0_T);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_t1 (0,
[(1, C_14_23)]), D_FT1_ZZWW0_U);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_t1 (0,
[(1, C_12_34)]), D_FT1_ZZWW1_S);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_t1 (0,
[(1, C_13_42)]), D_FT1_ZZWW1_T);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_t1 (0,
[(1, C_14_23)]), D_FT1_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_t1 (1,
[(1, C_12_34)]), D_FT1_ZZWW1_S);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_t1 (1,
[(1, C_13_42)]), D_FT1_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_t1 (1,
[(1, C_14_23)]), D_FT1_ZZWW1_T);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_t1 (2,
[(1, C_12_34)]), D_FT1_ZZWW1_S);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_t1 (2,
[(1, C_13_42)]), D_FT1_ZZWW1_U);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_t1 (2,
[(1, C_14_23)]), D_FT1_ZZWW1_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t1 (0,
[(1, C_12_34)]), D_FT1_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t1 (0,
[(1, C_13_42)]), D_FT1_ZZZZ_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t1 (0,
[(1, C_14_23)]), D_FT1_ZZZZ_U);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t1 (3,
[(1, C_14_23)]), D_FT1_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t1 (3,
[(1, C_13_42)]), D_FT1_ZZZZ_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t1 (3,
[(1, C_12_34)]), D_FT1_ZZZZ_U);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t1 (0,
[(1, C_12_34)]), D_FT1_AAAA_S);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t1 (0,
[(1, C_13_42)]), D_FT1_AAAA_T);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t1 (0,
[(1, C_14_23)]), D_FT1_AAAA_U);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t1 (3,
[(1, C_14_23)]), D_FT1_AAAA_S);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t1 (3,
[(1, C_13_42)]), D_FT1_AAAA_T);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t1 (3,
[(1, C_12_34)]), D_FT1_AAAA_U);
((Wm, Wp, Ga, Ga), Vector4_K_Matrix_cf_t1 (0,
[(1, C_12_34)]), D_FT1_AAWW0_S);
((Wm, Wp, Ga, Ga), Vector4_K_Matrix_cf_t1 (0,
[(1, C_13_42)]), D_FT1_AAWW0_T);
((Wm, Wp, Ga, Ga), Vector4_K_Matrix_cf_t1 (0,
[(1, C_14_23)]), D_FT1_AAWW0_U);
((Wm, Ga, Wp, Ga), Vector4_K_Matrix_cf_t1 (0,
[(1, C_12_34)]), D_FT1_AAWW1_S);
((Wm, Ga, Wp, Ga), Vector4_K_Matrix_cf_t1 (0,
[(1, C_13_42)]), D_FT1_AAWW1_T);
((Wm, Ga, Wp, Ga), Vector4_K_Matrix_cf_t1 (0,
[(1, C_14_23)]), D_FT1_AAWW1_U);
((Wp, Ga, Ga, Wm), Vector4_K_Matrix_cf_t1 (1,
[(1, C_12_34)]), D_FT1_AAWW1_S);
((Wp, Ga, Ga, Wm), Vector4_K_Matrix_cf_t1 (1,
[(1, C_13_42)]), D_FT1_AAWW1_U);
((Wp, Ga, Ga, Wm), Vector4_K_Matrix_cf_t1 (1,
[(1, C_14_23)]), D_FT1_AAWW1_T);
((Ga, Wp, Wm, Ga), Vector4_K_Matrix_cf_t1 (2,
[(1, C_12_34)]), D_FT1_AAWW1_S);
((Ga, Wp, Wm, Ga), Vector4_K_Matrix_cf_t1 (2,
[(1, C_13_42)]), D_FT1_AAWW1_U);
((Ga, Wp, Wm, Ga), Vector4_K_Matrix_cf_t1 (2,
[(1, C_14_23)]), D_FT1_AAWW1_T);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t1 (0,
[(1, C_12_34)]), D_FT1_AAZZ_S);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t1 (0,
[(1, C_13_42)]), D_FT1_AAZZ_T);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t1 (0,
[(1, C_14_23)]), D_FT1_AAZZ_U);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t1 (3,
[(1, C_14_23)]), D_FT1_AAZZ_S);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t1 (3,
[(1, C_13_42)]), D_FT1_AAZZ_T);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t1 (3,
[(1, C_12_34)]), D_FT1_AAZZ_U);
((Ga, Z, Wp, Wm), Vector4_K_Matrix_cf_t1 (0,
[(1, C_12_34)]), D_FT1_AZWW0_S);
((Ga, Z, Wp, Wm), Vector4_K_Matrix_cf_t1 (0,
[(1, C_13_42)]), D_FT1_AZWW0_T);
((Ga, Z, Wp, Wm), Vector4_K_Matrix_cf_t1 (0,
[(1, C_14_23)]), D_FT1_AZWW0_U);
((Wp, Ga, Wm, Z), Vector4_K_Matrix_cf_t1 (1,
[(1, C_12_34)]), D_FT1_AZWW1_S);
((Wp, Ga, Wm, Z), Vector4_K_Matrix_cf_t1 (1,
[(1, C_13_42)]), D_FT1_AZWW1_T);
((Wp, Ga, Wm, Z), Vector4_K_Matrix_cf_t1 (1,
[(1, C_14_23)]), D_FT1_AZWW1_U);
((Wm, Ga, Wp, Z), Vector4_K_Matrix_cf_t1 (1,
[(1, C_12_34)]), D_FT1_AZWW1_S);
((Wm, Ga, Wp, Z), Vector4_K_Matrix_cf_t1 (1,
[(1, C_13_42)]), D_FT1_AZWW1_T);
((Wm, Ga, Wp, Z), Vector4_K_Matrix_cf_t1 (1,
[(1, C_14_23)]), D_FT1_AZWW1_U);
((Z, Wm, Ga, Wp), Vector4_K_Matrix_cf_t1 (1,
[(1, C_12_34)]), D_FT1_AZWW1_S);
((Z, Wm, Ga, Wp), Vector4_K_Matrix_cf_t1 (1,
[(1, C_13_42)]), D_FT1_AZWW1_T);
((Z, Wm, Ga, Wp), Vector4_K_Matrix_cf_t1 (1,
[(1, C_14_23)]), D_FT1_AZWW1_U);
((Wp, Z, Wm, Ga), Vector4_K_Matrix_cf_t1 (1,
[(1, C_12_34)]), D_FT1_AZWW1_S);
((Wp, Z, Wm, Ga), Vector4_K_Matrix_cf_t1 (1,
[(1, C_13_42)]), D_FT1_AZWW1_T);
((Wp, Z, Wm, Ga), Vector4_K_Matrix_cf_t1 (1,
[(1, C_14_23)]), D_FT1_AZWW1_U);
((Ga, Ga, Ga, Z), Vector4_K_Matrix_cf_t1 (3,
[(1, C_12_34)]), D_FT1_AAAZ_S);
((Ga, Ga, Ga, Z), Vector4_K_Matrix_cf_t1 (3,
[(1, C_13_42)]), D_FT1_AAAZ_T);
((Ga, Ga, Ga, Z), Vector4_K_Matrix_cf_t1 (3,
[(1, C_14_23)]), D_FT1_AAAZ_U);
((Z, Ga, Ga, Ga), Vector4_K_Matrix_cf_t1 (3,
[(1, C_12_34)]), D_FT1_AAAZ_S);
((Z, Ga, Ga, Ga), Vector4_K_Matrix_cf_t1 (3,
[(1, C_13_42)]), D_FT1_AAAZ_T);
((Z, Ga, Ga, Ga), Vector4_K_Matrix_cf_t1 (3,
[(1, C_14_23)]), D_FT1_AAAZ_U);
((Ga, Ga, Z, Ga), Vector4_K_Matrix_cf_t1 (3,
[(1, C_12_34)]), D_FT1_AAAZ_S);
((Ga, Ga, Z, Ga), Vector4_K_Matrix_cf_t1 (3,
[(1, C_13_42)]), D_FT1_AAAZ_T);
((Ga, Ga, Z, Ga), Vector4_K_Matrix_cf_t1 (3,
[(1, C_14_23)]), D_FT1_AAAZ_U);
((Z, Z, Z, Ga), Vector4_K_Matrix_cf_t1 (3,
[(1, C_12_34)]), D_FT1_AZZZ_S);
((Z, Z, Z, Ga), Vector4_K_Matrix_cf_t1 (3,
[(1, C_13_42)]), D_FT1_AZZZ_T);
((Z, Z, Z, Ga), Vector4_K_Matrix_cf_t1 (3,
[(1, C_14_23)]), D_FT1_AZZZ_U);
((Ga, Z, Z, Z), Vector4_K_Matrix_cf_t1 (3,
[(1, C_12_34)]), D_FT1_AZZZ_S);
((Ga, Z, Z, Z), Vector4_K_Matrix_cf_t1 (3,
[(1, C_13_42)]), D_FT1_AZZZ_T);
((Ga, Z, Z, Z), Vector4_K_Matrix_cf_t1 (3,
[(1, C_14_23)]), D_FT1_AZZZ_U);
((Z, Z, Ga, Z), Vector4_K_Matrix_cf_t1 (3,
[(1, C_12_34)]), D_FT1_AZZZ_S);
((Z, Z, Ga, Z), Vector4_K_Matrix_cf_t1 (3,
[(1, C_13_42)]), D_FT1_AZZZ_T);
((Z, Z, Ga, Z), Vector4_K_Matrix_cf_t1 (3,
[(1, C_14_23)]), D_FT1_AZZZ_U)]
else
[]
let k_matrix_quartic_gauge_t_2 =
if Flags.k_matrix_tm then
List.map qgc
[ ((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_t2 (0,
[(1, C_12_34)]), D_FT2_WWWW0_S);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_t2 (0,
[(1, C_14_23)]), D_FT2_WWWW0_T);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_t2 (0,
[(1, C_13_42)]), D_FT2_WWWW0_U);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_t2 (0,
[(1, C_12_34)]), D_FT2_WWWW0_S);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_t2 (0,
[(1, C_14_23)]), D_FT2_WWWW0_T);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_t2 (0,
[(1, C_13_42)]), D_FT2_WWWW0_U);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_t2 (0,
[(1, C_12_34)]), D_FT2_WWWW2_S);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_t2 (0,
[(1, C_13_42)]), D_FT2_WWWW2_T);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_t2 (0,
[(1, C_14_23)]), D_FT2_WWWW2_U);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_t2 (0,
[(1, C_12_34)]), D_FT2_ZZWW0_S);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_t2 (0,
[(1, C_13_42)]), D_FT2_ZZWW0_T);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_t2 (0,
[(1, C_14_23)]), D_FT2_ZZWW0_U);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_t2 (0,
[(1, C_12_34)]), D_FT2_ZZWW1_S);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_t2 (0,
[(1, C_13_42)]), D_FT2_ZZWW1_T);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_t2 (0,
[(1, C_14_23)]), D_FT2_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_t2 (1,
[(1, C_12_34)]), D_FT2_ZZWW1_S);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_t2 (1,
[(1, C_13_42)]), D_FT2_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_t2 (1,
[(1, C_14_23)]), D_FT2_ZZWW1_T);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_t2 (2,
[(1, C_12_34)]), D_FT2_ZZWW1_S);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_t2 (2,
[(1, C_13_42)]), D_FT2_ZZWW1_U);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_t2 (2,
[(1, C_14_23)]), D_FT2_ZZWW1_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t2 (0,
[(1, C_12_34)]), D_FT2_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t2 (0,
[(1, C_13_42)]), D_FT2_ZZZZ_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t2 (0,
[(1, C_14_23)]), D_FT2_ZZZZ_U);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t2 (3,
[(1, C_14_23)]), D_FT2_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t2 (3,
[(1, C_13_42)]), D_FT2_ZZZZ_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t2 (3,
[(1, C_12_34)]), D_FT2_ZZZZ_U);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t2 (0,
[(1, C_12_34)]), D_FT2_AAAA_S);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t2 (0,
[(1, C_13_42)]), D_FT2_AAAA_T);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t2 (0,
[(1, C_14_23)]), D_FT2_AAAA_U);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t2 (3,
[(1, C_14_23)]), D_FT2_AAAA_S);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t2 (3,
[(1, C_13_42)]), D_FT2_AAAA_T);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t2 (3,
[(1, C_12_34)]), D_FT2_AAAA_U);
((Wm, Wp, Ga, Ga), Vector4_K_Matrix_cf_t2 (0,
[(1, C_12_34)]), D_FT2_AAWW0_S);
((Wm, Wp, Ga, Ga), Vector4_K_Matrix_cf_t2 (0,
[(1, C_13_42)]), D_FT2_AAWW0_T);
((Wm, Wp, Ga, Ga), Vector4_K_Matrix_cf_t2 (0,
[(1, C_14_23)]), D_FT2_AAWW0_U);
((Wm, Ga, Wp, Ga), Vector4_K_Matrix_cf_t2 (0,
[(1, C_12_34)]), D_FT2_AAWW1_S);
((Wm, Ga, Wp, Ga), Vector4_K_Matrix_cf_t2 (0,
[(1, C_13_42)]), D_FT2_AAWW1_T);
((Wm, Ga, Wp, Ga), Vector4_K_Matrix_cf_t2 (0,
[(1, C_14_23)]), D_FT2_AAWW1_U);
((Wp, Ga, Ga, Wm), Vector4_K_Matrix_cf_t2 (1,
[(1, C_12_34)]), D_FT2_AAWW1_S);
((Wp, Ga, Ga, Wm), Vector4_K_Matrix_cf_t2 (1,
[(1, C_13_42)]), D_FT2_AAWW1_U);
((Wp, Ga, Ga, Wm), Vector4_K_Matrix_cf_t2 (1,
[(1, C_14_23)]), D_FT2_AAWW1_T);
((Ga, Wp, Wm, Ga), Vector4_K_Matrix_cf_t2 (2,
[(1, C_12_34)]), D_FT2_AAWW1_S);
((Ga, Wp, Wm, Ga), Vector4_K_Matrix_cf_t2 (2,
[(1, C_13_42)]), D_FT2_AAWW1_U);
((Ga, Wp, Wm, Ga), Vector4_K_Matrix_cf_t2 (2,
[(1, C_14_23)]), D_FT2_AAWW1_T);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t2 (0,
[(1, C_12_34)]), D_FT2_AAZZ_S);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t2 (0,
[(1, C_13_42)]), D_FT2_AAZZ_T);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t2 (0,
[(1, C_14_23)]), D_FT2_AAZZ_U);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t2 (3,
[(1, C_14_23)]), D_FT2_AAZZ_S);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t2 (3,
[(1, C_13_42)]), D_FT2_AAZZ_T);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t2 (3,
[(1, C_12_34)]), D_FT2_AAZZ_U);
((Ga, Z, Wp, Wm), Vector4_K_Matrix_cf_t2 (0,
[(1, C_12_34)]), D_FT2_AZWW0_S);
((Ga, Z, Wp, Wm), Vector4_K_Matrix_cf_t2 (0,
[(1, C_13_42)]), D_FT2_AZWW0_T);
((Ga, Z, Wp, Wm), Vector4_K_Matrix_cf_t2 (0,
[(1, C_14_23)]), D_FT2_AZWW0_U);
((Wp, Ga, Wm, Z), Vector4_K_Matrix_cf_t2 (1,
[(1, C_12_34)]), D_FT2_AZWW1_S);
((Wp, Ga, Wm, Z), Vector4_K_Matrix_cf_t2 (1,
[(1, C_13_42)]), D_FT2_AZWW1_T);
((Wp, Ga, Wm, Z), Vector4_K_Matrix_cf_t2 (1,
[(1, C_14_23)]), D_FT2_AZWW1_U);
((Wm, Ga, Wp, Z), Vector4_K_Matrix_cf_t2 (1,
[(1, C_12_34)]), D_FT2_AZWW1_S);
((Wm, Ga, Wp, Z), Vector4_K_Matrix_cf_t2 (1,
[(1, C_13_42)]), D_FT2_AZWW1_T);
((Wm, Ga, Wp, Z), Vector4_K_Matrix_cf_t2 (1,
[(1, C_14_23)]), D_FT2_AZWW1_U);
((Z, Wm, Ga, Wp), Vector4_K_Matrix_cf_t2 (1,
[(1, C_12_34)]), D_FT2_AZWW1_S);
((Z, Wm, Ga, Wp), Vector4_K_Matrix_cf_t2 (1,
[(1, C_13_42)]), D_FT2_AZWW1_T);
((Z, Wm, Ga, Wp), Vector4_K_Matrix_cf_t2 (1,
[(1, C_14_23)]), D_FT2_AZWW1_U);
((Wp, Z, Wm, Ga), Vector4_K_Matrix_cf_t2 (1,
[(1, C_12_34)]), D_FT2_AZWW1_S);
((Wp, Z, Wm, Ga), Vector4_K_Matrix_cf_t2 (1,
[(1, C_13_42)]), D_FT2_AZWW1_T);
((Wp, Z, Wm, Ga), Vector4_K_Matrix_cf_t2 (1,
[(1, C_14_23)]), D_FT2_AZWW1_U);
((Ga, Ga, Ga, Z), Vector4_K_Matrix_cf_t2 (3,
[(1, C_12_34)]), D_FT2_AAAZ_S);
((Ga, Ga, Ga, Z), Vector4_K_Matrix_cf_t2 (3,
[(1, C_13_42)]), D_FT2_AAAZ_T);
((Ga, Ga, Ga, Z), Vector4_K_Matrix_cf_t2 (3,
[(1, C_14_23)]), D_FT2_AAAZ_U);
((Z, Ga, Ga, Ga), Vector4_K_Matrix_cf_t2 (3,
[(1, C_12_34)]), D_FT2_AAAZ_S);
((Z, Ga, Ga, Ga), Vector4_K_Matrix_cf_t2 (3,
[(1, C_13_42)]), D_FT2_AAAZ_T);
((Z, Ga, Ga, Ga), Vector4_K_Matrix_cf_t2 (3,
[(1, C_14_23)]), D_FT2_AAAZ_U);
((Ga, Ga, Z, Ga), Vector4_K_Matrix_cf_t2 (3,
[(1, C_12_34)]), D_FT2_AAAZ_S);
((Ga, Ga, Z, Ga), Vector4_K_Matrix_cf_t2 (3,
[(1, C_13_42)]), D_FT2_AAAZ_T);
((Ga, Ga, Z, Ga), Vector4_K_Matrix_cf_t2 (3,
[(1, C_14_23)]), D_FT2_AAAZ_U);
((Z, Z, Z, Ga), Vector4_K_Matrix_cf_t2 (3,
[(1, C_12_34)]), D_FT2_AZZZ_S);
((Z, Z, Z, Ga), Vector4_K_Matrix_cf_t2 (3,
[(1, C_13_42)]), D_FT2_AZZZ_T);
((Z, Z, Z, Ga), Vector4_K_Matrix_cf_t2 (3,
[(1, C_14_23)]), D_FT2_AZZZ_U);
((Ga, Z, Z, Z), Vector4_K_Matrix_cf_t2 (3,
[(1, C_12_34)]), D_FT2_AZZZ_S);
((Ga, Z, Z, Z), Vector4_K_Matrix_cf_t2 (3,
[(1, C_13_42)]), D_FT2_AZZZ_T);
((Ga, Z, Z, Z), Vector4_K_Matrix_cf_t2 (3,
[(1, C_14_23)]), D_FT2_AZZZ_U);
((Z, Z, Ga, Z), Vector4_K_Matrix_cf_t2 (3,
[(1, C_12_34)]), D_FT2_AZZZ_S);
((Z, Z, Ga, Z), Vector4_K_Matrix_cf_t2 (3,
[(1, C_13_42)]), D_FT2_AZZZ_T);
((Z, Z, Ga, Z), Vector4_K_Matrix_cf_t2 (3,
[(1, C_14_23)]), D_FT2_AZZZ_U)]
else
[]
let k_matrix_quartic_gauge_t_rsi =
if Flags.k_matrix_tm then
List.map qgc
[ ((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_12_34)]), D_FTrsi_WWWW0_S);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_14_23)]), D_FTrsi_WWWW0_T);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_13_42)]), D_FTrsi_WWWW0_U);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_12_34)]), D_FTrsi_WWWW0_S);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_14_23)]), D_FTrsi_WWWW0_T);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_13_42)]), D_FTrsi_WWWW0_U);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_12_34)]), D_FTrsi_WWWW2_S);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_13_42)]), D_FTrsi_WWWW2_T);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_14_23)]), D_FTrsi_WWWW2_U);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_12_34)]), D_FTrsi_ZZWW0_S);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_13_42)]), D_FTrsi_ZZWW0_T);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_14_23)]), D_FTrsi_ZZWW0_U);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_12_34)]), D_FTrsi_ZZWW1_S);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_13_42)]), D_FTrsi_ZZWW1_T);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_14_23)]), D_FTrsi_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_12_34)]), D_FTrsi_ZZWW1_S);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_13_42)]), D_FTrsi_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_14_23)]), D_FTrsi_ZZWW1_T);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_t_rsi (2,
[(1, C_12_34)]), D_FTrsi_ZZWW1_S);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_t_rsi (2,
[(1, C_13_42)]), D_FTrsi_ZZWW1_U);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_t_rsi (2,
[(1, C_14_23)]), D_FTrsi_ZZWW1_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_12_34)]), D_FTrsi_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_13_42)]), D_FTrsi_ZZZZ_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_14_23)]), D_FTrsi_ZZZZ_U);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_14_23)]), D_FTrsi_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_13_42)]), D_FTrsi_ZZZZ_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_12_34)]), D_FTrsi_ZZZZ_U);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_12_34)]), D_FTrsi_AAAA_S);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_13_42)]), D_FTrsi_AAAA_T);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_14_23)]), D_FTrsi_AAAA_U);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_14_23)]), D_FTrsi_AAAA_S);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_13_42)]), D_FTrsi_AAAA_T);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_12_34)]), D_FTrsi_AAAA_U);
((Wm, Wp, Ga, Ga), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_12_34)]), D_FTrsi_AAWW0_S);
((Wm, Wp, Ga, Ga), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_13_42)]), D_FTrsi_AAWW0_T);
((Wm, Wp, Ga, Ga), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_14_23)]), D_FTrsi_AAWW0_U);
((Wm, Ga, Wp, Ga), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_12_34)]), D_FTrsi_AAWW1_S);
((Wm, Ga, Wp, Ga), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_13_42)]), D_FTrsi_AAWW1_T);
((Wm, Ga, Wp, Ga), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_14_23)]), D_FTrsi_AAWW1_U);
((Wp, Ga, Ga, Wm), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_12_34)]), D_FTrsi_AAWW1_S);
((Wp, Ga, Ga, Wm), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_13_42)]), D_FTrsi_AAWW1_U);
((Wp, Ga, Ga, Wm), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_14_23)]), D_FTrsi_AAWW1_T);
((Ga, Wp, Wm, Ga), Vector4_K_Matrix_cf_t_rsi (2,
[(1, C_12_34)]), D_FTrsi_AAWW1_S);
((Ga, Wp, Wm, Ga), Vector4_K_Matrix_cf_t_rsi (2,
[(1, C_13_42)]), D_FTrsi_AAWW1_U);
((Ga, Wp, Wm, Ga), Vector4_K_Matrix_cf_t_rsi (2,
[(1, C_14_23)]), D_FTrsi_AAWW1_T);
((Ga, Z, Ga, Z), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_12_34)]), D_FTrsi_AAZZ_S);
((Ga, Z, Ga, Z), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_14_23)]), D_FTrsi_AAZZ_T);
((Ga, Z, Ga, Z), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_13_42)]), D_FTrsi_AAZZ_U);
((Z, Ga, Z, Ga), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_12_34)]), D_FTrsi_AAZZ_S);
((Z, Ga, Z, Ga), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_14_23)]), D_FTrsi_AAZZ_T);
((Z, Ga, Z, Ga), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_13_42)]), D_FTrsi_AAZZ_U);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_12_34)]), D_FTrsi_AAZZ_S);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_13_42)]), D_FTrsi_AAZZ_T);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_14_23)]), D_FTrsi_AAZZ_U);
((Ga, Z, Wp, Wm), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_12_34)]), D_FTrsi_AZWW0_S);
((Ga, Z, Wp, Wm), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_13_42)]), D_FTrsi_AZWW0_T);
((Ga, Z, Wp, Wm), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_14_23)]), D_FTrsi_AZWW0_U);
((Wp, Ga, Wm, Z), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_12_34)]), D_FTrsi_AZWW1_S);
((Wp, Ga, Wm, Z), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_13_42)]), D_FTrsi_AZWW1_T);
((Wp, Ga, Wm, Z), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_14_23)]), D_FTrsi_AZWW1_U);
((Wm, Ga, Wp, Z), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_12_34)]), D_FTrsi_AZWW1_S);
((Wm, Ga, Wp, Z), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_13_42)]), D_FTrsi_AZWW1_T);
((Wm, Ga, Wp, Z), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_14_23)]), D_FTrsi_AZWW1_U);
((Z, Wm, Ga, Wp), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_12_34)]), D_FTrsi_AZWW1_S);
((Z, Wm, Ga, Wp), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_13_42)]), D_FTrsi_AZWW1_T);
((Z, Wm, Ga, Wp), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_14_23)]), D_FTrsi_AZWW1_U);
((Wp, Z, Wm, Ga), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_12_34)]), D_FTrsi_AZWW1_S);
((Wp, Z, Wm, Ga), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_13_42)]), D_FTrsi_AZWW1_T);
((Wp, Z, Wm, Ga), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_14_23)]), D_FTrsi_AZWW1_U);
((Ga, Ga, Ga, Z), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_12_34)]), D_FTrsi_AAAZ_S);
((Ga, Ga, Ga, Z), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_13_42)]), D_FTrsi_AAAZ_T);
((Ga, Ga, Ga, Z), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_14_23)]), D_FTrsi_AAAZ_U);
((Z, Ga, Ga, Ga), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_12_34)]), D_FTrsi_AAAZ_S);
((Z, Ga, Ga, Ga), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_13_42)]), D_FTrsi_AAAZ_T);
((Z, Ga, Ga, Ga), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_14_23)]), D_FTrsi_AAAZ_U);
((Ga, Ga, Z, Ga), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_12_34)]), D_FTrsi_AAAZ_S);
((Ga, Ga, Z, Ga), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_13_42)]), D_FTrsi_AAAZ_T);
((Ga, Ga, Z, Ga), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_14_23)]), D_FTrsi_AAAZ_U);
((Z, Z, Z, Ga), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_12_34)]), D_FTrsi_AZZZ_S);
((Z, Z, Z, Ga), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_13_42)]), D_FTrsi_AZZZ_T);
((Z, Z, Z, Ga), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_14_23)]), D_FTrsi_AZZZ_U);
((Ga, Z, Z, Z), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_12_34)]), D_FTrsi_AZZZ_S);
((Ga, Z, Z, Z), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_13_42)]), D_FTrsi_AZZZ_T);
((Ga, Z, Z, Z), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_14_23)]), D_FTrsi_AZZZ_U);
((Z, Z, Ga, Z), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_12_34)]), D_FTrsi_AZZZ_S);
((Z, Z, Ga, Z), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_13_42)]), D_FTrsi_AZZZ_T);
((Z, Z, Ga, Z), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_14_23)]), D_FTrsi_AZZZ_U)]
else
[]
let k_matrix_quartic_gauge_m_0 =
if Flags.k_matrix_tm then
List.map qgc
[ ((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_m0 (0,
[(1, C_12_34)]), D_FM0_WWWW0_S);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_m0 (0,
[(1, C_14_23)]), D_FM0_WWWW0_T);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_m0 (0,
[(1, C_13_42)]), D_FM0_WWWW0_U);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_m0 (0,
[(1, C_12_34)]), D_FM0_WWWW0_S);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_m0 (0,
[(1, C_14_23)]), D_FM0_WWWW0_T);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_m0 (0,
[(1, C_13_42)]), D_FM0_WWWW0_U);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_m0 (0,
[(1, C_12_34)]), D_FM0_WWWW2_S);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_m0 (0,
[(1, C_13_42)]), D_FM0_WWWW2_T);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_m0 (0,
[(1, C_14_23)]), D_FM0_WWWW2_U);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_m0 (0,
[(1, C_12_34)]), D_FM0_ZZWW0_S);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_m0 (0,
[(1, C_13_42)]), D_FM0_ZZWW0_T);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_m0 (0,
[(1, C_14_23)]), D_FM0_ZZWW0_U);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_m0 (0,
[(1, C_12_34)]), D_FM0_ZZWW1_S);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_m0 (0,
[(1, C_13_42)]), D_FM0_ZZWW1_T);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_m0 (0,
[(1, C_14_23)]), D_FM0_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_m0 (1,
[(1, C_12_34)]), D_FM0_ZZWW1_S);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_m0 (1,
[(1, C_13_42)]), D_FM0_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_m0 (1,
[(1, C_14_23)]), D_FM0_ZZWW1_T);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_m0 (2,
[(1, C_12_34)]), D_FM0_ZZWW1_S);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_m0 (2,
[(1, C_13_42)]), D_FM0_ZZWW1_U);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_m0 (2,
[(1, C_14_23)]), D_FM0_ZZWW1_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m0 (0,
[(1, C_12_34)]), D_FM0_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m0 (0,
[(1, C_13_42)]), D_FM0_ZZZZ_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m0 (0,
[(1, C_14_23)]), D_FM0_ZZZZ_U);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m0 (3,
[(1, C_14_23)]), D_FM0_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m0 (3,
[(1, C_13_42)]), D_FM0_ZZZZ_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m0 (3,
[(1, C_12_34)]), D_FM0_ZZZZ_U)]
else
[]
let k_matrix_quartic_gauge_m_1 =
if Flags.k_matrix_tm then
List.map qgc
[ ((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_m1 (0,
[(1, C_12_34)]), D_FM1_WWWW0_S);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_m1 (0,
[(1, C_14_23)]), D_FM1_WWWW0_T);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_m1 (0,
[(1, C_13_42)]), D_FM1_WWWW0_U);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_m1 (0,
[(1, C_12_34)]), D_FM1_WWWW0_S);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_m1 (0,
[(1, C_14_23)]), D_FM1_WWWW0_T);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_m1 (0,
[(1, C_13_42)]), D_FM1_WWWW0_U);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_m1 (0,
[(1, C_12_34)]), D_FM1_WWWW2_S);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_m1 (0,
[(1, C_13_42)]), D_FM1_WWWW2_T);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_m1 (0,
[(1, C_14_23)]), D_FM1_WWWW2_U);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_m1 (0,
[(1, C_12_34)]), D_FM1_ZZWW0_S);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_m1 (0,
[(1, C_13_42)]), D_FM1_ZZWW0_T);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_m1 (0,
[(1, C_14_23)]), D_FM1_ZZWW0_U);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_m1 (0,
[(1, C_12_34)]), D_FM1_ZZWW1_S);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_m1 (0,
[(1, C_13_42)]), D_FM1_ZZWW1_T);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_m1 (0,
[(1, C_14_23)]), D_FM1_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_m1 (1,
[(1, C_12_34)]), D_FM1_ZZWW1_S);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_m1 (1,
[(1, C_13_42)]), D_FM1_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_m1 (1,
[(1, C_14_23)]), D_FM1_ZZWW1_T);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_m1 (2,
[(1, C_12_34)]), D_FM1_ZZWW1_S);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_m1 (2,
[(1, C_13_42)]), D_FM1_ZZWW1_U);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_m1 (2,
[(1, C_14_23)]), D_FM1_ZZWW1_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m1 (0,
[(1, C_12_34)]), D_FM1_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m1 (0,
[(1, C_13_42)]), D_FM1_ZZZZ_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m1 (0,
[(1, C_14_23)]), D_FM1_ZZZZ_U);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m1 (3,
[(1, C_14_23)]), D_FM1_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m1 (3,
[(1, C_13_42)]), D_FM1_ZZZZ_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m1 (3,
[(1, C_12_34)]), D_FM1_ZZZZ_U)]
else
[]
let k_matrix_quartic_gauge_m_7 =
if Flags.k_matrix_tm then
List.map qgc
[ ((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_m7 (0,
[(1, C_12_34)]), D_FM7_WWWW0_S);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_m7 (0,
[(1, C_14_23)]), D_FM7_WWWW0_T);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_m7 (0,
[(1, C_13_42)]), D_FM7_WWWW0_U);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_m7 (0,
[(1, C_12_34)]), D_FM7_WWWW0_S);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_m7 (0,
[(1, C_14_23)]), D_FM7_WWWW0_T);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_m7 (0,
[(1, C_13_42)]), D_FM7_WWWW0_U);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_m7 (0,
[(1, C_12_34)]), D_FM7_WWWW2_S);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_m7 (0,
[(1, C_13_42)]), D_FM7_WWWW2_T);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_m7 (0,
[(1, C_14_23)]), D_FM7_WWWW2_U);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_m7 (0,
[(1, C_12_34)]), D_FM7_ZZWW0_S);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_m7 (0,
[(1, C_13_42)]), D_FM7_ZZWW0_T);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_m7 (0,
[(1, C_14_23)]), D_FM7_ZZWW0_U);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_m7 (0,
[(1, C_12_34)]), D_FM7_ZZWW1_S);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_m7 (0,
[(1, C_13_42)]), D_FM7_ZZWW1_T);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_m7 (0,
[(1, C_14_23)]), D_FM7_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_m7 (1,
[(1, C_12_34)]), D_FM7_ZZWW1_S);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_m7 (1,
[(1, C_13_42)]), D_FM7_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_m7 (1,
[(1, C_14_23)]), D_FM7_ZZWW1_T);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_m7 (2,
[(1, C_12_34)]), D_FM7_ZZWW1_S);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_m7 (2,
[(1, C_13_42)]), D_FM7_ZZWW1_U);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_m7 (2,
[(1, C_14_23)]), D_FM7_ZZWW1_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m7 (0,
[(1, C_12_34)]), D_FM7_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m7 (0,
[(1, C_13_42)]), D_FM7_ZZZZ_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m7 (0,
[(1, C_14_23)]), D_FM7_ZZZZ_U);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m7 (3,
[(1, C_14_23)]), D_FM7_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m7 (3,
[(1, C_13_42)]), D_FM7_ZZZZ_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m7 (3,
[(1, C_12_34)]), D_FM7_ZZZZ_U)]
else
[]
let k_matrix_2scalar_2gauge =
if Flags.k_matrix_tm then
if Flags.higgs_matrix then
[ ((O H,O H,G Z,G Z), DScalar2_Vector2_K_Matrix_ms
(0, [(1, C_12_34)]), D_Alpha_HHZZ0_S);
((O H,O H,G Z,G Z), DScalar2_Vector2_K_Matrix_ms
(0, [(1, C_13_42)]), D_Alpha_HHZZ0_T);
((O H,O H,G Z,G Z), DScalar2_Vector2_K_Matrix_ms
(0, [(1, C_14_23)]), D_Alpha_HHZZ0_T);
((O H,O H,G Z,G Z), DScalar2_Vector2_K_Matrix_ms
(3, [(1, C_14_23)]), D_Alpha_HHZZ1_S);
((O H,O H,G Z,G Z), DScalar2_Vector2_K_Matrix_ms
(3, [(1, C_13_42)]), D_Alpha_HHZZ1_T);
((O H,O H,G Z,G Z), DScalar2_Vector2_K_Matrix_ms
(3, [(1, C_12_34)]), D_Alpha_HHZZ1_U);
((O H,O H,G Z,G Z), DScalar2_Vector2_K_Matrix_ms
(6, [(1, C_13_42)]), D_Alpha_HHZZ1_S);
((O H,O H,G Z,G Z), DScalar2_Vector2_K_Matrix_ms
(6, [(1, C_12_34)]), D_Alpha_HHZZ1_T);
((O H,O H,G Z,G Z), DScalar2_Vector2_K_Matrix_ms
(6, [(1, C_14_23)]), D_Alpha_HHZZ1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_K_Matrix_ms
(0, [(1, C_12_34)]), D_Alpha_HHWW0_S);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_K_Matrix_ms
(2, [(1, C_13_42)]), D_Alpha_HHWW0_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_K_Matrix_ms
(1, [(1, C_14_23)]), D_Alpha_HHWW0_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_K_Matrix_ms
(1, [(1, C_13_42)]), D_Alpha_HHWW0_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_K_Matrix_ms
(2, [(1, C_14_23)]), D_Alpha_HHWW0_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_K_Matrix_ms
(3, [(1, C_14_23)]), D_Alpha_HHWW1_S);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_K_Matrix_ms
(6, [(1, C_13_42)]), D_Alpha_HHWW1_S);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_K_Matrix_ms
(4, [(1, C_13_42)]), D_Alpha_HHWW1_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_K_Matrix_ms
(5, [(1, C_12_34)]), D_Alpha_HHWW1_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_K_Matrix_ms
(8, [(1, C_14_23)]), D_Alpha_HHWW1_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_K_Matrix_ms
(7, [(1, C_12_34)]), D_Alpha_HHWW1_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_K_Matrix_ms
(5, [(1, C_13_42)]), D_Alpha_HHWW1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_K_Matrix_ms
(4, [(1, C_12_34)]), D_Alpha_HHWW1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_K_Matrix_ms
(7, [(1, C_14_23)]), D_Alpha_HHWW1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_K_Matrix_ms
(8, [(1, C_12_34)]), D_Alpha_HHWW1_U) ]
else
[]
else
[]
let k_matrix_2scalar_2gauge_m =
if Flags.k_matrix_tm then
if Flags.higgs_matrix then
[ ((O H,O H,G Z,G Z), DScalar2_Vector2_m_0_K_Matrix_cf
(0, [(1, C_12_34)]), D_FM0_HHZZ0_S);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_0_K_Matrix_cf
(0, [(1, C_13_42)]), D_FM0_HHZZ0_T);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_0_K_Matrix_cf
(0, [(1, C_14_23)]), D_FM0_HHZZ0_U);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_0_K_Matrix_cf
(3, [(1, C_14_23)]), D_FM0_HHZZ1_S);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_0_K_Matrix_cf
(3, [(1, C_13_42)]), D_FM0_HHZZ1_U);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_0_K_Matrix_cf
(3, [(1, C_12_34)]), D_FM0_HHZZ1_T);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_0_K_Matrix_cf
(6, [(1, C_13_42)]), D_FM0_HHZZ1_S);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_0_K_Matrix_cf
(6, [(1, C_12_34)]), D_FM0_HHZZ1_T);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_0_K_Matrix_cf
(6, [(1, C_14_23)]), D_FM0_HHZZ1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_0_K_Matrix_cf
(0, [(1, C_12_34)]), D_FM0_HHWW0_S);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_0_K_Matrix_cf
(2, [(1, C_13_42)]), D_FM0_HHWW0_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_0_K_Matrix_cf
(1, [(1, C_14_23)]), D_FM0_HHWW0_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_0_K_Matrix_cf
(1, [(1, C_13_42)]), D_FM0_HHWW0_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_0_K_Matrix_cf
(2, [(1, C_14_23)]), D_FM0_HHWW0_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_0_K_Matrix_cf
(3, [(1, C_14_23)]), D_FM0_HHWW1_S);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_0_K_Matrix_cf
(6, [(1, C_13_42)]), D_FM0_HHWW1_S);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_0_K_Matrix_cf
(4, [(1, C_13_42)]), D_FM0_HHWW1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_0_K_Matrix_cf
(5, [(1, C_12_34)]), D_FM0_HHWW1_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_0_K_Matrix_cf
(8, [(1, C_14_23)]), D_FM0_HHWW1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_0_K_Matrix_cf
(7, [(1, C_12_34)]), D_FM0_HHWW1_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_0_K_Matrix_cf
(5, [(1, C_13_42)]), D_FM0_HHWW1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_0_K_Matrix_cf
(4, [(1, C_12_34)]), D_FM0_HHWW1_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_0_K_Matrix_cf
(7, [(1, C_14_23)]), D_FM0_HHWW1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_0_K_Matrix_cf
(8, [(1, C_12_34)]), D_FM0_HHWW1_T) ]
else
[]
else
[]
let k_matrix_2scalar_2gauge_m_1 =
if Flags.k_matrix_tm then
if Flags.higgs_matrix then
[ ((O H,O H,G Z,G Z), DScalar2_Vector2_m_1_K_Matrix_cf
(0, [(1, C_12_34)]), D_FM1_HHZZ0_S);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_1_K_Matrix_cf
(0, [(1, C_13_42)]), D_FM1_HHZZ0_T);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_1_K_Matrix_cf
(0, [(1, C_14_23)]), D_FM1_HHZZ0_U);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_1_K_Matrix_cf
(3, [(1, C_14_23)]), D_FM1_HHZZ1_S);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_1_K_Matrix_cf
(3, [(1, C_13_42)]), D_FM1_HHZZ1_U);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_1_K_Matrix_cf
(3, [(1, C_12_34)]), D_FM1_HHZZ1_T);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_1_K_Matrix_cf
(6, [(1, C_13_42)]), D_FM1_HHZZ1_S);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_1_K_Matrix_cf
(6, [(1, C_12_34)]), D_FM1_HHZZ1_T);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_1_K_Matrix_cf
(6, [(1, C_14_23)]), D_FM1_HHZZ1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_1_K_Matrix_cf
(0, [(1, C_12_34)]), D_FM1_HHWW0_S);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_1_K_Matrix_cf
(2, [(1, C_13_42)]), D_FM1_HHWW0_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_1_K_Matrix_cf
(1, [(1, C_14_23)]), D_FM1_HHWW0_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_1_K_Matrix_cf
(1, [(1, C_13_42)]), D_FM1_HHWW0_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_1_K_Matrix_cf
(2, [(1, C_14_23)]), D_FM1_HHWW0_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_1_K_Matrix_cf
(3, [(1, C_14_23)]), D_FM1_HHWW1_S);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_1_K_Matrix_cf
(6, [(1, C_13_42)]), D_FM1_HHWW1_S);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_1_K_Matrix_cf
(4, [(1, C_13_42)]), D_FM1_HHWW1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_1_K_Matrix_cf
(5, [(1, C_12_34)]), D_FM1_HHWW1_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_1_K_Matrix_cf
(8, [(1, C_14_23)]), D_FM1_HHWW1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_1_K_Matrix_cf
(7, [(1, C_12_34)]), D_FM1_HHWW1_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_1_K_Matrix_cf
(5, [(1, C_13_42)]), D_FM1_HHWW1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_1_K_Matrix_cf
(4, [(1, C_12_34)]), D_FM1_HHWW1_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_1_K_Matrix_cf
(7, [(1, C_14_23)]), D_FM1_HHWW1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_1_K_Matrix_cf
(8, [(1, C_12_34)]), D_FM1_HHWW1_T) ]
else
[]
else
[]
let k_matrix_2scalar_2gauge_m_7 =
if Flags.k_matrix_tm then
if Flags.higgs_matrix then
[ ((O H,O H,G Z,G Z), DScalar2_Vector2_m_7_K_Matrix_cf
(0, [(1, C_12_34)]), D_FM7_HHZZ0_S);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_7_K_Matrix_cf
(0, [(1, C_13_42)]), D_FM7_HHZZ0_T);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_7_K_Matrix_cf
(0, [(1, C_14_23)]), D_FM7_HHZZ0_U);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_7_K_Matrix_cf
(3, [(1, C_14_23)]), D_FM7_HHZZ1_S);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_7_K_Matrix_cf
(3, [(1, C_13_42)]), D_FM7_HHZZ1_U);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_7_K_Matrix_cf
(3, [(1, C_12_34)]), D_FM7_HHZZ1_T);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_7_K_Matrix_cf
(6, [(1, C_13_42)]), D_FM7_HHZZ1_S);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_7_K_Matrix_cf
(6, [(1, C_12_34)]), D_FM7_HHZZ1_T);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_7_K_Matrix_cf
(6, [(1, C_14_23)]), D_FM7_HHZZ1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_7_K_Matrix_cf
(0, [(1, C_12_34)]), D_FM7_HHWW0_S);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_7_K_Matrix_cf
(2, [(1, C_13_42)]), D_FM7_HHWW0_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_7_K_Matrix_cf
(1, [(1, C_14_23)]), D_FM7_HHWW0_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_7_K_Matrix_cf
(1, [(1, C_13_42)]), D_FM7_HHWW0_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_7_K_Matrix_cf
(2, [(1, C_14_23)]), D_FM7_HHWW0_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_7_K_Matrix_cf
(3, [(1, C_14_23)]), D_FM7_HHWW1_S);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_7_K_Matrix_cf
(6, [(1, C_13_42)]), D_FM7_HHWW1_S);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_7_K_Matrix_cf
(4, [(1, C_13_42)]), D_FM7_HHWW1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_7_K_Matrix_cf
(5, [(1, C_12_34)]), D_FM7_HHWW1_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_7_K_Matrix_cf
(8, [(1, C_14_23)]), D_FM7_HHWW1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_7_K_Matrix_cf
(7, [(1, C_12_34)]), D_FM7_HHWW1_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_7_K_Matrix_cf
(5, [(1, C_13_42)]), D_FM7_HHWW1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_7_K_Matrix_cf
(4, [(1, C_12_34)]), D_FM7_HHWW1_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_7_K_Matrix_cf
(7, [(1, C_14_23)]), D_FM7_HHWW1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_7_K_Matrix_cf
(8, [(1, C_12_34)]), D_FM7_HHWW1_T) ]
else
[]
else
[]
let k_matrix_4scalar =
if Flags.k_matrix then
if Flags.higgs_matrix then
[ ((O H,O H,O H,O H), DScalar4_K_Matrix_ms
(0, [(1, C_12_34)]), D_Alpha_HHHH_S);
((O H,O H,O H,O H), DScalar4_K_Matrix_ms
(0, [(1, C_13_42)]), D_Alpha_HHHH_T);
((O H,O H,O H,O H), DScalar4_K_Matrix_ms
(0, [(1, C_14_23)]), D_Alpha_HHHH_T);
((O H,O H,O H,O H), DScalar4_K_Matrix_ms
(3, [(1, C_14_23)]), D_Alpha_HHHH_S);
((O H,O H,O H,O H), DScalar4_K_Matrix_ms
(3, [(1, C_13_42)]), D_Alpha_HHHH_T);
((O H,O H,O H,O H), DScalar4_K_Matrix_ms
(3, [(1, C_12_34)]), D_Alpha_HHHH_T) ]
else
[]
else
[]
(*i Thorsten's original implementation of the K matrix, which we keep since
it still might be usefull for the future.
let k_matrix_quartic_gauge =
if Flags.k_matrix then
List.map qgc
[ ((Wm, Wp, Wm, Wp), Vector4_K_Matrix_tho (0, [K_Matrix_Coeff 0,
K_Matrix_Pole 0]), Alpha_WWWW0);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_tho (0, [K_Matrix_Coeff 2,
K_Matrix_Pole 2]), Alpha_WWWW2);
((Wm, Wp, Z, Z), Vector4_K_Matrix_tho (0, [(K_Matrix_Coeff 0,
K_Matrix_Pole 0); (K_Matrix_Coeff 2,
K_Matrix_Pole 2)]), Alpha_ZZWW0);
((Wm, Z, Wp, Z), Vector4_K_Matrix_tho (0, [K_Matrix_Coeff 1,
K_Matrix_Pole 1]), Alpha_ZZWW1);
((Z, Z, Z, Z), Vector4_K_Matrix_tho (0, [K_Matrix_Coeff 0,
K_Matrix_Pole 0]), Alpha_ZZZZ) ]
else
[]
i*)
let quartic_gauge =
standard_quartic_gauge @ anomalous_quartic_gauge @ k_matrix_quartic_gauge
@ k_matrix_quartic_gauge_t_0 @ k_matrix_quartic_gauge_t_1 @ k_matrix_quartic_gauge_t_2
@ k_matrix_quartic_gauge_t_rsi
@ k_matrix_quartic_gauge_m_0 @ k_matrix_quartic_gauge_m_1 @ k_matrix_quartic_gauge_m_7
let standard_gauge_higgs =
[ ((O H, G Wp, G Wm), Scalar_Vector_Vector 1, G_HWW);
((O H, G Z, G Z), Scalar_Vector_Vector 1, G_HZZ) ]
let standard_gauge_higgs4 =
[ (O H, O H, G Wp, G Wm), Scalar2_Vector2 1, G_HHWW;
(O H, O H, G Z, G Z), Scalar2_Vector2 1, G_HHZZ ]
let dim8_gauge_higgs4 =
[ (O H, O H, G Wp, G Wm), Dim8_Scalar2_Vector2_1 1, FS0_HHWW;
(O H, O H, G Z, G Z), Dim8_Scalar2_Vector2_1 1, FS0_HHZZ;
(O H, O H, G Wp, G Wm), Dim8_Scalar2_Vector2_2 1, FS1_HHWW;
(O H, O H, G Z, G Z), Dim8_Scalar2_Vector2_2 1, FS1_HHZZ ]
let dim8_gauge_higgs4_m =
[ (O H, O H, G Wp, G Wm), Dim8_Scalar2_Vector2_m_0 1, FM0_HHWW;
(O H, O H, G Z, G Z), Dim8_Scalar2_Vector2_m_0 1, FM0_HHZZ;
(O H, O H, G Wp, G Wm), Dim8_Scalar2_Vector2_m_1 1, FM1_HHWW;
(O H, O H, G Z, G Z), Dim8_Scalar2_Vector2_m_1 1, FM1_HHZZ;
(O H, O H, G Wp, G Wm), Dim8_Scalar2_Vector2_m_7 1, FM7_HHWW;
(O H, O H, G Z, G Z), Dim8_Scalar2_Vector2_m_7 1, FM7_HHZZ]
let standard_higgs =
[ (O H, O H, O H), Scalar_Scalar_Scalar 1, G_H3 ]
let standard_higgs4 =
[ (O H, O H, O H, O H), Scalar4 1, G_H4 ]
let fs_higgs4 =
[ (O H, O H, O H, O H), Dim8_Scalar4 1, FS_H4 ]
(* WK's couplings (apparently, he still intends to divide by
$\Lambda^2_{\text{EWSB}}=16\pi^2v_{\mathrm{F}}^2$):
\begin{subequations}
\begin{align}
\mathcal{L}^{\tau}_4 &=
\left\lbrack (\partial_{\mu}H)(\partial^{\mu}H)
+ \frac{g^2v_{\mathrm{F}}^2}{4} V_{\mu} V^{\mu} \right\rbrack^2 \\
\mathcal{L}^{\tau}_5 &=
\left\lbrack (\partial_{\mu}H)(\partial_{\nu}H)
+ \frac{g^2v_{\mathrm{F}}^2}{4} V_{\mu} V_{\nu} \right\rbrack^2
\end{align}
\end{subequations}
with
\begin{equation}
V_{\mu} V_{\nu} =
\frac{1}{2} \left( W^+_{\mu} W^-_{\nu} + W^+_{\nu} W^-_{\mu} \right)
+ \frac{1}{2\cos^2\theta_{w}} Z_{\mu} Z_{\nu}
\end{equation}
(note the symmetrization!), i.\,e.
\begin{subequations}
\begin{align}
\mathcal{L}_4 &= \alpha_4 \frac{g^4v_{\mathrm{F}}^4}{16} (V_{\mu} V_{\nu})^2 \\
\mathcal{L}_5 &= \alpha_5 \frac{g^4v_{\mathrm{F}}^4}{16} (V_{\mu} V^{\mu})^2
\end{align}
\end{subequations} *)
(* Breaking thinks up
\begin{subequations}
\begin{align}
\mathcal{L}^{\tau,H^4}_4 &=
\left\lbrack (\partial_{\mu}H)(\partial^{\mu}H) \right\rbrack^2 \\
\mathcal{L}^{\tau,H^4}_5 &=
\left\lbrack (\partial_{\mu}H)(\partial^{\mu}H) \right\rbrack^2
\end{align}
\end{subequations}
and
\begin{subequations}
\begin{align}
\mathcal{L}^{\tau,H^2V^2}_4 &= \frac{g^2v_{\mathrm{F}}^2}{2}
(\partial_{\mu}H)(\partial^{\mu}H) V_{\mu}V^{\mu} \\
\mathcal{L}^{\tau,H^2V^2}_5 &= \frac{g^2v_{\mathrm{F}}^2}{2}
(\partial_{\mu}H)(\partial_{\nu}H) V_{\mu}V_{\nu}
\end{align}
\end{subequations}
i.\,e.
\begin{subequations}
\begin{align}
\mathcal{L}^{\tau,H^2V^2}_4 &=
\frac{g^2v_{\mathrm{F}}^2}{2}
\left\lbrack
(\partial_{\mu}H)(\partial^{\mu}H) W^+_{\nu}W^{-,\nu}
+ \frac{1}{2\cos^2\theta_{w}} (\partial_{\mu}H)(\partial^{\mu}H) Z_{\nu} Z^{\nu}
\right\rbrack \\
\mathcal{L}^{\tau,H^2V^2}_5 &=
\frac{g^2v_{\mathrm{F}}^2}{2}
\left\lbrack
(W^{+,\mu}\partial_{\mu}H) (W^{-,\nu}\partial_{\nu}H)
+ \frac{1}{2\cos^2\theta_{w}} (Z^{\mu}\partial_{\mu}H)(Z^{\nu}\partial_{\nu}H)
\right\rbrack
\end{align}
\end{subequations} *)
(* \begin{multline}
\tau^4_8 \mathcal{L}^{\tau,H^2V^2}_4 + \tau^5_8 \mathcal{L}^{\tau,H^2V^2}_5 = \\
- \frac{g^2v_{\mathrm{F}}^2}{2} \Biggl\lbrack
2\tau^4_8
\frac{1}{2}(\ii\partial_{\mu}H)(\ii\partial^{\mu}H) W^+_{\nu}W^{-,\nu}
+ \tau^5_8
(W^{+,\mu}\ii\partial_{\mu}H) (W^{-,\nu}\ii\partial_{\nu}H) \\
+ \frac{2\tau^4_8}{\cos^2\theta_{w}}
\frac{1}{4} (\ii\partial_{\mu}H)(\ii\partial^{\mu}H) Z_{\nu} Z^{\nu}
+ \frac{\tau^5_8}{\cos^2\theta_{w}}
\frac{1}{2} (Z^{\mu}\ii\partial_{\mu}H)(Z^{\nu}\ii\partial_{\nu}H)
\Biggr\rbrack
\end{multline}
where the two powers of $\ii$ make the sign conveniently negative,
i.\,e.
\begin{subequations}
\begin{align}
\alpha_{(\partial H)^2W^2}^2 &= \tau^4_8 g^2v_{\mathrm{F}}^2\\
\alpha_{(\partial HW)^2}^2 &= \frac{\tau^5_8 g^2v_{\mathrm{F}}^2}{2} \\
\alpha_{(\partial H)^2Z^2}^2 &= \frac{\tau^4_8 g^2v_{\mathrm{F}}^2}{\cos^2\theta_{w}} \\
\alpha_{(\partial HZ)^2}^2 &=\frac{\tau^5_8 g^2v_{\mathrm{F}}^2}{2\cos^2\theta_{w}}
\end{align}
\end{subequations} *)
let anomalous_gauge_higgs =
[ (O H, G Ga, G Ga), Dim5_Scalar_Gauge2 1, G_HGaGa_anom;
(O H, G Ga, G Z), Dim5_Scalar_Gauge2 1, G_HGaZ_anom;
(O H, G Z, G Z), Dim5_Scalar_Gauge2 1, G_HZZ_anom;
(O H, G Wp, G Wm), Dim5_Scalar_Gauge2 1, G_HWW_anom;
(O H, G Ga, G Z), Dim5_Scalar_Vector_Vector_U 1, G_HGaZ_u;
(O H, G Z, G Z), Dim5_Scalar_Vector_Vector_U 1, G_HZZ_u;
(O H, G Wp, G Wm), Dim5_Scalar_Vector_Vector_U 1, G_HWW_u;
(O H, G Wm, G Wp), Dim5_Scalar_Vector_Vector_U 1, G_HWW_u
]
let anomalous_gauge_higgs4 =
[]
let anomalous_higgs =
[]
let higgs_triangle_vertices =
if Flags.higgs_triangle then
[ (O H, G Ga, G Ga), Dim5_Scalar_Gauge2 1, G_HGaGa;
(O H, G Ga, G Z), Dim5_Scalar_Gauge2 1, G_HGaZ;
(O H, G Gl, G Gl), Dim5_Scalar_Gauge2 1, G_Hgg ]
else
[]
let anomalous_higgs4 =
[]
let gauge_higgs =
if Flags.higgs_anom then
standard_gauge_higgs @ anomalous_gauge_higgs
else
standard_gauge_higgs
let gauge_higgs4 =
( if Flags.higgs_anom then
standard_gauge_higgs4 @ anomalous_gauge_higgs4
else
standard_gauge_higgs4 ) @
( if Flags.higgs_matrix then
(dim8_gauge_higgs4 @ dim8_gauge_higgs4_m @ k_matrix_2scalar_2gauge
@ k_matrix_2scalar_2gauge_m @ k_matrix_2scalar_2gauge_m_1 @ k_matrix_2scalar_2gauge_m_7)
else
[] )
let higgs =
if Flags.higgs_anom then
standard_higgs @ anomalous_higgs
else
standard_higgs
let higgs4 =
( if Flags.higgs_anom then
standard_higgs4 @ anomalous_higgs4
else
standard_higgs4 ) @
( if Flags.higgs_matrix then
(fs_higgs4 @ k_matrix_4scalar )
else
[] )
let goldstone_vertices =
[ ((O Phi0, G Wm, G Wp), Scalar_Vector_Vector 1, I_G_ZWW);
((O Phip, G Ga, G Wm), Scalar_Vector_Vector 1, I_Q_W);
((O Phip, G Z, G Wm), Scalar_Vector_Vector 1, I_G_ZWW);
((O Phim, G Wp, G Ga), Scalar_Vector_Vector 1, I_Q_W);
((O Phim, G Wp, G Z), Scalar_Vector_Vector 1, I_G_ZWW) ]
(* New Resonances *)
(*
\begin{dubious}
There is an extra minus in the Lagrangian to have the same sign as
HWW or HZZ vertex.
Effectivly this doesn't matter for SSC, because $(-1)^2=1$.
This is only for completeness.
\end{dubious}
\begin{subequations}
\begin{align}
\mathbf{V}_\mu &= -\mathrm{i} g\mathbf{W}_\mu+\mathrm{i} g^\prime\mathbf{B}_\mu \\
\mathbf{W}_\mu &= W_\mu^a\frac{\tau^a}{2} \\
\mathbf{B}_\mu &= W_\mu^a\frac{\tau^3}{2} \\
\tau^{++}&= \tau^+ \otimes \tau^+ \\
\tau^+ &= \frac{1}{2} \left (\tau^+ \otimes \tau^3 + \tau^3+\tau^+ \right ) \\
\tau^0 &= \frac{1}{\sqrt{6}} \left (\tau^3\otimes\tau^3 -\tau^+ \otimes \tau^- - \tau^-+\tau^+ \right ) \\
\tau^- &= \frac{1}{2} \left (\tau^- \otimes \tau^3 + \tau^3+\tau^- \right ) \\
\tau^{--}&= \tau^- \otimes \tau^-
\end{align}
\end{subequations}
*)
(* Scalar Isoscalar
Old representation
\begin{equation}
\mathcal{L}_{\sigma}=
-\frac{g_\sigma v}{2} \text{tr}
\left\lbrack \mathbf{V}_\mu \mathbf{V}^\mu \right\rbrack \sigma
\end{equation}
*)
(* \begin{dubious}
Transversal couplings like rsigma3t and rf3t are to be calculated in the new
higgs matrix representation.
\end{dubious} *)
let rsigma3 =
[ ((O Rsigma, G Wp, G Wm), Scalar_Vector_Vector 1, G_SWW);
((O Rsigma, G Z, G Z), Scalar_Vector_Vector 1, G_SZZ) ]
let rsigma3h =
[ ((O Rsigma, O H, O H), Dim5_Scalar_Scalar2 1, G_SHH) ]
let rsigma3t =
[ ((O Rsigma, G Wp, G Wm), Scalar_Vector_Vector_t 1, G_SWW_T);
((O Rsigma, G Z, G Z), Scalar_Vector_Vector_t 1, G_SZZ_T);
((O Rsigma, G Ga, G Ga), Scalar_Vector_Vector_t 1, G_SAA_T);
((O Rsigma, G Ga, G Z), Scalar_Vector_Vector_t 1, G_SAZ_T) ]
let rsigma4 =
[ (O Rsigma, O Rsigma, G Wp, G Wm), Scalar2_Vector2 1, G_SSWW;
(O Rsigma, O Rsigma, G Z, G Z), Scalar2_Vector2 1, G_SSZZ ]
(* Scalar Isotensor
\begin{subequations}
\begin{align}
\mathcal{L}_{\phi}&=
\frac{g_\phi v}{4} \text{Tr}
\left \lbrack \left ( \mathbf{V}_\mu \otimes \mathbf{V}^\mu - \frac{\tau^{aa}}{6} \text{Tr} \left \lbrack \mathbf{V}_\mu \mathbf{V}^\mu \right \rbrack\right ) {\mathbf{\phi}} \right \rbrack\\
\phi&=\sqrt{2} \left (\phi^{++}\tau^{++}+\phi^+\tau^++\phi^0\tau^0+\phi^-\tau^- + \phi^{--}\tau^{--} \right )
\end{align}
\end{subequations}
*)
let rphi3 =
[ ((O Rphin, G Wp, G Wm), Scalar_Vector_Vector 1, G_PNWW);
((O Rphin, G Z, G Z), Scalar_Vector_Vector 1, G_PNZZ) ;
((O Rphisn, G Wp, G Wm), Scalar_Vector_Vector 1, G_PSNWW);
((O Rphisn, G Z, G Z), Scalar_Vector_Vector 1, G_PSNZZ) ;
((O Rphip, G Z, G Wm), Scalar_Vector_Vector 1, G_PWZ) ;
((O Rphipp, G Wm, G Wm), Scalar_Vector_Vector 1, G_PWW) ;
((O Rphim, G Wp, G Z), Scalar_Vector_Vector 1, G_PWZ) ;
((O Rphimm, G Wp, G Wp), Scalar_Vector_Vector 1, G_PWW) ]
let rphi3h =
[ ((O Rphisn, O H, O H), Dim5_Scalar_Scalar2 1, G_PSNHH) ]
(* Tensor IsoScalar
*)
let rf3 =
[ ((O Rf, G Wp, G Wm), Tensor_2_Vector_Vector_1 1, G_FWW);
((O Rf, G Z, G Z), Tensor_2_Vector_Vector_1 1, G_FZZ) ]
let rf3cf =
[ ((O Rf, G Wp, G Wm), Tensor_2_Vector_Vector 1, G_FWW);
((O Rf, G Z, G Z), Tensor_2_Vector_Vector 1, G_FZZ);
((O Rf, G Wp, G Wm), Tensor_2_Vector_Vector_cf 1, G_FWW_CF);
((O Rf, G Z, G Z), Tensor_2_Vector_Vector_cf 1, G_FZZ_CF) ]
let rf3h =
[ ((O Rf, O H, O H), Tensor_2_Scalar_Scalar 1, G_FHH);
((O Rf, O H, O H), Tensor_2_Scalar_Scalar_cf 1, G_FHH_CF) ]
let rf3t =
[ ((O Rf, G Wp, G Wm), Tensor_2_Vector_Vector_t 1, G_FWW_T);
((O Rf, G Z, G Z), Tensor_2_Vector_Vector_t 1, G_FZZ_T) ]
(* Tensor Isotensor
\begin{subequations}
\begin{align}
\mathcal{L}_{t}
\end{align}
\end{subequations}
*)
let rt3 =
[ ((O Rtn, G Wp, G Wm), Tensor_2_Vector_Vector_1 1, G_TNWW);
((O Rtn, G Z, G Z), Tensor_2_Vector_Vector_1 1, G_TNZZ) ;
((O Rtsn, G Wp, G Wm), Tensor_2_Vector_Vector_1 1, G_TSNWW);
((O Rtsn, G Z, G Z), Tensor_2_Vector_Vector_1 1, G_TSNZZ) ;
((O Rtp, G Z, G Wm), Tensor_2_Vector_Vector_1 1, G_TWZ) ;
((O Rtpp, G Wm, G Wm), Tensor_2_Vector_Vector_1 1, G_TWW) ;
((O Rtm, G Wp, G Z), Tensor_2_Vector_Vector_1 1, G_TWZ) ;
((O Rtmm, G Wp, G Wp), Tensor_2_Vector_Vector_1 1, G_TWW) ]
let rt3cf =
[ ((O Rtn, G Wp, G Wm), Tensor_2_Vector_Vector 1, G_TNWW);
((O Rtn, G Z, G Z), Tensor_2_Vector_Vector 1, G_TNZZ) ;
((O Rtsn, G Wp, G Wm), Tensor_2_Vector_Vector 1, G_TSNWW);
((O Rtsn, G Z, G Z), Tensor_2_Vector_Vector 1, G_TSNZZ) ;
((O Rtp, G Z, G Wm), Tensor_2_Vector_Vector 1, G_TWZ) ;
((O Rtpp, G Wm, G Wm), Tensor_2_Vector_Vector 1, G_TWW) ;
((O Rtm, G Wp, G Z), Tensor_2_Vector_Vector 1, G_TWZ) ;
((O Rtmm, G Wp, G Wp), Tensor_2_Vector_Vector 1, G_TWW);
((O Rtn, G Wp, G Wm), Tensor_2_Vector_Vector_cf 1, G_TNWW_CF);
((O Rtn, G Z, G Z), Tensor_2_Vector_Vector_cf 1, G_TNZZ_CF) ;
((O Rtsn, G Wp, G Wm), Tensor_2_Vector_Vector_cf 1, G_TSNWW_CF);
((O Rtsn, G Z, G Z), Tensor_2_Vector_Vector_cf 1, G_TSNZZ_CF) ;
((O Rtp, G Z, G Wm), Tensor_2_Vector_Vector_cf 1, G_TWZ_CF) ;
((O Rtpp, G Wm, G Wm), Tensor_2_Vector_Vector_cf 1, G_TWW_CF) ;
((O Rtm, G Wp, G Z), Tensor_2_Vector_Vector_cf 1, G_TWZ_CF) ;
((O Rtmm, G Wp, G Wp), Tensor_2_Vector_Vector_cf 1, G_TWW_CF) ]
(* Anomalous trilinear interactions $f_i f_j V$ and $ttH$:
\begin{equation}
\Delta\mathcal{L}_{tt\gamma} =
- e \frac{\upsilon}{\Lambda^2}
\bar{t} i\sigma^{\mu\nu} k_\nu (d_V(k^2) + i d_A(k^2) \gamma_5) t A_\mu
\end{equation} *)
let anomalous_ttA =
if Flags.top_anom then
[ ((M (U (-3)), G Ga, M (U 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_ttA) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{bb\gamma} =
- e \frac{\upsilon}{\Lambda^2}
\bar{b} i\sigma^{\mu\nu} k_\nu (d_V(k^2) + i d_A(k^2) \gamma_5) b A_\mu
\end{equation} *)
let anomalous_bbA =
if Flags.top_anom then
[ ((M (D (-3)), G Ga, M (D 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_bbA) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{ttg} =
- g_s \frac{\upsilon}{\Lambda^2}
\bar{t}\lambda^a i\sigma^{\mu\nu}k_\nu
(d_V(k^2)+id_A(k^2)\gamma_5)tG^a_\mu
\end{equation} *)
let anomalous_ttG =
if Flags.top_anom then
[ ((M (U (-3)), G Gl, M (U 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_ttG) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{ttZ} =
- \frac{g}{2 c_W} \frac{\upsilon^2}{\Lambda^2}\left\lbrack
\bar{t} \fmslash{Z} (X_L(k^2) P_L + X_R(k^2) P_R) t
+ \bar{t}\frac{i\sigma^{\mu\nu}k_\nu}{m_Z}
(d_V(k^2)+id_A(k^2)\gamma_5)tZ_\mu\right\rbrack
\end{equation} *)
let anomalous_ttZ =
if Flags.top_anom then
[ ((M (U (-3)), G Z, M (U 3)), FBF (1, Psibar, VLRM, Psi), G_VLR_ttZ);
((M (U (-3)), G Z, M (U 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_ttZ) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{bbZ} =
- \frac{g}{2 c_W} \frac{\upsilon^2}{\Lambda^2}
\bar{b}\frac{i\sigma^{\mu\nu}k_\nu}{m_Z}
(d_V(k^2)+id_A(k^2)\gamma_5)bZ_\mu
\end{equation} *)
let anomalous_bbZ =
if Flags.top_anom then
[ ((M (D (-3)), G Z, M (D 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_bbZ) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{tbW} =
- \frac{g}{\sqrt{2}} \frac{\upsilon^2}{\Lambda^2}\left\lbrack
\bar{b}\fmslash{W}^-(V_L(k^2) P_L+V_R(k^2) P_R) t
+ \bar{b}\frac{i\sigma^{\mu\nu}k_\nu}{m_W}
(g_L(k^2)P_L+g_R(k^2)P_R)tW^-_\mu\right\rbrack
+ \textnormal{H.c.}
\end{equation} *)
let anomalous_tbW =
if Flags.top_anom then
[ ((M (D (-3)), G Wm, M (U 3)), FBF (1, Psibar, VLRM, Psi), G_VLR_btW);
((M (U (-3)), G Wp, M (D 3)), FBF (1, Psibar, VLRM, Psi), G_VLR_tbW);
((M (D (-3)), G Wm, M (U 3)), FBF (1, Psibar, TLRM, Psi), G_TLR_btW);
((M (U (-3)), G Wp, M (D 3)), FBF (1, Psibar, TRLM, Psi), G_TRL_tbW) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{ttH} =
- \frac{1}{\sqrt{2}} \bar{t} (Y_V(k^2)+iY_A(k^2)\gamma_5)t H
\end{equation} *)
let anomalous_ttH =
if Flags.top_anom then
[ ((M (U (-3)), O H, M (U 3)), FBF (1, Psibar, SPM, Psi), G_SP_ttH) ]
else
[]
(* quartic fermion-gauge interactions $f_i f_j V_1 V_2$ emerging from gauge-invariant
effective operators:
\begin{equation}
\Delta\mathcal{L}_{ttgg} =
- \frac{g_s^2}{2} f_{abc} \frac{\upsilon}{\Lambda^2}
\bar{t} \lambda^a \sigma^{\mu\nu}
(d_V(k^2)+id_A(k^2)\gamma_5)t G^b_\mu G^c_\nu
\end{equation} *)
let anomalous_ttGG =
if Flags.top_anom then
[ ((M (U (-3)), O (Aux_top (2,1,0,true,TTGG)), M (U 3)), FBF (1, Psibar, TVA, Psi), G_TVA_ttGG);
((O (Aux_top (2,1,0,false,TTGG)), G Gl, G Gl), Aux_Gauge_Gauge 1, I_Gs) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{tbWA} =
- i\sin\theta_w \frac{g^2}{2\sqrt{2}} \frac{\upsilon^2}{\Lambda^2}\left\lbrack
\bar{b}\frac{\sigma^{\mu\nu}}{m_W}
(g_L(k^2)P_L+g_R(k^2)P_R)t A_\mu W^-_\nu \right\rbrack
+ \textnormal{H.c.}
\end{equation} *)
let anomalous_tbWA =
if Flags.top_anom then
[ ((M (D (-3)), O (Aux_top (2,0,-1,true,TBWA)), M (U 3)), FBF (1, Psibar, TLR, Psi), G_TLR_btWA);
((O (Aux_top (2,0,1,false,TBWA)), G Ga, G Wm), Aux_Gauge_Gauge 1, I_G_weak);
((M (U (-3)), O (Aux_top (2,0,1,true,TBWA)), M (D 3)), FBF (1, Psibar, TRL, Psi), G_TRL_tbWA);
((O (Aux_top (2,0,-1,false,TBWA)), G Wp, G Ga), Aux_Gauge_Gauge 1, I_G_weak) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{tbWZ} =
- i\cos\theta_w \frac{g^2}{2\sqrt{2}} \frac{\upsilon^2}{\Lambda^2}\left\lbrack
\bar{b}\frac{\sigma^{\mu\nu}}{m_W}
(g_L(k^2)P_L+g_R(k^2)P_R)t Z_\mu W^-_\nu \right\rbrack
+ \textnormal{H.c.}
\end{equation} *)
let anomalous_tbWZ =
if Flags.top_anom then
[ ((M (D (-3)), O (Aux_top (2,0,-1,true,TBWZ)), M (U 3)), FBF (1, Psibar, TLR, Psi), G_TLR_btWZ);
((O (Aux_top (2,0,1,false,TBWZ)), G Z, G Wm), Aux_Gauge_Gauge 1, I_G_weak);
((M (U (-3)), O (Aux_top (2,0,1,true,TBWZ)), M (D 3)), FBF (1, Psibar, TRL, Psi), G_TRL_tbWZ);
((O (Aux_top (2,0,-1,false,TBWZ)), G Wp, G Z), Aux_Gauge_Gauge 1, I_G_weak) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{ttWW} =
- i \frac{g^2}{2} \frac{\upsilon^2}{\Lambda^2}
\bar{t} \frac{\sigma^{\mu\nu}}{m_W}
(d_V(k^2)+id_A(k^2)\gamma_5)t W^-_\mu W^+_\nu
\end{equation} *)
let anomalous_ttWW =
if Flags.top_anom then
[ ((M (U (-3)), O (Aux_top (2,0,0,true,TTWW)), M (U 3)), FBF (1, Psibar, TVA, Psi), G_TVA_ttWW);
((O (Aux_top (2,0,0,false,TTWW)), G Wm, G Wp), Aux_Gauge_Gauge 1, I_G_weak) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{bbWW} =
- i \frac{g^2}{2} \frac{\upsilon^2}{\Lambda^2}
\bar{b} \frac{\sigma^{\mu\nu}}{m_W}
(d_V(k^2)+id_A(k^2)\gamma_5)b W^-_\mu W^+_\nu
\end{equation} *)
let anomalous_bbWW =
if Flags.top_anom then
[ ((M (D (-3)), O (Aux_top (2,0,0,true,BBWW)), M (D 3)), FBF (1, Psibar, TVA, Psi), G_TVA_bbWW);
((O (Aux_top (2,0,0,false,BBWW)), G Wm, G Wp), Aux_Gauge_Gauge 1, I_G_weak) ]
else
[]
(* 4-fermion contact terms emerging from operator rewriting: *)
let anomalous_top_qGuG_tt =
[ ((M (U (-3)), O (Aux_top (1,1,0,true,QGUG)), M (U 3)), FBF (1, Psibar, VLR, Psi), G_VLR_qGuG) ]
let anomalous_top_qGuG_ff n =
List.map mom
[ ((U (-n), Aux_top (1,1,0,false,QGUG), U n), FBF (1, Psibar, V, Psi), Unit);
((D (-n), Aux_top (1,1,0,false,QGUG), D n), FBF (1, Psibar, V, Psi), Unit) ]
let anomalous_top_qGuG =
if Flags.top_anom_4f then
anomalous_top_qGuG_tt @ ThoList.flatmap anomalous_top_qGuG_ff [1;2;3]
else
[]
let anomalous_top_qBuB_tt =
[ ((M (U (-3)), O (Aux_top (1,0,0,true,QBUB)), M (U 3)), FBF (1, Psibar, VLR, Psi), G_VLR_qBuB) ]
let anomalous_top_qBuB_ff n =
List.map mom
[ ((U (-n), Aux_top (1,0,0,false,QBUB), U n), FBF (1, Psibar, VLR, Psi), G_VLR_qBuB_u);
((D (-n), Aux_top (1,0,0,false,QBUB), D n), FBF (1, Psibar, VLR, Psi), G_VLR_qBuB_d);
((L (-n), Aux_top (1,0,0,false,QBUB), L n), FBF (1, Psibar, VLR, Psi), G_VLR_qBuB_e);
((N (-n), Aux_top (1,0,0,false,QBUB), N n), FBF (1, Psibar, VL, Psi), G_VL_qBuB_n) ]
let anomalous_top_qBuB =
if Flags.top_anom_4f then
anomalous_top_qBuB_tt @ ThoList.flatmap anomalous_top_qBuB_ff [1;2;3]
else
[]
let anomalous_top_qW_tq =
[ ((M (U (-3)), O (Aux_top (1,0,0,true,QW)), M (U 3)), FBF (1, Psibar, VL, Psi), G_VL_qW);
((M (D (-3)), O (Aux_top (1,0,-1,true,QW)), M (U 3)), FBF (1, Psibar, VL, Psi), G_VL_qW);
((M (U (-3)), O (Aux_top (1,0,1,true,QW)), M (D 3)), FBF (1, Psibar, VL, Psi), G_VL_qW) ]
let anomalous_top_qW_ff n =
List.map mom
[ ((U (-n), Aux_top (1,0,0,false,QW), U n), FBF (1, Psibar, VL, Psi), G_VL_qW_u);
((D (-n), Aux_top (1,0,0,false,QW), D n), FBF (1, Psibar, VL, Psi), G_VL_qW_d);
((N (-n), Aux_top (1,0,0,false,QW), N n), FBF (1, Psibar, VL, Psi), G_VL_qW_u);
((L (-n), Aux_top (1,0,0,false,QW), L n), FBF (1, Psibar, VL, Psi), G_VL_qW_d);
((D (-n), Aux_top (1,0,-1,false,QW), U n), FBF (1, Psibar, VL, Psi), Half);
((U (-n), Aux_top (1,0,1,false,QW), D n), FBF (1, Psibar, VL, Psi), Half);
((L (-n), Aux_top (1,0,-1,false,QW), N n), FBF (1, Psibar, VL, Psi), Half);
((N (-n), Aux_top (1,0,1,false,QW), L n), FBF (1, Psibar, VL, Psi), Half) ]
let anomalous_top_qW =
if Flags.top_anom_4f then
anomalous_top_qW_tq @ ThoList.flatmap anomalous_top_qW_ff [1;2;3]
else
[]
let anomalous_top_DuDd =
if Flags.top_anom_4f then
[ ((M (U (-3)), O (Aux_top (0,0,0,true,DR)), M (U 3)), FBF (1, Psibar, SR, Psi), Half);
((M (U (-3)), O (Aux_top (0,0,0,false,DR)), M (U 3)), FBF (1, Psibar, SL, Psi), G_SL_DttR);
((M (D (-3)), O (Aux_top (0,0,0,false,DR)), M (D 3)), FBF (1, Psibar, SR, Psi), G_SR_DttR);
((M (U (-3)), O (Aux_top (0,0,0,true,DL)), M (U 3)), FBF (1, Psibar, SL, Psi), Half);
((M (D (-3)), O (Aux_top (0,0,0,false,DL)), M (D 3)), FBF (1, Psibar, SL, Psi), G_SL_DttL);
((M (D (-3)), O (Aux_top (0,0,-1,true,DR)), M (U 3)), FBF (1, Psibar, SR, Psi), Half);
((M (U (-3)), O (Aux_top (0,0,1,false,DR)), M (D 3)), FBF (1, Psibar, SLR, Psi), G_SLR_DbtR);
((M (D (-3)), O (Aux_top (0,0,-1,true,DL)), M (U 3)), FBF (1, Psibar, SL, Psi), Half);
((M (U (-3)), O (Aux_top (0,0,1,false,DL)), M (D 3)), FBF (1, Psibar, SL, Psi), G_SL_DbtL) ]
else
[]
let vertices3 =
(ThoList.flatmap electromagnetic_currents [1;2;3] @
ThoList.flatmap color_currents [1;2;3] @
ThoList.flatmap neutral_currents [1;2;3] @
(if Flags.ckm_present then
charged_currents_ckm
else
charged_currents_triv) @
yukawa @ triple_gauge @
gauge_higgs @ higgs @ higgs_triangle_vertices
@ goldstone_vertices @
rsigma3 @ rsigma3t @ rphi3 @
( if Flags.cf_arbitrary then
(rf3cf @ rt3cf)
else
(rf3 @ rt3) ) @
rf3t @
( if Flags.higgs_matrix then
(rsigma3h @ rphi3h @ rf3h )
else
[] ) @
anomalous_ttA @ anomalous_bbA @
anomalous_ttZ @ anomalous_bbZ @
anomalous_tbW @ anomalous_tbWA @ anomalous_tbWZ @
anomalous_ttWW @ anomalous_bbWW @
anomalous_ttG @ anomalous_ttGG @
anomalous_ttH @
anomalous_top_qGuG @ anomalous_top_qBuB @
anomalous_top_qW @ anomalous_top_DuDd)
let vertices4 =
quartic_gauge @ gauge_higgs4 @ higgs4
let vertices () = (vertices3, vertices4, [])
(* For efficiency, make sure that [F.of_vertices vertices] is
evaluated only once. *)
let table = F.of_vertices (vertices ())
let fuse2 = F.fuse2 table
let fuse3 = F.fuse3 table
let fuse = F.fuse table
let max_degree () = 4
let flavor_of_string = function
| "e-" -> M (L 1) | "e+" -> M (L (-1))
| "mu-" -> M (L 2) | "mu+" -> M (L (-2))
| "tau-" -> M (L 3) | "tau+" -> M (L (-3))
| "nue" -> M (N 1) | "nuebar" -> M (N (-1))
| "numu" -> M (N 2) | "numubar" -> M (N (-2))
| "nutau" -> M (N 3) | "nutaubar" -> M (N (-3))
| "u" -> M (U 1) | "ubar" -> M (U (-1))
| "c" -> M (U 2) | "cbar" -> M (U (-2))
| "t" -> M (U 3) | "tbar" -> M (U (-3))
| "d" -> M (D 1) | "dbar" -> M (D (-1))
| "s" -> M (D 2) | "sbar" -> M (D (-2))
| "b" -> M (D 3) | "bbar" -> M (D (-3))
| "g" | "gl" -> G Gl
| "A" -> G Ga | "Z" | "Z0" -> G Z
| "W+" -> G Wp | "W-" -> G Wm
| "H" -> O H | "Rsigma" -> O Rsigma
| "Rphi0" -> O Rphin
| "Rphis0" -> O Rphisn
| "Rphi+" -> O Rphip | "Rphi-" -> O Rphim
| "Rphi++" -> O Rphip | "Rphi--" -> O Rphimm
| "Rf" -> O Rf
| "Rt0" -> O Rtn
| "Rts0" -> O Rtsn
| "Rt+" -> O Rtp | "Rt-" -> O Rtm
| "Rt++" -> O Rtp | "Rt--" -> O Rtmm
| "Aux_t_ttGG0" -> O (Aux_top (2,1, 0,true,TTGG)) | "Aux_ttGG0" -> O (Aux_top (2,1, 0,false,TTGG))
| "Aux_t_tbWA+" -> O (Aux_top (2,0, 1,true,TBWA)) | "Aux_tbWA+" -> O (Aux_top (2,0, 1,false,TBWA))
| "Aux_t_tbWA-" -> O (Aux_top (2,0,-1,true,TBWA)) | "Aux_tbWA-" -> O (Aux_top (2,0,-1,false,TBWA))
| "Aux_t_tbWZ+" -> O (Aux_top (2,0, 1,true,TBWZ)) | "Aux_tbWZ+" -> O (Aux_top (2,0, 1,false,TBWZ))
| "Aux_t_tbWZ-" -> O (Aux_top (2,0,-1,true,TBWZ)) | "Aux_tbWZ-" -> O (Aux_top (2,0,-1,false,TBWZ))
| "Aux_t_ttWW0" -> O (Aux_top (2,0, 0,true,TTWW)) | "Aux_ttWW0" -> O (Aux_top (2,0, 0,false,TTWW))
| "Aux_t_bbWW0" -> O (Aux_top (2,0, 0,true,BBWW)) | "Aux_bbWW0" -> O (Aux_top (2,0, 0,false,BBWW))
| "Aux_t_qGuG0" -> O (Aux_top (1,1, 0,true,QGUG)) | "Aux_qGuG0" -> O (Aux_top (1,1, 0,false,QGUG))
| "Aux_t_qBuB0" -> O (Aux_top (1,0, 0,true,QBUB)) | "Aux_qBuB0" -> O (Aux_top (1,0, 0,false,QBUB))
| "Aux_t_qW0" -> O (Aux_top (1,0, 0,true,QW)) | "Aux_qW0" -> O (Aux_top (1,0, 0,false,QW))
| "Aux_t_qW+" -> O (Aux_top (1,0, 1,true,QW)) | "Aux_qW+" -> O (Aux_top (1,0, 1,false,QW))
| "Aux_t_qW-" -> O (Aux_top (1,0,-1,true,QW)) | "Aux_qW-" -> O (Aux_top (1,0,-1,false,QW))
| "Aux_t_dL0" -> O (Aux_top (0,0, 0,true,DL)) | "Aux_dL0" -> O (Aux_top (0,0, 0,false,DL))
| "Aux_t_dL+" -> O (Aux_top (0,0, 1,true,DL)) | "Aux_dL+" -> O (Aux_top (0,0, 1,false,DL))
| "Aux_t_dL-" -> O (Aux_top (0,0,-1,true,DL)) | "Aux_dL-" -> O (Aux_top (0,0,-1,false,DL))
| "Aux_t_dR0" -> O (Aux_top (0,0, 0,true,DR)) | "Aux_dR0" -> O (Aux_top (0,0, 0,false,DR))
| "Aux_t_dR+" -> O (Aux_top (0,0, 1,true,DR)) | "Aux_dR+" -> O (Aux_top (0,0, 1,false,DR))
| "Aux_t_dR-" -> O (Aux_top (0,0,-1,true,DR)) | "Aux_dR-" -> O (Aux_top (0,0,-1,false,DR))
| _ -> invalid_arg "Modellib_BSM.SSC.flavor_of_string"
let flavor_to_string = function
| M f ->
begin match f with
| L 1 -> "e-" | L (-1) -> "e+"
| L 2 -> "mu-" | L (-2) -> "mu+"
| L 3 -> "tau-" | L (-3) -> "tau+"
| L _ -> invalid_arg
"Modellib_BSM.SSC.flavor_to_string: invalid lepton"
| N 1 -> "nue" | N (-1) -> "nuebar"
| N 2 -> "numu" | N (-2) -> "numubar"
| N 3 -> "nutau" | N (-3) -> "nutaubar"
| N _ -> invalid_arg
"Modellib_BSM.SSC.flavor_to_string: invalid neutrino"
| U 1 -> "u" | U (-1) -> "ubar"
| U 2 -> "c" | U (-2) -> "cbar"
| U 3 -> "t" | U (-3) -> "tbar"
| U _ -> invalid_arg
"Modellib_BSM.SSC.flavor_to_string: invalid up type quark"
| D 1 -> "d" | D (-1) -> "dbar"
| D 2 -> "s" | D (-2) -> "sbar"
| D 3 -> "b" | D (-3) -> "bbar"
| D _ -> invalid_arg
"Modellib_BSM.SSC.flavor_to_string: invalid down type quark"
end
| G f ->
begin match f with
| Gl -> "gl"
| Ga -> "A" | Z -> "Z"
| Wp -> "W+" | Wm -> "W-"
end
| O f ->
begin match f with
| Phip -> "phi+" | Phim -> "phi-" | Phi0 -> "phi0"
| H -> "H" | Rsigma -> "Rsigma"
| Rphin -> "Rphin" | Rphisn -> "Rphisn"
| Rphip -> "Rphi+" | Rphim -> "Rphi-"
| Rphipp -> "Rphi++" | Rphimm -> "Rphi--"
| Rf -> "Rf"
| Rtn -> "Rtn" | Rtsn -> "Rtsn" | Rtp -> "Rt+" | Rtm -> "Rt-"
| Rtpp -> "Rt++" | Rtmm -> "Rt--"
| Aux_top (_,_,ch,n,v) -> "Aux_" ^ (if n then "t_" else "") ^ (
begin match v with
| TTGG -> "ttGG" | TBWA -> "tbWA" | TBWZ -> "tbWZ"
| TTWW -> "ttWW" | BBWW -> "bbWW"
| QGUG -> "qGuG" | QBUB -> "qBuB"
| QW -> "qW" | DL -> "dL" | DR -> "dR"
end ) ^ ( if ch > 0 then "+" else if ch < 0 then "-" else "0" )
end
let flavor_to_TeX = function
| M f ->
begin match f with
| L 1 -> "e^-" | L (-1) -> "e^+"
| L 2 -> "\\mu^-" | L (-2) -> "\\mu^+"
| L 3 -> "\\tau^-" | L (-3) -> "\\tau^+"
| L _ -> invalid_arg
"Modellib_BSM.SSC.flavor_to_TeX: invalid lepton"
| N 1 -> "\\nu_e" | N (-1) -> "\\bar{\\nu}_e"
| N 2 -> "\\nu_\\mu" | N (-2) -> "\\bar{\\nu}_\\mu"
| N 3 -> "\\nu_\\tau" | N (-3) -> "\\bar{\\nu}_\\tau"
| N _ -> invalid_arg
"Modellib_BSM.SSC.flavor_to_TeX: invalid neutrino"
| U 1 -> "u" | U (-1) -> "\\bar{u}"
| U 2 -> "c" | U (-2) -> "\\bar{c}"
| U 3 -> "t" | U (-3) -> "\\bar{t}"
| U _ -> invalid_arg
"Modellib_BSM.SSC.flavor_to_TeX: invalid up type quark"
| D 1 -> "d" | D (-1) -> "\\bar{d}"
| D 2 -> "s" | D (-2) -> "\\bar{s}"
| D 3 -> "b" | D (-3) -> "\\bar{b}"
| D _ -> invalid_arg
"Modellib_BSM.SSC.flavor_to_TeX: invalid down type quark"
end
| G f ->
begin match f with
| Gl -> "g"
| Ga -> "\\gamma" | Z -> "Z"
| Wp -> "W^+" | Wm -> "W^-"
end
| O f ->
begin match f with
| Phip -> "\\phi^+" | Phim -> "\\phi^-" | Phi0 -> "\\phi^0"
| H -> "H" | Rsigma -> "\\sigma"
| Rphip -> "\\phi^+" | Rphim -> "\\phi^-" | Rphin -> "\\phi^0"
| Rphisn -> "\\phi_s^0"
| Rphipp -> "\\phi^{++}" | Rphimm -> "\\phi^{--}"
| Rf -> "f"
| Rtp -> "t^+" | Rtm -> "t^-" | Rtn -> "t^0" | Rtsn -> "t_s^0"
| Rtpp -> "t^{++}" | Rtmm -> "t^{--}"
| Aux_top (_,_,ch,n,v) -> "\\textnormal{Aux_" ^ (if n then "t_" else "") ^ (
begin match v with
| TTGG -> "ttGG" | TBWA -> "tbWA" | TBWZ -> "tbWZ"
| TTWW -> "ttWW" | BBWW -> "bbWW"
| QGUG -> "qGuG" | QBUB -> "qBuB"
| QW -> "qW" | DL -> "dL" | DR -> "dR"
end ) ^ ( if ch > 0 then "^+" else if ch < 0 then "^-" else "^0" ) ^ "}"
end
let flavor_symbol = function
| M f ->
begin match f with
| L n when n > 0 -> "l" ^ string_of_int n
| L n -> "l" ^ string_of_int (abs n) ^ "b"
| N n when n > 0 -> "n" ^ string_of_int n
| N n -> "n" ^ string_of_int (abs n) ^ "b"
| U n when n > 0 -> "u" ^ string_of_int n
| U n -> "u" ^ string_of_int (abs n) ^ "b"
| D n when n > 0 -> "d" ^ string_of_int n
| D n -> "d" ^ string_of_int (abs n) ^ "b"
end
| G f ->
begin match f with
| Gl -> "gl"
| Ga -> "a" | Z -> "z"
| Wp -> "wp" | Wm -> "wm"
end
| O f ->
begin match f with
| Phip -> "pp" | Phim -> "pm" | Phi0 -> "p0"
| H -> "h" | Rsigma -> "rsi"
| Rphip -> "rpp" | Rphim -> "rpm" | Rphin -> "rpn"
| Rphisn -> "rpsn"
| Rphipp -> "rppp" | Rphimm -> "rpmm"
| Rf -> "rf"
| Rtp -> "rtp" | Rtm -> "rtm" | Rtn -> "rtn"
| Rtsn -> "rtsn"
| Rtpp -> "rtpp" | Rtmm -> "rtmm"
| Aux_top (_,_,ch,n,v) -> "aux_" ^ (if n then "t_" else "") ^ (
begin match v with
| TTGG -> "ttgg" | TBWA -> "tbwa" | TBWZ -> "tbwz"
| TTWW -> "ttww" | BBWW -> "bbww"
| QGUG -> "qgug" | QBUB -> "qbub"
| QW -> "qw" | DL -> "dl" | DR -> "dr"
end ) ^ "_" ^ ( if ch > 0 then "p" else if ch < 0 then "m" else "0" )
end
(* Introducing new Resonances from 45, there are no PDG values *)
let pdg = function
| M f ->
begin match f with
| L n when n > 0 -> 9 + 2*n
| L n -> - 9 + 2*n
| N n when n > 0 -> 10 + 2*n
| N n -> - 10 + 2*n
| U n when n > 0 -> 2*n
| U n -> 2*n
| D n when n > 0 -> - 1 + 2*n
| D n -> 1 + 2*n
end
| G f ->
begin match f with
| Gl -> 21
| Ga -> 22 | Z -> 23
| Wp -> 24 | Wm -> (-24)
end
| O f ->
begin match f with
| Phip | Phim -> 27 | Phi0 -> 26
| H -> 25 | Rsigma -> 45
| Rphin -> 46 | Rphip | Rphim -> 47
| Rphipp | Rphimm -> 48
| Rphisn -> 49
| Rf -> 52
| Rtn -> 53 | Rtp | Rtm -> 54
| Rtpp | Rtmm -> 55
| Rtsn -> 59
| Aux_top (_,_,_,_,_) -> 81
end
let mass_symbol f =
"mass(" ^ string_of_int (abs (pdg f)) ^ ")"
let width_symbol f =
"width(" ^ string_of_int (abs (pdg f)) ^ ")"
let constant_symbol = function
| Unit -> "unit" | Half -> "half" | Pi -> "PI"
| Alpha_QED -> "alpha" | E -> "e" | G_weak -> "g" | Vev -> "vev"
| I_G_weak -> "ig"
| Sin2thw -> "sin2thw" | Sinthw -> "sinthw" | Costhw -> "costhw"
| Q_lepton -> "qlep" | Q_up -> "qup" | Q_down -> "qdwn"
| G_NC_lepton -> "gnclep" | G_NC_neutrino -> "gncneu"
| G_NC_up -> "gncup" | G_NC_down -> "gncdwn"
| G_TVA_ttA -> "gtva_tta" | G_TVA_bbA -> "gtva_bba"
| G_VLR_ttZ -> "gvlr_ttz" | G_TVA_ttZ -> "gtva_ttz" | G_TVA_bbZ -> "gtva_bbz"
| G_VLR_btW -> "gvlr_btw" | G_VLR_tbW -> "gvlr_tbw"
| G_TLR_btW -> "gtlr_btw" | G_TRL_tbW -> "gtrl_tbw"
| G_TLR_btWA -> "gtlr_btwa" | G_TRL_tbWA -> "gtrl_tbwa"
| G_TLR_btWZ -> "gtlr_btwz" | G_TRL_tbWZ -> "gtrl_tbwz"
| G_TVA_ttWW -> "gtva_ttww" | G_TVA_bbWW -> "gtva_bbww"
| G_TVA_ttG -> "gtva_ttg" | G_TVA_ttGG -> "gtva_ttgg"
| G_SP_ttH -> "gsp_tth"
| G_VLR_qGuG -> "gvlr_qgug"
| G_VLR_qBuB -> "gvlr_qbub"
| G_VLR_qBuB_u -> "gvlr_qbub_u" | G_VLR_qBuB_d -> "gvlr_qbub_d"
| G_VLR_qBuB_e -> "gvlr_qbub_e" | G_VL_qBuB_n -> "gvl_qbub_n"
| G_VL_qW -> "gvl_qw"
| G_VL_qW_u -> "gvl_qw_u" | G_VL_qW_d -> "gvl_qw_d"
| G_SL_DttR -> "gsl_dttr" | G_SR_DttR -> "gsr_dttr" | G_SL_DttL -> "gsl_dttl"
| G_SLR_DbtR -> "gslr_dbtr" | G_SL_DbtL -> "gsl_dbtl"
| G_CC -> "gcc"
| G_CCQ (n1,n2) -> "gccq" ^ string_of_int n1 ^ string_of_int n2
| I_Q_W -> "iqw" | I_G_ZWW -> "igzww"
| G_WWWW -> "gw4" | G_ZZWW -> "gzzww"
| G_AZWW -> "gazww" | G_AAWW -> "gaaww"
| I_G1_AWW -> "ig1a" | I_G1_ZWW -> "ig1z"
| I_G1_plus_kappa_plus_G4_AWW -> "ig1pkpg4a"
| I_G1_plus_kappa_plus_G4_ZWW -> "ig1pkpg4z"
| I_G1_plus_kappa_minus_G4_AWW -> "ig1pkmg4a"
| I_G1_plus_kappa_minus_G4_ZWW -> "ig1pkmg4z"
| I_G1_minus_kappa_plus_G4_AWW -> "ig1mkpg4a"
| I_G1_minus_kappa_plus_G4_ZWW -> "ig1mkpg4z"
| I_G1_minus_kappa_minus_G4_AWW -> "ig1mkmg4a"
| I_G1_minus_kappa_minus_G4_ZWW -> "ig1mkmg4z"
| I_lambda_AWW -> "ila"
| I_lambda_ZWW -> "ilz"
| G5_AWW -> "rg5a"
| G5_ZWW -> "rg5z"
| I_kappa5_AWW -> "ik5a"
| I_kappa5_ZWW -> "ik5z"
| I_lambda5_AWW -> "il5a" | I_lambda5_ZWW -> "il5z"
| Alpha_WWWW0 -> "alww0" | Alpha_WWWW2 -> "alww2"
| Alpha_ZZWW0 -> "alzw0" | Alpha_ZZWW1 -> "alzw1"
| Alpha_ZZZZ -> "alzz"
| FT0_WWWW0 -> "at0ww0" | FT0_WWWW2 -> "at0ww2"
| FT0_ZZWW0 -> "at0zw0" | FT0_ZZWW1 -> "at0zw1"
| FT0_ZZZZ -> "at0zz" | FT0_AAAA -> "at0aa"
| FT0_AAWW0 -> "at0aw0" | FT0_AAWW1 -> "at0aw1"
| FT0_AAZZ -> "at0az"
| FT0_AZWW0 -> "at0azw0" | FT0_AZWW1 -> "at0azw1"
| FT0_AAAZ -> "at03az" | FT0_AZZZ -> "at0a3z"
| FT1_WWWW0 -> "at1ww0" | FT1_WWWW2 -> "at1ww2"
| FT1_ZZWW0 -> "at1zw0" | FT1_ZZWW1 -> "at1zw1"
| FT1_ZZZZ -> "at1zz" | FT1_AAAA -> "at1aa"
| FT1_AAWW0 -> "at1aw0" | FT1_AAWW1 -> "at1aw1"
| FT1_AAZZ -> "at1az"
| FT1_AZWW0 -> "at1azw0" | FT1_AZWW1 -> "at1azw1"
| FT1_AAAZ -> "at13az" | FT1_AZZZ -> "at1a3z"
| FT2_WWWW0 -> "at2ww0" | FT2_WWWW2 -> "at2ww2"
| FT2_ZZWW0 -> "at2zw0" | FT2_ZZWW1 -> "at2zw1"
| FT2_ZZZZ -> "at2zz" | FT2_AAAA -> "at2aa"
| FT2_AAWW0 -> "at2aw0" | FT2_AAWW1 -> "at2aw1"
| FT2_AAZZ -> "at2az"
| FT2_AZWW0 -> "at2azw0" | FT2_AZWW1 -> "at2azw1"
| FT2_AAAZ -> "at23az" | FT2_AZZZ -> "at2a3z"
| FM0_WWWW0 -> "am0ww0,am0ww0" | FM0_WWWW2 -> "am0ww2,am0ww2"
| FM0_ZZWW0 -> "am0zw0/costhw**2,am0zw0*costhw**2" | FM0_ZZWW1 -> "am0zw1/costhw**2,am0zw1*costhw**2"
| FM0_ZZZZ -> "am0zz,am0zz"
| FM1_WWWW0 -> "am1ww0,am1ww0" | FM1_WWWW2 -> "am1ww2,am1ww2"
| FM1_ZZWW0 -> "am1zw0/costhw**2,am1zw0*costhw**2" | FM1_ZZWW1 -> "am1zw1/costhw**2,am1zw1*costhw**2"
| FM1_ZZZZ -> "am1zz,am1zz"
| FM7_WWWW0 -> "am7ww0,am7ww0,am7ww0" | FM7_WWWW2 -> "am7ww2,am7ww2,am7ww2"
| FM7_ZZWW0 -> "am7zw0/costhw**2,am7zw0,am7zw0*costhw**2" | FM7_ZZWW1 -> "am7zw1/costhw**2,am7zw1,am7zw1*costhw**2"
| FM7_ZZZZ -> "am7zz,am7zz,am7zz"
| FS0_HHWW -> "fs0hhww" | FS0_HHZZ -> "fs0hhzz"
| FS1_HHWW -> "fs1hhww" | FS1_HHZZ -> "fs1hhzz"
| FS_H4 -> "fsh4"
| FM0_HHWW -> "fm0hhww" | FM0_HHZZ -> "fm0hhzz"
| FM1_HHWW -> "fm1hhww" | FM1_HHZZ -> "fm1hhzz"
| FM7_HHWW -> "fm7hhww" | FM7_HHZZ -> "fm7hhzz"
| D_Alpha_ZZWW0_S -> "dalzz0_s(gkm,mkm,"
| D_Alpha_ZZWW0_T -> "dalzz0_t(gkm,mkm,"
| D_Alpha_ZZWW1_S -> "dalzz1_s(gkm,mkm,"
| D_Alpha_ZZWW1_T -> "dalzz1_t(gkm,mkm,"
| D_Alpha_ZZWW1_U -> "dalzz1_u(gkm,mkm,"
| D_Alpha_WWWW0_S -> "dalww0_s(gkm,mkm,"
| D_Alpha_WWWW0_T -> "dalww0_t(gkm,mkm,"
| D_Alpha_WWWW0_U -> "dalww0_u(gkm,mkm,"
| D_Alpha_WWWW2_S -> "dalww2_s(gkm,mkm,"
| D_Alpha_WWWW2_T -> "dalww2_t(gkm,mkm,"
| D_Alpha_ZZZZ_S -> "dalz4_s(gkm,mkm,"
| D_Alpha_ZZZZ_T -> "dalz4_t(gkm,mkm,"
| D_FT0_ZZWW0_S -> "datzz0_s_0(gkm,mkm,"
| D_FT0_ZZWW0_T -> "datzz0_t_0(gkm,mkm,"
| D_FT0_ZZWW0_U -> "datzz0_u_0(gkm,mkm,"
| D_FT0_ZZWW1_S -> "datzz1_s_0(gkm,mkm,"
| D_FT0_ZZWW1_T -> "datzz1_t_0(gkm,mkm,"
| D_FT0_ZZWW1_U -> "datzz1_u_0(gkm,mkm,"
| D_FT0_WWWW0_S -> "datww0_s_0(gkm,mkm,"
| D_FT0_WWWW0_T -> "datww0_t_0(gkm,mkm,"
| D_FT0_WWWW0_U -> "datww0_u_0(gkm,mkm,"
| D_FT0_WWWW2_S -> "datww2_s_0(gkm,mkm,"
| D_FT0_WWWW2_T -> "datww2_t_0(gkm,mkm,"
| D_FT0_WWWW2_U -> "datww2_u_0(gkm,mkm,"
| D_FT0_ZZZZ_S -> "datz4_s_0(gkm,mkm,"
| D_FT0_ZZZZ_T -> "datz4_t_0(gkm,mkm,"
| D_FT0_ZZZZ_U -> "datz4_u_0(gkm,mkm,"
| D_FT0_AAAA_S -> "data4_s_0(gkm,mkm,"
| D_FT0_AAAA_T -> "data4_t_0(gkm,mkm,"
| D_FT0_AAAA_U -> "data4_u_0(gkm,mkm,"
| D_FT0_AAWW0_S -> "dataw0_s_0(gkm,mkm,"
| D_FT0_AAWW0_T -> "dataw0_t_0(gkm,mkm,"
| D_FT0_AAWW0_U -> "dataw0_u_0(gkm,mkm,"
| D_FT0_AAWW1_S -> "dataw1_s_0(gkm,mkm,"
| D_FT0_AAWW1_T -> "dataw1_t_0(gkm,mkm,"
| D_FT0_AAWW1_U -> "dataw1_u_0(gkm,mkm,"
| D_FT0_AAZZ_S -> "dataz_s_0(gkm,mkm,"
| D_FT0_AAZZ_T -> "dataz_t_0(gkm,mkm,"
| D_FT0_AAZZ_U -> "dataz_u_0(gkm,mkm,"
| D_FT0_AZWW0_S -> "datazw0_s_0(gkm,mkm,"
| D_FT0_AZWW0_T -> "datazw0_t_0(gkm,mkm,"
| D_FT0_AZWW0_U -> "datazw0_u_0(gkm,mkm,"
| D_FT0_AZWW1_S -> "datazw1_s_0(gkm,mkm,"
| D_FT0_AZWW1_T -> "datazw1_t_0(gkm,mkm,"
| D_FT0_AZWW1_U -> "datazw1_u_0(gkm,mkm,"
| D_FT0_AAAZ_S -> "dat3az_s_0(gkm,mkm,"
| D_FT0_AAAZ_T -> "dat3az_t_0(gkm,mkm,"
| D_FT0_AAAZ_U -> "dat3az_u_0(gkm,mkm,"
| D_FT0_AZZZ_S -> "data3z_s_0(gkm,mkm,"
| D_FT0_AZZZ_T -> "data3z_t_0(gkm,mkm,"
| D_FT0_AZZZ_U -> "data3z_u_0(gkm,mkm,"
| D_FT1_ZZWW0_S -> "datzz0_s_1(gkm,mkm,"
| D_FT1_ZZWW0_T -> "datzz0_t_1(gkm,mkm,"
| D_FT1_ZZWW0_U -> "datzz0_u_1(gkm,mkm,"
| D_FT1_ZZWW1_S -> "datzz1_s_1(gkm,mkm,"
| D_FT1_ZZWW1_T -> "datzz1_t_1(gkm,mkm,"
| D_FT1_ZZWW1_U -> "datzz1_u_1(gkm,mkm,"
| D_FT1_WWWW0_S -> "datww0_s_1(gkm,mkm,"
| D_FT1_WWWW0_T -> "datww0_t_1(gkm,mkm,"
| D_FT1_WWWW0_U -> "datww0_u_1(gkm,mkm,"
| D_FT1_WWWW2_S -> "datww2_s_1(gkm,mkm,"
| D_FT1_WWWW2_T -> "datww2_t_1(gkm,mkm,"
| D_FT1_WWWW2_U -> "datww2_u_1(gkm,mkm,"
| D_FT1_ZZZZ_S -> "datz4_s_1(gkm,mkm,"
| D_FT1_ZZZZ_T -> "datz4_t_1(gkm,mkm,"
| D_FT1_ZZZZ_U -> "datz4_u_1(gkm,mkm,"
| D_FT1_AAAA_S -> "data4_s_1(gkm,mkm,"
| D_FT1_AAAA_T -> "data4_t_1(gkm,mkm,"
| D_FT1_AAAA_U -> "data4_u_1(gkm,mkm,"
| D_FT1_AAWW0_S -> "dataw0_s_1(gkm,mkm,"
| D_FT1_AAWW0_T -> "dataw0_t_1(gkm,mkm,"
| D_FT1_AAWW0_U -> "dataw0_u_1(gkm,mkm,"
| D_FT1_AAWW1_S -> "dataw1_s_1(gkm,mkm,"
| D_FT1_AAWW1_T -> "dataw1_t_1(gkm,mkm,"
| D_FT1_AAWW1_U -> "dataw1_u_1(gkm,mkm,"
| D_FT1_AAZZ_S -> "dataz_s_1(gkm,mkm,"
| D_FT1_AAZZ_T -> "dataz_t_1(gkm,mkm,"
| D_FT1_AAZZ_U -> "dataz_u_1(gkm,mkm,"
| D_FT1_AZWW0_S -> "datazw0_s_1(gkm,mkm,"
| D_FT1_AZWW0_T -> "datazw0_t_1(gkm,mkm,"
| D_FT1_AZWW0_U -> "datazw0_u_1(gkm,mkm,"
| D_FT1_AZWW1_S -> "datazw1_s_1(gkm,mkm,"
| D_FT1_AZWW1_T -> "datazw1_t_1(gkm,mkm,"
| D_FT1_AZWW1_U -> "datazw1_u_1(gkm,mkm,"
| D_FT1_AAAZ_S -> "dat3az_s_1(gkm,mkm,"
| D_FT1_AAAZ_T -> "dat3az_t_1(gkm,mkm,"
| D_FT1_AAAZ_U -> "dat3az_u_1(gkm,mkm,"
| D_FT1_AZZZ_S -> "data3z_s_1(gkm,mkm,"
| D_FT1_AZZZ_T -> "data3z_t_1(gkm,mkm,"
| D_FT1_AZZZ_U -> "data3z_u_1(gkm,mkm,"
| D_FT2_ZZWW0_S -> "datzz0_s_2(gkm,mkm,"
| D_FT2_ZZWW0_T -> "datzz0_t_2(gkm,mkm,"
| D_FT2_ZZWW0_U -> "datzz0_u_2(gkm,mkm,"
| D_FT2_ZZWW1_S -> "datzz1_s_2(gkm,mkm,"
| D_FT2_ZZWW1_T -> "datzz1_t_2(gkm,mkm,"
| D_FT2_ZZWW1_U -> "datzz1_u_2(gkm,mkm,"
| D_FT2_WWWW0_S -> "datww0_s_2(gkm,mkm,"
| D_FT2_WWWW0_T -> "datww0_t_2(gkm,mkm,"
| D_FT2_WWWW0_U -> "datww0_u_2(gkm,mkm,"
| D_FT2_WWWW2_S -> "datww2_s_2(gkm,mkm,"
| D_FT2_WWWW2_T -> "datww2_t_2(gkm,mkm,"
| D_FT2_WWWW2_U -> "datww2_u_2(gkm,mkm,"
| D_FT2_ZZZZ_S -> "datz4_s_2(gkm,mkm,"
| D_FT2_ZZZZ_T -> "datz4_t_2(gkm,mkm,"
| D_FT2_ZZZZ_U -> "datz4_u_2(gkm,mkm,"
| D_FT2_AAAA_S -> "data4_s_2(gkm,mkm,"
| D_FT2_AAAA_T -> "data4_t_2(gkm,mkm,"
| D_FT2_AAAA_U -> "data4_u_2(gkm,mkm,"
| D_FT2_AAWW0_S -> "dataw0_s_2(gkm,mkm,"
| D_FT2_AAWW0_T -> "dataw0_t_2(gkm,mkm,"
| D_FT2_AAWW0_U -> "dataw0_u_2(gkm,mkm,"
| D_FT2_AAWW1_S -> "dataw1_s_2(gkm,mkm,"
| D_FT2_AAWW1_T -> "dataw1_t_2(gkm,mkm,"
| D_FT2_AAWW1_U -> "dataw1_u_2(gkm,mkm,"
| D_FT2_AAZZ_S -> "dataz_s_2(gkm,mkm,"
| D_FT2_AAZZ_T -> "dataz_t_2(gkm,mkm,"
| D_FT2_AAZZ_U -> "dataz_u_2(gkm,mkm,"
| D_FT2_AZWW0_S -> "datazw0_s_2(gkm,mkm,"
| D_FT2_AZWW0_T -> "datazw0_t_2(gkm,mkm,"
| D_FT2_AZWW0_U -> "datazw0_u_2(gkm,mkm,"
| D_FT2_AZWW1_S -> "datazw1_s_2(gkm,mkm,"
| D_FT2_AZWW1_T -> "datazw1_t_2(gkm,mkm,"
| D_FT2_AZWW1_U -> "datazw1_u_2(gkm,mkm,"
| D_FT2_AAAZ_S -> "dat3az_s_2(gkm,mkm,"
| D_FT2_AAAZ_T -> "dat3az_t_2(gkm,mkm,"
| D_FT2_AAAZ_U -> "dat3az_u_2(gkm,mkm,"
| D_FT2_AZZZ_S -> "data3z_s_2(gkm,mkm,"
| D_FT2_AZZZ_T -> "data3z_t_2(gkm,mkm,"
| D_FT2_AZZZ_U -> "data3z_u_2(gkm,mkm,"
| D_FTrsi_ZZWW0_S -> "datzz0_s_rsi(gkm,mkm,"
| D_FTrsi_ZZWW0_T -> "datzz0_t_rsi(gkm,mkm,"
| D_FTrsi_ZZWW0_U -> "datzz0_u_rsi(gkm,mkm,"
| D_FTrsi_ZZWW1_S -> "datzz1_s_rsi(gkm,mkm,"
| D_FTrsi_ZZWW1_T -> "datzz1_t_rsi(gkm,mkm,"
| D_FTrsi_ZZWW1_U -> "datzz1_u_rsi(gkm,mkm,"
| D_FTrsi_WWWW0_S -> "datww0_s_rsi(gkm,mkm,"
| D_FTrsi_WWWW0_T -> "datww0_t_rsi(gkm,mkm,"
| D_FTrsi_WWWW0_U -> "datww0_u_rsi(gkm,mkm,"
| D_FTrsi_WWWW2_S -> "datww2_s_rsi(gkm,mkm,"
| D_FTrsi_WWWW2_T -> "datww2_t_rsi(gkm,mkm,"
| D_FTrsi_WWWW2_U -> "datww2_u_rsi(gkm,mkm,"
| D_FTrsi_ZZZZ_S -> "datz4_s_rsi(gkm,mkm,"
| D_FTrsi_ZZZZ_T -> "datz4_t_rsi(gkm,mkm,"
| D_FTrsi_ZZZZ_U -> "datz4_u_rsi(gkm,mkm,"
| D_FTrsi_AAAA_S -> "data4_s_rsi(gkm,mkm,"
| D_FTrsi_AAAA_T -> "data4_t_rsi(gkm,mkm,"
| D_FTrsi_AAAA_U -> "data4_u_rsi(gkm,mkm,"
| D_FTrsi_AAWW0_S -> "dataw0_s_rsi(gkm,mkm,"
| D_FTrsi_AAWW0_T -> "dataw0_t_rsi(gkm,mkm,"
| D_FTrsi_AAWW0_U -> "dataw0_u_rsi(gkm,mkm,"
| D_FTrsi_AAWW1_S -> "dataw1_s_rsi(gkm,mkm,"
| D_FTrsi_AAWW1_T -> "dataw1_t_rsi(gkm,mkm,"
| D_FTrsi_AAWW1_U -> "dataw1_u_rsi(gkm,mkm,"
| D_FTrsi_AAZZ_S -> "dataz_s_rsi(gkm,mkm,"
| D_FTrsi_AAZZ_T -> "dataz_t_rsi(gkm,mkm,"
| D_FTrsi_AAZZ_U -> "dataz_u_rsi(gkm,mkm,"
| D_FTrsi_AZWW0_S -> "datazw0_s_rsi(gkm,mkm,"
| D_FTrsi_AZWW0_T -> "datazw0_t_rsi(gkm,mkm,"
| D_FTrsi_AZWW0_U -> "datazw0_u_rsi(gkm,mkm,"
| D_FTrsi_AZWW1_S -> "datazw1_s_rsi(gkm,mkm,"
| D_FTrsi_AZWW1_T -> "datazw1_t_rsi(gkm,mkm,"
| D_FTrsi_AZWW1_U -> "datazw1_u_rsi(gkm,mkm,"
| D_FTrsi_AAAZ_S -> "dat3az_s_rsi(gkm,mkm,"
| D_FTrsi_AAAZ_T -> "dat3az_t_rsi(gkm,mkm,"
| D_FTrsi_AAAZ_U -> "dat3az_u_rsi(gkm,mkm,"
| D_FTrsi_AZZZ_S -> "data3z_s_rsi(gkm,mkm,"
| D_FTrsi_AZZZ_T -> "data3z_t_rsi(gkm,mkm,"
| D_FTrsi_AZZZ_U -> "data3z_u_rsi(gkm,mkm,"
| D_FM0_ZZWW0_S -> "damzz0_s_0(gkm,mkm,"
| D_FM0_ZZWW0_T -> "damzz0_t_0(gkm,mkm,"
| D_FM0_ZZWW0_U -> "damzz0_u_0(gkm,mkm,"
| D_FM0_ZZWW1_S -> "damzz1_s_0(gkm,mkm,"
| D_FM0_ZZWW1_T -> "damzz1_t_0(gkm,mkm,"
| D_FM0_ZZWW1_U -> "damzz1_u_0(gkm,mkm,"
| D_FM0_WWWW0_S -> "damww0_s_0(gkm,mkm,"
| D_FM0_WWWW0_T -> "damww0_t_0(gkm,mkm,"
| D_FM0_WWWW0_U -> "damww0_u_0(gkm,mkm,"
| D_FM0_WWWW2_S -> "damww2_s_0(gkm,mkm,"
| D_FM0_WWWW2_T -> "damww2_t_0(gkm,mkm,"
| D_FM0_WWWW2_U -> "damww2_u_0(gkm,mkm,"
| D_FM0_ZZZZ_S -> "damz4_s_0(gkm,mkm,"
| D_FM0_ZZZZ_T -> "damz4_t_0(gkm,mkm,"
| D_FM0_ZZZZ_U -> "damz4_u_0(gkm,mkm,"
| D_FM1_ZZWW0_S -> "damzz0_s_1(gkm,mkm,"
| D_FM1_ZZWW0_T -> "damzz0_t_1(gkm,mkm,"
| D_FM1_ZZWW0_U -> "damzz0_u_1(gkm,mkm,"
| D_FM1_ZZWW1_S -> "damzz1_s_1(gkm,mkm,"
| D_FM1_ZZWW1_T -> "damzz1_t_1(gkm,mkm,"
| D_FM1_ZZWW1_U -> "damzz1_u_1(gkm,mkm,"
| D_FM1_WWWW0_S -> "damww0_s_1(gkm,mkm,"
| D_FM1_WWWW0_T -> "damww0_t_1(gkm,mkm,"
| D_FM1_WWWW0_U -> "damww0_u_1(gkm,mkm,"
| D_FM1_WWWW2_S -> "damww2_s_1(gkm,mkm,"
| D_FM1_WWWW2_T -> "damww2_t_1(gkm,mkm,"
| D_FM1_WWWW2_U -> "damww2_u_1(gkm,mkm,"
| D_FM1_ZZZZ_S -> "damz4_s_1(gkm,mkm,"
| D_FM1_ZZZZ_T -> "damz4_t_1(gkm,mkm,"
| D_FM1_ZZZZ_U -> "damz4_u_1(gkm,mkm,"
| D_FM7_ZZWW0_S -> "damzz0_s_7(gkm,mkm,"
| D_FM7_ZZWW0_T -> "damzz0_t_7(gkm,mkm,"
| D_FM7_ZZWW0_U -> "damzz0_u_7(gkm,mkm,"
| D_FM7_ZZWW1_S -> "damzz1_s_7(gkm,mkm,"
| D_FM7_ZZWW1_T -> "damzz1_t_7(gkm,mkm,"
| D_FM7_ZZWW1_U -> "damzz1_u_7(gkm,mkm,"
| D_FM7_WWWW0_S -> "damww0_s_7(gkm,mkm,"
| D_FM7_WWWW0_T -> "damww0_t_7(gkm,mkm,"
| D_FM7_WWWW0_U -> "damww0_u_7(gkm,mkm,"
| D_FM7_WWWW2_S -> "damww2_s_7(gkm,mkm,"
| D_FM7_WWWW2_T -> "damww2_t_7(gkm,mkm,"
| D_FM7_WWWW2_U -> "damww2_u_7(gkm,mkm,"
| D_FM7_ZZZZ_S -> "damz4_s_7(gkm,mkm,"
| D_FM7_ZZZZ_T -> "damz4_t_7(gkm,mkm,"
| D_FM7_ZZZZ_U -> "damz4_u_7(gkm,mkm,"
| D_Alpha_HHHH_S -> "dalh4_s(gkm,mkm,"
| D_Alpha_HHHH_T -> "dalh4_t(gkm,mkm,"
| D_Alpha_HHWW0_S -> "dalhw0_s(gkm,mkm,"
| D_Alpha_HHWW0_T -> "dalhw0_t(gkm,mkm,"
| D_Alpha_HHZZ0_S -> "dalhz0_s(gkm,mkm,"
| D_Alpha_HHZZ0_T -> "dalhz0_t(gkm,mkm,"
| D_Alpha_HHWW1_S -> "dalhw1_s(gkm,mkm,"
| D_Alpha_HHWW1_T -> "dalhw1_t(gkm,mkm,"
| D_Alpha_HHWW1_U -> "dalhw1_u(gkm,mkm,"
| D_Alpha_HHZZ1_S -> "dalhz1_s(gkm,mkm,"
| D_Alpha_HHZZ1_T -> "dalhz1_t(gkm,mkm,"
| D_Alpha_HHZZ1_U -> "dalhz1_u(gkm,mkm,"
| D_FM0_HHWW0_S -> "damhw0_s_0(gkm,mkm,"
| D_FM0_HHWW0_T -> "damhw0_t_0(gkm,mkm,"
| D_FM0_HHWW0_U -> "damhw0_u_0(gkm,mkm,"
| D_FM0_HHZZ0_S -> "damhz0_s_0(gkm,mkm,"
| D_FM0_HHZZ0_T -> "damhz0_t_0(gkm,mkm,"
| D_FM0_HHZZ0_U -> "damhz0_u_0(gkm,mkm,"
| D_FM0_HHWW1_S -> "damhw1_s_0(gkm,mkm,"
| D_FM0_HHWW1_T -> "damhw1_t_0(gkm,mkm,"
| D_FM0_HHWW1_U -> "damhw1_u_0(gkm,mkm,"
| D_FM0_HHZZ1_S -> "damhz1_s_0(gkm,mkm,"
| D_FM0_HHZZ1_T -> "damhz1_t_0(gkm,mkm,"
| D_FM0_HHZZ1_U -> "damhz1_u_0(gkm,mkm,"
| D_FM1_HHWW0_S -> "damhw0_s_1(gkm,mkm,"
| D_FM1_HHWW0_T -> "damhw0_t_1(gkm,mkm,"
| D_FM1_HHWW0_U -> "damhw0_u_1(gkm,mkm,"
| D_FM1_HHZZ0_S -> "damhz0_s_1(gkm,mkm,"
| D_FM1_HHZZ0_T -> "damhz0_t_1(gkm,mkm,"
| D_FM1_HHZZ0_U -> "damhz0_u_1(gkm,mkm,"
| D_FM1_HHWW1_S -> "damhw1_s_1(gkm,mkm,"
| D_FM1_HHWW1_T -> "damhw1_t_1(gkm,mkm,"
| D_FM1_HHWW1_U -> "damhw1_u_1(gkm,mkm,"
| D_FM1_HHZZ1_S -> "damhz1_s_1(gkm,mkm,"
| D_FM1_HHZZ1_T -> "damhz1_t_1(gkm,mkm,"
| D_FM1_HHZZ1_U -> "damhz1_u_1(gkm,mkm,"
| D_FM7_HHWW0_S -> "damhw0_s_7(gkm,mkm,"
| D_FM7_HHWW0_T -> "damhw0_t_7(gkm,mkm,"
| D_FM7_HHWW0_U -> "damhw0_u_7(gkm,mkm,"
| D_FM7_HHZZ0_S -> "damhz0_s_7(gkm,mkm,"
| D_FM7_HHZZ0_T -> "damhz0_t_7(gkm,mkm,"
| D_FM7_HHZZ0_U -> "damhz0_u_7(gkm,mkm,"
| D_FM7_HHWW1_S -> "damhw1_s_7(gkm,mkm,"
| D_FM7_HHWW1_T -> "damhw1_t_7(gkm,mkm,"
| D_FM7_HHWW1_U -> "damhw1_u_7(gkm,mkm,"
| D_FM7_HHZZ1_S -> "damhz1_s_7(gkm,mkm,"
| D_FM7_HHZZ1_T -> "damhz1_t_7(gkm,mkm,"
| D_FM7_HHZZ1_U -> "damhz1_u_7(gkm,mkm,"
| G_HWW -> "ghww" | G_HZZ -> "ghzz"
| G_HHWW -> "ghhww" | G_HHZZ -> "ghhzz"
| G_SWW -> "gsww" | G_SZZ -> "gszz"
| G_SHH -> "gshh"
| G_SWW_T -> "gswwt" | G_SZZ_T -> "gszzt"
| G_SAA_T -> "gsaat" | G_SAZ_T -> "gsazt"
| G_PNWW -> "gpnww" | G_PNZZ -> "gpnzz"
| G_PSNWW -> "gpsnww" | G_PSNZZ -> "gpsnzz"
| G_PSNHH -> "gpsnhh"
| G_PWZ -> "gpwz" | G_PWW -> "gpww"
| G_FWW -> "gfww" | G_FZZ -> "gfzz"
| G_FWW_CF -> "gfwwcf" | G_FZZ_CF -> "gfzzcf"
| G_FHH -> "gfhh" | G_FHH_CF -> "gfhhcf"
| G_FWW_T -> "gfwwt" | G_FZZ_T -> "gfzzt"
| G_TNWW -> "gtnww" | G_TNZZ -> "gtnzz"
| G_TNWW_CF -> "gtnwwcf" | G_TNZZ_CF -> "gtnzzcf"
| G_TSNWW -> "gtsnww" | G_TSNZZ -> "gtsnzz"
| G_TSNWW_CF -> "gtsnwwcf" | G_TSNZZ_CF -> "gtsnzzcf"
| G_TWZ -> "gtwz" | G_TWW -> "gtww"
| G_TWZ_CF -> "gtwzcf" | G_TWW_CF -> "gtwwcf"
| G_SSWW -> "gssww" | G_SSZZ -> "gsszz"
| G_Htt -> "ghtt" | G_Hbb -> "ghbb"
| G_Htautau -> "ghtautau" | G_Hcc -> "ghcc" | G_Hmm -> "ghmm"
| G_HGaZ -> "ghgaz" | G_HGaGa -> "ghgaga" | G_Hgg -> "ghgg"
| G_HGaGa_anom -> "ghgaga_ac" | G_HGaZ_anom -> "ghgaz_ac"
| G_HZZ_anom -> "ghzz_ac" | G_HWW_anom -> "ghww_ac"
| G_HGaZ_u -> "ghgaz_u" | G_HZZ_u -> "ghzz_u"
| G_HWW_u -> "ghww_u"
| G_H3 -> "gh3" | G_H4 -> "gh4"
| Gs -> "gs" | I_Gs -> "igs" | G2 -> "gs**2"
| Mass f -> "mass" ^ flavor_symbol f
| Width f -> "width" ^ flavor_symbol f
| K_Matrix_Coeff i -> "kc" ^ string_of_int i
| K_Matrix_Pole i -> "kp" ^ string_of_int i
end
(* \thocwmodulesection{Complete Minimal Standard Model including additional Resonances (alternate Tensor)} *)
module SSC_AltT (Flags : SSC_flags) =
struct
open Coupling
let default_width = ref Timelike
let use_fudged_width = ref false
let options = Options.create
[ "constant_width", Arg.Unit (fun () -> default_width := Constant),
"use constant width (also in t-channel)";
"fudged_width", Arg.Set use_fudged_width,
"use fudge factor for charge particle width";
"custom_width", Arg.String (fun f -> default_width := Custom f),
"use custom width";
"cancel_widths", Arg.Unit (fun () -> default_width := Vanishing),
"use vanishing width";
"cms_width", Arg.Unit (fun () -> default_width := Complex_Mass),
"use complex mass scheme";
"running_width", Arg.Unit (fun () -> default_width := Running),
"use running width"]
let caveats () = []
type f_aux_top = TTGG | TBWA | TBWZ | TTWW | BBWW | (*i top auxiliary field "flavors" *)
QGUG | QBUB | QW | DL | DR
type matter_field = L of int | N of int | U of int | D of int
type gauge_boson = Ga | Wp | Wm | Z | Gl
type other = Phip | Phim | Phi0 | H
| Rsigma | Rphin | Rphisn | Rphip | Rphim | Rphipp | Rphimm
| Rf | Rtn | Rtsn | Rtp | Rtm | Rtpp | Rtmm
| Rff | Rfv | Rfphi
| Aux_top of int*int*int*bool*f_aux_top (*i lorentz*color*charge*top-side*flavor *)
type flavor = M of matter_field | G of gauge_boson | O of other
let matter_field f = M f
let gauge_boson f = G f
let other f = O f
type field =
| Matter of matter_field
| Gauge of gauge_boson
| Other of other
let field = function
| M f -> Matter f
| G f -> Gauge f
| O f -> Other f
type gauge = unit
let gauge_symbol () =
failwith "Modellib_BSM.SSC_AltT.gauge_symbol: internal error"
let family n = List.map matter_field [ L n; N n; U n; D n ]
let rec aux_top_flavors (f,l,co,ch) = List.append
( List.map other [ Aux_top(l,co,ch/2,true,f); Aux_top(l,co,ch/2,false,f) ] )
( if ch > 1 then List.append
( List.map other [ Aux_top(l,co,-ch/2,true,f); Aux_top(l,co,-ch/2,false,f) ] )
( aux_top_flavors (f,l,co,(ch-2)) )
else [] )
let external_flavors () =
[ "1st Generation", ThoList.flatmap family [1; -1];
"2nd Generation", ThoList.flatmap family [2; -2];
"3rd Generation", ThoList.flatmap family [3; -3];
"Gauge Bosons", List.map gauge_boson [Ga; Z; Wp; Wm; Gl];
"Higgs", List.map other [H];
"Scalar Resonances", List.map other [Rsigma; Rphin; Rphisn; Rphip; Rphim; Rphipp; Rphimm];
"Tensor Resonances", List.map other [Rf; Rtn; Rtsn; Rtp; Rtm; Rtpp; Rtmm];
"Alternate Tensor", List.map other [Rff; Rfv; Rfphi];
"Goldstone Bosons", List.map other [Phip; Phim; Phi0] ]
let flavors () = List.append
( ThoList.flatmap snd (external_flavors ()) )
( ThoList.flatmap aux_top_flavors
[ (TTGG,2,1,1); (TBWA,2,0,2); (TBWZ,2,0,2); (TTWW,2,0,1); (BBWW,2,0,1);
(QGUG,1,1,1); (QBUB,1,0,1); (QW,1,0,3); (DL,0,0,3); (DR,0,0,3) ] )
let spinor n =
if n >= 0 then
Spinor
else
ConjSpinor
let lorentz_aux = function
| 2 -> Tensor_1
| 1 -> Vector
| 0 -> Scalar
| _ -> invalid_arg ("SM.lorentz_aux: wrong value")
let lorentz = function
| M f ->
begin match f with
| L n -> spinor n | N n -> spinor n
| U n -> spinor n | D n -> spinor n
end
| G f ->
begin match f with
| Ga | Gl -> Vector
| Wp | Wm | Z -> Massive_Vector
end
| O f ->
begin match f with
| Aux_top (l,_,_,_,_) -> lorentz_aux l
| Rf | Rtn | Rtsn | Rtp | Rtm | Rtpp | Rtmm -> Tensor_2
| Rff -> Tensor_2
| Rfv -> Vector
| _ -> Scalar
end
- let color = function
+ let color = function
| M (U n) -> Color.SUN (if n > 0 then 3 else -3)
| M (D n) -> Color.SUN (if n > 0 then 3 else -3)
| G Gl -> Color.AdjSUN 3
| O (Aux_top (_,co,_,_,_)) -> if co == 0 then Color.Singlet else Color.AdjSUN 3
| _ -> Color.Singlet
let nc () = 3
let prop_spinor n =
if n >= 0 then
Prop_Spinor
else
Prop_ConjSpinor
let prop_aux = function
| 2 -> Aux_Tensor_1
| 1 -> Aux_Vector
| 0 -> Aux_Scalar
| _ -> invalid_arg ("SM.prop_aux: wrong value")
let propagator = function
| M f ->
begin match f with
| L n -> prop_spinor n | N n -> prop_spinor n
| U n -> prop_spinor n | D n -> prop_spinor n
end
| G f ->
begin match f with
| Ga | Gl -> Prop_Feynman
| Wp | Wm | Z -> Prop_Unitarity
end
| O f ->
begin match f with
| Phip | Phim | Phi0 -> Only_Insertion
| H | Rsigma -> Prop_Scalar
| Rphin | Rphisn | Rphip | Rphim | Rphipp | Rphimm -> Prop_Scalar
| Rf -> Prop_Tensor_2
| Rff -> Prop_Tensor_pure
| Rfv -> Prop_Vector_pure
| Rfphi -> Prop_Scalar
| Rtn | Rtsn | Rtp | Rtm | Rtpp | Rtmm -> Prop_Tensor_2
| Aux_top (l,_,_,_,_) -> prop_aux l
end
(* Optionally, ask for the fudge factor treatment for the widths of
charged particles. Currently, this only applies to $W^\pm$ and top. *)
let width f =
if !use_fudged_width then
match f with
| G Wp | G Wm | M (U 3) | M (U (-3)) -> Fudged
| _ -> !default_width
else
!default_width
let goldstone = function
| G f ->
begin match f with
| Wp -> Some (O Phip, Coupling.Integer 1)
| Wm -> Some (O Phim, Coupling.Integer 1)
| Z -> Some (O Phi0, Coupling.Integer 1)
| _ -> None
end
| _ -> None
let conjugate = function
| M f ->
M (begin match f with
| L n -> L (-n) | N n -> N (-n)
| U n -> U (-n) | D n -> D (-n)
end)
| G f ->
G (begin match f with
| Gl -> Gl | Ga -> Ga | Z -> Z
| Wp -> Wm | Wm -> Wp
end)
| O f ->
O (begin match f with
| Phip -> Phim | Phim -> Phip | Phi0 -> Phi0
| H -> H | Rsigma -> Rsigma
| Rphin -> Rphin | Rphip -> Rphim | Rphim -> Rphip
| Rphisn -> Rphisn
| Rphipp -> Rphimm | Rphimm -> Rphipp
| Rf -> Rf
| Rff -> Rff | Rfv -> Rfv | Rfphi -> Rfphi
| Rtn -> Rtn | Rtsn -> Rtsn | Rtp -> Rtm | Rtm -> Rtp
| Rtpp -> Rtmm | Rtmm -> Rtpp
| Aux_top (l,co,ch,n,f) -> Aux_top (l,co,(-ch),(not n),f)
end)
let fermion = function
| M f ->
begin match f with
| L n -> if n > 0 then 1 else -1
| N n -> if n > 0 then 1 else -1
| U n -> if n > 0 then 1 else -1
| D n -> if n > 0 then 1 else -1
end
| G f ->
begin match f with
| Gl | Ga | Z | Wp | Wm -> 0
end
| O _ -> 0
(* Electrical charge, lepton number, baryon number. We could avoid the
rationals altogether by multiplying the first and last by 3 \ldots *)
module Ch = Charges.QQ
let ( // ) = Algebra.Small_Rational.make
let generation' = function
| 1 -> [ 1//1; 0//1; 0//1]
| 2 -> [ 0//1; 1//1; 0//1]
| 3 -> [ 0//1; 0//1; 1//1]
| -1 -> [-1//1; 0//1; 0//1]
| -2 -> [ 0//1; -1//1; 0//1]
| -3 -> [ 0//1; 0//1; -1//1]
| n -> invalid_arg ("SM.generation': " ^ string_of_int n)
let generation f =
if Flags.ckm_present then
[]
else
match f with
| M (L n | N n | U n | D n) -> generation' n
| G _ | O _ -> [0//1; 0//1; 0//1]
let charge = function
| M f ->
begin match f with
| L n -> if n > 0 then -1//1 else 1//1
| N n -> 0//1
| U n -> if n > 0 then 2//3 else -2//3
| D n -> if n > 0 then -1//3 else 1//3
end
| G f ->
begin match f with
| Gl | Ga | Z -> 0//1
| Wp -> 1//1
| Wm -> -1//1
end
| O f ->
begin match f with
| H | Rsigma | Phi0 | Rphin | Rphisn
| Rf | Rff | Rfv | Rfphi | Rtn | Rtsn -> 0//1
| Phip | Rphip | Rtp -> 1//1
| Phim | Rphim | Rtm -> -1//1
| Rphipp | Rtpp -> 2//1
| Rphimm | Rtmm -> -2//1
| Aux_top (_,_,ch,_,_) -> ch//1
end
let lepton = function
| M f ->
begin match f with
| L n | N n -> if n > 0 then 1//1 else -1//1
| U _ | D _ -> 0//1
end
| G _ | O _ -> 0//1
let baryon = function
| M f ->
begin match f with
| L _ | N _ -> 0//1
| U n | D n -> if n > 0 then 1//1 else -1//1
end
| G _ | O _ -> 0//1
let charges f =
[ charge f; lepton f; baryon f] @ generation f
type constant =
| Unit | Half | Pi | Alpha_QED | Sin2thw
| Sinthw | Costhw | E | G_weak | I_G_weak | Vev
| Q_lepton | Q_up | Q_down | G_CC | G_CCQ of int*int
| G_NC_neutrino | G_NC_lepton | G_NC_up | G_NC_down
| G_TVA_ttA | G_TVA_bbA
| G_VLR_ttZ | G_TVA_ttZ | G_TVA_bbZ
| G_VLR_btW | G_VLR_tbW
| G_TLR_btW | G_TRL_tbW
| G_TLR_btWZ | G_TRL_tbWZ
| G_TLR_btWA | G_TRL_tbWA
| G_TVA_ttWW | G_TVA_bbWW
| G_TVA_ttG | G_TVA_ttGG
| G_SP_ttH
| G_VLR_qGuG | G_VLR_qBuB
| G_VLR_qBuB_u | G_VLR_qBuB_d | G_VLR_qBuB_e | G_VL_qBuB_n
| G_VL_qW | G_VL_qW_u | G_VL_qW_d
| G_SL_DttR | G_SR_DttR | G_SL_DttL | G_SLR_DbtR | G_SL_DbtL
| I_Q_W | I_G_ZWW
| G_WWWW | G_ZZWW | G_AZWW | G_AAWW
| I_G1_AWW | I_G1_ZWW
| I_G1_plus_kappa_plus_G4_AWW
| I_G1_plus_kappa_plus_G4_ZWW
| I_G1_plus_kappa_minus_G4_AWW
| I_G1_plus_kappa_minus_G4_ZWW
| I_G1_minus_kappa_plus_G4_AWW
| I_G1_minus_kappa_plus_G4_ZWW
| I_G1_minus_kappa_minus_G4_AWW
| I_G1_minus_kappa_minus_G4_ZWW
| I_lambda_AWW | I_lambda_ZWW
| G5_AWW | G5_ZWW
| I_kappa5_AWW | I_kappa5_ZWW
| I_lambda5_AWW | I_lambda5_ZWW
| FS0_HHWW | FS0_HHZZ
| FS1_HHWW | FS1_HHZZ
| FM0_HHWW | FM0_HHZZ
| FM1_HHWW | FM1_HHZZ
| FM7_HHWW | FM7_HHZZ
| Alpha_WWWW0 | Alpha_ZZWW1 | Alpha_WWWW2
| Alpha_ZZWW0 | Alpha_ZZZZ
| FT0_WWWW0 | FT0_WWWW2
| FT0_ZZWW0 | FT0_ZZWW1
| FT0_ZZZZ | FT0_AAAA
| FT0_AAWW0 | FT0_AAWW1
| FT0_AAZZ
| FT0_AZWW0 | FT0_AZWW1
| FT0_AAAZ | FT0_AZZZ
| FT1_WWWW0 | FT1_WWWW2
| FT1_ZZWW0 | FT1_ZZWW1
| FT1_ZZZZ | FT1_AAAA
| FT1_AAWW0 | FT1_AAWW1
| FT1_AAZZ
| FT1_AZWW0 | FT1_AZWW1
| FT1_AAAZ | FT1_AZZZ
| FT2_WWWW0 | FT2_WWWW2
| FT2_ZZWW0 | FT2_ZZWW1
| FT2_ZZZZ | FT2_AAAA
| FT2_AAWW0 | FT2_AAWW1
| FT2_AAZZ
| FT2_AZWW0 | FT2_AZWW1
| FT2_AAAZ | FT2_AZZZ
| FM0_WWWW0 | FM0_WWWW2
| FM0_ZZWW0 | FM0_ZZWW1
| FM0_ZZZZ
| FM1_WWWW0 | FM1_WWWW2
| FM1_ZZWW0 | FM1_ZZWW1
| FM1_ZZZZ
| FM7_WWWW0 | FM7_WWWW2
| FM7_ZZWW0 | FM7_ZZWW1
| FM7_ZZZZ
| D_Alpha_ZZWW0_S | D_Alpha_ZZWW0_T | D_Alpha_ZZWW1_S
| D_Alpha_ZZWW1_T | D_Alpha_ZZWW1_U | D_Alpha_WWWW0_S
| D_Alpha_WWWW0_T | D_Alpha_WWWW0_U | D_Alpha_WWWW2_S
| D_Alpha_WWWW2_T | D_Alpha_ZZZZ_S | D_Alpha_ZZZZ_T
| D_FT0_ZZWW0_S | D_FT0_ZZWW0_T | D_FT0_ZZWW0_U
| D_FT0_ZZWW1_S | D_FT0_ZZWW1_T | D_FT0_ZZWW1_U
| D_FT0_WWWW0_S | D_FT0_WWWW0_T | D_FT0_WWWW0_U
| D_FT0_WWWW2_S | D_FT0_WWWW2_T | D_FT0_WWWW2_U
| D_FT0_ZZZZ_S | D_FT0_ZZZZ_T | D_FT0_ZZZZ_U
| D_FT0_AAAA_S | D_FT0_AAAA_T | D_FT0_AAAA_U
| D_FT0_AAWW0_S | D_FT0_AAWW0_T | D_FT0_AAWW0_U
| D_FT0_AAWW1_S | D_FT0_AAWW1_T | D_FT0_AAWW1_U
| D_FT0_AAZZ_S | D_FT0_AAZZ_T | D_FT0_AAZZ_U
| D_FT0_AZWW0_S | D_FT0_AZWW0_T | D_FT0_AZWW0_U
| D_FT0_AZWW1_S | D_FT0_AZWW1_T | D_FT0_AZWW1_U
| D_FT0_AAAZ_S | D_FT0_AAAZ_T | D_FT0_AAAZ_U
| D_FT0_AZZZ_S | D_FT0_AZZZ_T | D_FT0_AZZZ_U
| D_FT1_ZZWW0_S | D_FT1_ZZWW0_T | D_FT1_ZZWW0_U
| D_FT1_ZZWW1_S | D_FT1_ZZWW1_T | D_FT1_ZZWW1_U
| D_FT1_WWWW0_S | D_FT1_WWWW0_T | D_FT1_WWWW0_U
| D_FT1_WWWW2_S | D_FT1_WWWW2_T | D_FT1_WWWW2_U
| D_FT1_ZZZZ_S | D_FT1_ZZZZ_T | D_FT1_ZZZZ_U
| D_FT1_AAAA_S | D_FT1_AAAA_T | D_FT1_AAAA_U
| D_FT1_AAWW0_S | D_FT1_AAWW0_T | D_FT1_AAWW0_U
| D_FT1_AAWW1_S | D_FT1_AAWW1_T | D_FT1_AAWW1_U
| D_FT1_AAZZ_S | D_FT1_AAZZ_T | D_FT1_AAZZ_U
| D_FT1_AZWW0_S | D_FT1_AZWW0_T | D_FT1_AZWW0_U
| D_FT1_AZWW1_S | D_FT1_AZWW1_T | D_FT1_AZWW1_U
| D_FT1_AAAZ_S | D_FT1_AAAZ_T | D_FT1_AAAZ_U
| D_FT1_AZZZ_S | D_FT1_AZZZ_T | D_FT1_AZZZ_U
| D_FT2_ZZWW0_S | D_FT2_ZZWW0_T | D_FT2_ZZWW0_U
| D_FT2_ZZWW1_S | D_FT2_ZZWW1_T | D_FT2_ZZWW1_U
| D_FT2_WWWW0_S | D_FT2_WWWW0_T | D_FT2_WWWW0_U
| D_FT2_WWWW2_S | D_FT2_WWWW2_T | D_FT2_WWWW2_U
| D_FT2_ZZZZ_S | D_FT2_ZZZZ_T | D_FT2_ZZZZ_U
| D_FT2_AAAA_S | D_FT2_AAAA_T | D_FT2_AAAA_U
| D_FT2_AAWW0_S | D_FT2_AAWW0_T | D_FT2_AAWW0_U
| D_FT2_AAWW1_S | D_FT2_AAWW1_T | D_FT2_AAWW1_U
| D_FT2_AAZZ_S | D_FT2_AAZZ_T | D_FT2_AAZZ_U
| D_FT2_AZWW0_S | D_FT2_AZWW0_T | D_FT2_AZWW0_U
| D_FT2_AZWW1_S | D_FT2_AZWW1_T | D_FT2_AZWW1_U
| D_FT2_AAAZ_S | D_FT2_AAAZ_T | D_FT2_AAAZ_U
| D_FT2_AZZZ_S | D_FT2_AZZZ_T | D_FT2_AZZZ_U
| D_FTrsi_ZZWW0_S | D_FTrsi_ZZWW0_T | D_FTrsi_ZZWW0_U
| D_FTrsi_ZZWW1_S | D_FTrsi_ZZWW1_T | D_FTrsi_ZZWW1_U
| D_FTrsi_WWWW0_S | D_FTrsi_WWWW0_T | D_FTrsi_WWWW0_U
| D_FTrsi_WWWW2_S | D_FTrsi_WWWW2_T | D_FTrsi_WWWW2_U
| D_FTrsi_ZZZZ_S | D_FTrsi_ZZZZ_T | D_FTrsi_ZZZZ_U
| D_FTrsi_AAAA_S | D_FTrsi_AAAA_T | D_FTrsi_AAAA_U
| D_FTrsi_AAWW0_S | D_FTrsi_AAWW0_T | D_FTrsi_AAWW0_U
| D_FTrsi_AAWW1_S | D_FTrsi_AAWW1_T | D_FTrsi_AAWW1_U
| D_FTrsi_AAZZ_S | D_FTrsi_AAZZ_T | D_FTrsi_AAZZ_U
| D_FTrsi_AZWW0_S | D_FTrsi_AZWW0_T | D_FTrsi_AZWW0_U
| D_FTrsi_AZWW1_S | D_FTrsi_AZWW1_T | D_FTrsi_AZWW1_U
| D_FTrsi_AAAZ_S | D_FTrsi_AAAZ_T | D_FTrsi_AAAZ_U
| D_FTrsi_AZZZ_S | D_FTrsi_AZZZ_T | D_FTrsi_AZZZ_U
| D_FM0_ZZWW0_S | D_FM0_ZZWW0_T | D_FM0_ZZWW0_U
| D_FM0_ZZWW1_S | D_FM0_ZZWW1_T | D_FM0_ZZWW1_U
| D_FM0_WWWW0_S | D_FM0_WWWW0_T | D_FM0_WWWW0_U
| D_FM0_WWWW2_S | D_FM0_WWWW2_T | D_FM0_WWWW2_U
| D_FM0_ZZZZ_S | D_FM0_ZZZZ_T | D_FM0_ZZZZ_U
| D_FM1_ZZWW0_S | D_FM1_ZZWW0_T | D_FM1_ZZWW0_U
| D_FM1_ZZWW1_S | D_FM1_ZZWW1_T | D_FM1_ZZWW1_U
| D_FM1_WWWW0_S | D_FM1_WWWW0_T | D_FM1_WWWW0_U
| D_FM1_WWWW2_S | D_FM1_WWWW2_T | D_FM1_WWWW2_U
| D_FM1_ZZZZ_S | D_FM1_ZZZZ_T | D_FM1_ZZZZ_U
| D_FM7_ZZWW0_S | D_FM7_ZZWW0_T | D_FM7_ZZWW0_U
| D_FM7_ZZWW1_S | D_FM7_ZZWW1_T | D_FM7_ZZWW1_U
| D_FM7_WWWW0_S | D_FM7_WWWW0_T | D_FM7_WWWW0_U
| D_FM7_WWWW2_S | D_FM7_WWWW2_T | D_FM7_WWWW2_U
| D_FM7_ZZZZ_S | D_FM7_ZZZZ_T | D_FM7_ZZZZ_U
| D_Alpha_HHHH_S | D_Alpha_HHHH_T
| D_Alpha_HHZZ0_S | D_Alpha_HHWW0_S
| D_Alpha_HHZZ0_T | D_Alpha_HHWW0_T
| D_Alpha_HHZZ1_S | D_Alpha_HHWW1_S
| D_Alpha_HHZZ1_T | D_Alpha_HHWW1_T
| D_Alpha_HHZZ1_U | D_Alpha_HHWW1_U
| D_FM0_HHZZ0_S | D_FM0_HHWW0_S
| D_FM0_HHZZ0_T | D_FM0_HHWW0_T
| D_FM0_HHZZ0_U | D_FM0_HHWW0_U
| D_FM0_HHZZ1_S | D_FM0_HHWW1_S
| D_FM0_HHZZ1_T | D_FM0_HHWW1_T
| D_FM0_HHZZ1_U | D_FM0_HHWW1_U
| D_FM1_HHZZ0_S | D_FM1_HHWW0_S
| D_FM1_HHZZ0_T | D_FM1_HHWW0_T
| D_FM1_HHZZ0_U | D_FM1_HHWW0_U
| D_FM1_HHZZ1_S | D_FM1_HHWW1_S
| D_FM1_HHZZ1_T | D_FM1_HHWW1_T
| D_FM1_HHZZ1_U | D_FM1_HHWW1_U
| D_FM7_HHZZ0_S | D_FM7_HHWW0_S
| D_FM7_HHZZ0_T | D_FM7_HHWW0_T
| D_FM7_HHZZ0_U | D_FM7_HHWW0_U
| D_FM7_HHZZ1_S | D_FM7_HHWW1_S
| D_FM7_HHZZ1_T | D_FM7_HHWW1_T
| D_FM7_HHZZ1_U | D_FM7_HHWW1_U
| G_HWW | G_HHWW | G_HZZ | G_HHZZ
| G_SWW | G_SWW_T | G_SSWW | G_SZZ
| G_SZZ_T | G_SSZZ | G_SHH
| G_SAA_T | G_SAZ_T
| G_PNWW | G_PNZZ | G_PWZ | G_PWW
| G_PSNWW | G_PSNZZ | G_PSNHH
| G_FWW | G_FZZ | G_FWW_CF | G_FZZ_CF
| G_FWW_T | G_FZZ_T | G_FHH | G_FHH_CF
| G_FFWW | G_FFZZ | G_FFWW_CF | G_FFZZ_CF
| G_FFHH | G_FFHH_CF
| G_FVWW | G_FVZZ | G_FVHH | G_FVWW_CF | G_FVZZ_CF | G_FVHH_CF
| G_FDDSWW | G_FDDSZZ | G_FDDSHH | G_FDDSWW_CF
| G_FDDSZZ_CF | G_FDDSHH_CF | G_FSWW | G_FSZZ | G_FSHH
| G_TNWW | G_TNZZ | G_TSNWW | G_TSNZZ | G_TWZ | G_TWW
| G_TNWW_CF | G_TNZZ_CF | G_TSNWW_CF | G_TSNZZ_CF
| G_TWZ_CF | G_TWW_CF
| G_Htt | G_Hbb | G_Hcc | G_Hmm | G_Htautau | G_H3 | G_H4
| FS_H4
| G_HGaZ | G_HGaGa | G_Hgg
| G_HGaZ_anom | G_HGaGa_anom | G_HZZ_anom | G_HWW_anom
| G_HGaZ_u | G_HZZ_u | G_HWW_u
| Gs | I_Gs | G2
| Mass of flavor | Width of flavor
| K_Matrix_Coeff of int | K_Matrix_Pole of int
(* \begin{dubious}
The current abstract syntax for parameter dependencies is admittedly
tedious. Later, there will be a parser for a convenient concrete syntax
as a part of a concrete syntax for models. But as these examples show,
it should include simple functions.
\end{dubious} *)
- type orders = int * int
+ type coupling_order = QCD | EW
+ let all_coupling_orders () = [QCD; EW]
+ let coupling_order_to_string = function
+ | QCD -> "QCD"
+ | EW -> "EW"
- let orders = function
- | _ -> (0,0)
+ let coupling_orders = function
+ | _ -> failwith "Modellib_BSM.SSC_AltT.orders: not implemented yet!"
(* \begin{subequations}
\begin{align}
\alpha_{\text{QED}} &= \frac{1}{137.0359895} \\
\sin^2\theta_w &= 0.23124
\end{align}
\end{subequations} *)
let input_parameters =
[ Alpha_QED, 1. /. 137.0359895;
Sin2thw, 0.23124;
Mass (G Z), 91.187;
Mass (M (N 1)), 0.0; Mass (M (L 1)), 0.51099907e-3;
Mass (M (N 2)), 0.0; Mass (M (L 2)), 0.105658389;
Mass (M (N 3)), 0.0; Mass (M (L 3)), 1.77705;
Mass (M (U 1)), 5.0e-3; Mass (M (D 1)), 3.0e-3;
Mass (M (U 2)), 1.2; Mass (M (D 2)), 0.1;
Mass (M (U 3)), 174.0; Mass (M (D 3)), 4.2 ]
(* \begin{subequations}
\begin{align}
e &= \sqrt{4\pi\alpha} \\
\sin\theta_w &= \sqrt{\sin^2\theta_w} \\
\cos\theta_w &= \sqrt{1-\sin^2\theta_w} \\
g &= \frac{e}{\sin\theta_w} \\
m_W &= \cos\theta_w m_Z \\
v &= \frac{2m_W}{g} \\
g_{CC} =
-\frac{g}{2\sqrt2} &= -\frac{e}{2\sqrt2\sin\theta_w} \\
Q_{\text{lepton}} =
-q_{\text{lepton}}e &= e \\
Q_{\text{up}} =
-q_{\text{up}}e &= -\frac{2}{3}e \\
Q_{\text{down}} =
-q_{\text{down}}e &= \frac{1}{3}e \\
\ii q_We =
\ii g_{\gamma WW} &= \ii e \\
\ii g_{ZWW} &= \ii g \cos\theta_w \\
\ii g_{WWW} &= \ii g
\end{align}
\end{subequations} *)
(* \begin{dubious}
\ldots{} to be continued \ldots{}
The quartic couplings can't be correct, because the dimensions are wrong!
\begin{subequations}
\begin{align}
g_{HWW} &= g m_W = 2 \frac{m_W^2}{v}\\
g_{HHWW} &= 2 \frac{m_W^2}{v^2} = \frac{g^2}{2} \\
g_{HZZ} &= \frac{g}{\cos\theta_w}m_Z \\
g_{HHZZ} &= 2 \frac{m_Z^2}{v^2} = \frac{g^2}{2\cos\theta_w} \\
g_{Htt} &= \lambda_t \\
g_{Hbb} &= \lambda_b=\frac{m_b}{m_t}\lambda_t \\
g_{H^3} &= - \frac{3g}{2}\frac{m_H^2}{m_W} = - 3 \frac{m_H^2}{v}
g_{H^4} &= - \frac{3g^2}{4} \frac{m_W^2}{v^2} = -3 \frac{m_H^2}{v^2}
\end{align}
\end{subequations}
\end{dubious} *)
let derived_parameters =
[ Real E, Sqrt (Prod [Integer 4; Atom Pi; Atom Alpha_QED]);
Real Sinthw, Sqrt (Atom Sin2thw);
Real Costhw, Sqrt (Diff (Integer 1, Atom Sin2thw));
Real G_weak, Quot (Atom E, Atom Sinthw);
Real (Mass (G Wp)), Prod [Atom Costhw; Atom (Mass (G Z))];
Real Vev, Quot (Prod [Integer 2; Atom (Mass (G Wp))], Atom G_weak);
Real Q_lepton, Atom E;
Real Q_up, Prod [Quot (Integer (-2), Integer 3); Atom E];
Real Q_down, Prod [Quot (Integer 1, Integer 3); Atom E];
Real G_CC, Neg (Quot (Atom G_weak, Prod [Integer 2; Sqrt (Integer 2)]));
Complex I_Q_W, Prod [I; Atom E];
Complex I_G_weak, Prod [I; Atom G_weak];
Complex I_G_ZWW, Prod [I; Atom G_weak; Atom Costhw] ]
(* \begin{equation}
- \frac{g}{2\cos\theta_w}
\end{equation} *)
let g_over_2_costh =
Quot (Neg (Atom G_weak), Prod [Integer 2; Atom Costhw])
(* \begin{subequations}
\begin{align}
- \frac{g}{2\cos\theta_w} g_V
&= - \frac{g}{2\cos\theta_w} (T_3 - 2 q \sin^2\theta_w) \\
- \frac{g}{2\cos\theta_w} g_A
&= - \frac{g}{2\cos\theta_w} T_3
\end{align}
\end{subequations} *)
let nc_coupling c t3 q =
(Real_Array c,
[Prod [g_over_2_costh; Diff (t3, Prod [Integer 2; q; Atom Sin2thw])];
Prod [g_over_2_costh; t3]])
let half = Quot (Integer 1, Integer 2)
let derived_parameter_arrays =
[ nc_coupling G_NC_neutrino half (Integer 0);
nc_coupling G_NC_lepton (Neg half) (Integer (-1));
nc_coupling G_NC_up half (Quot (Integer 2, Integer 3));
nc_coupling G_NC_down (Neg half) (Quot (Integer (-1), Integer 3)) ]
let parameters () =
{ input = input_parameters;
derived = derived_parameters;
derived_arrays = derived_parameter_arrays }
module F = Modeltools.Fusions (struct
type f = flavor
type c = constant
let compare = compare
let conjugate = conjugate
end)
(* \begin{equation}
\mathcal{L}_{\textrm{EM}} =
- e \sum_i q_i \bar\psi_i\fmslash{A}\psi_i
\end{equation} *)
let mgm ((m1, g, m2), fbf, c) = ((M m1, G g, M m2), fbf, c)
let mom ((m1, o, m2), fbf, c) = ((M m1, O o, M m2), fbf, c)
let electromagnetic_currents n =
List.map mgm
[ ((L (-n), Ga, L n), FBF (1, Psibar, V, Psi), Q_lepton);
((U (-n), Ga, U n), FBF (1, Psibar, V, Psi), Q_up);
((D (-n), Ga, D n), FBF (1, Psibar, V, Psi), Q_down) ]
let color_currents n =
List.map mgm
[ ((U (-n), Gl, U n), FBF ((-1), Psibar, V, Psi), Gs);
((D (-n), Gl, D n), FBF ((-1), Psibar, V, Psi), Gs) ]
(* \begin{equation}
\mathcal{L}_{\textrm{NC}} =
- \frac{g}{2\cos\theta_W}
\sum_i \bar\psi_i\fmslash{Z}(g_V^i-g_A^i\gamma_5)\psi_i
\end{equation} *)
let neutral_currents n =
List.map mgm
[ ((L (-n), Z, L n), FBF (1, Psibar, VA, Psi), G_NC_lepton);
((N (-n), Z, N n), FBF (1, Psibar, VA, Psi), G_NC_neutrino);
((U (-n), Z, U n), FBF (1, Psibar, VA, Psi), G_NC_up);
((D (-n), Z, D n), FBF (1, Psibar, VA, Psi), G_NC_down) ]
(* \begin{equation}
\mathcal{L}_{\textrm{CC}} =
- \frac{g}{2\sqrt2} \sum_i \bar\psi_i
(T^+\fmslash{W}^+ + T^-\fmslash{W}^-)(1-\gamma_5)\psi_i
\end{equation} *)
let charged_currents' n =
List.map mgm
[ ((L (-n), Wm, N n), FBF (1, Psibar, VL, Psi), G_CC);
((N (-n), Wp, L n), FBF (1, Psibar, VL, Psi), G_CC) ]
let charged_currents'' n =
List.map mgm
[ ((D (-n), Wm, U n), FBF (1, Psibar, VL, Psi), G_CC);
((U (-n), Wp, D n), FBF (1, Psibar, VL, Psi), G_CC) ]
let charged_currents_triv =
ThoList.flatmap charged_currents' [1;2;3] @
ThoList.flatmap charged_currents'' [1;2;3]
let charged_currents_ckm =
let charged_currents_2 n1 n2 =
List.map mgm
[ ((D (-n1), Wm, U n2), FBF (1, Psibar, VL, Psi), G_CCQ (n2,n1));
((U (-n1), Wp, D n2), FBF (1, Psibar, VL, Psi), G_CCQ (n1,n2)) ] in
ThoList.flatmap charged_currents' [1;2;3] @
List.flatten (Product.list2 charged_currents_2 [1;2;3] [1;2;3])
let yukawa =
[ ((M (U (-3)), O H, M (U 3)), FBF (1, Psibar, S, Psi), G_Htt);
((M (D (-3)), O H, M (D 3)), FBF (1, Psibar, S, Psi), G_Hbb);
((M (U (-2)), O H, M (U 2)), FBF (1, Psibar, S, Psi), G_Hcc);
((M (L (-3)), O H, M (L 3)), FBF (1, Psibar, S, Psi), G_Htautau) ] @
if Flags.higgs_hmm then
[ ((M (L (-2)), O H, M (L 2)), FBF (1, Psibar, S, Psi), G_Hmm)]
else
[]
(* \begin{equation}
\mathcal{L}_{\textrm{TGC}} =
- e \partial_\mu A_\nu W_+^\mu W_-^\nu + \ldots
- e \cot\theta_w \partial_\mu Z_\nu W_+^\mu W_-^\nu + \ldots
\end{equation} *)
let tgc ((g1, g2, g3), t, c) = ((G g1, G g2, G g3), t, c)
let standard_triple_gauge =
List.map tgc
[ ((Ga, Wm, Wp), Gauge_Gauge_Gauge 1, I_Q_W);
((Z, Wm, Wp), Gauge_Gauge_Gauge 1, I_G_ZWW);
((Gl, Gl, Gl), Gauge_Gauge_Gauge 1, I_Gs)]
(* \begin{multline}
\mathcal{L}_{\textrm{TGC}}(g_1,\kappa)
= g_1 \mathcal{L}_T(V,W^+,W^-) \\
+ \frac{\kappa+g_1}{2} \Bigl(\mathcal{L}_T(W^-,V,W^+)
- \mathcal{L}_T(W^+,V,W^-)\Bigr)\\
+ \frac{\kappa-g_1}{2} \Bigl(\mathcal{L}_L(W^-,V,W^+)
- \mathcal{L}_T(W^+,V,W^-)\Bigr)
\end{multline} *)
(* \begin{dubious}
The whole thing in the LEP2 workshop notation:
\begin{multline}
\ii\mathcal{L}_{\textrm{TGC},V} / g_{WWV} = \\
g_1^V V^\mu (W^-_{\mu\nu}W^{+,\nu}-W^+_{\mu\nu}W^{-,\nu})
+ \kappa_V W^+_\mu W^-_\nu V^{\mu\nu}
+ \frac{\lambda_V}{m_W^2} V_{\mu\nu}
W^-_{\rho\mu} W^{+,\hphantom{\nu}\rho}_{\hphantom{+,}\nu} \\
+ \ii g_5^V \epsilon_{\mu\nu\rho\sigma}
\left( (\partial^\rho W^{-,\mu}) W^{+,\nu}
- W^{-,\mu}(\partial^\rho W^{+,\nu}) \right) V^\sigma \\
+ \ii g_4^V W^-_\mu W^+_\nu (\partial^\mu V^\nu + \partial^\nu V^\mu)
- \frac{\tilde\kappa_V}{2} W^-_\mu W^+_\nu \epsilon^{\mu\nu\rho\sigma}
V_{\rho\sigma}
- \frac{\tilde\lambda_V}{2m_W^2}
W^-_{\rho\mu} W^{+,\mu}_{\hphantom{+,\mu}\nu} \epsilon^{\nu\rho\alpha\beta}
V_{\alpha\beta}
\end{multline}
using the conventions of Itzykson and Zuber with $\epsilon^{0123} = +1$.
\end{dubious} *)
(* \begin{dubious}
This is equivalent to the notation of Hagiwara et al.~\cite{HPZH87}, if we
remember that they have opposite signs for~$g_{WWV}$:
\begin{multline}
\mathcal{L}_{WWV} / (-g_{WWV}) = \\
\ii g_1^V \left( W^\dagger_{\mu\nu} W^\mu
- W^\dagger_\mu W^\mu_{\hphantom{\mu}\nu} \right) V^\nu
+ \ii \kappa_V W^\dagger_\mu W_\nu V^{\mu\nu}
+ \ii \frac{\lambda_V}{m_W^2}
W^\dagger_{\lambda\mu} W^\mu_{\hphantom{\mu}\nu} V^{\nu\lambda} \\
- g_4^V W^\dagger_\mu W_\nu
\left(\partial^\mu V^\nu + \partial^\nu V^\mu \right)
+ g_5^V \epsilon^{\mu\nu\lambda\sigma}
\left( W^\dagger_\mu \stackrel{\leftrightarrow}{\partial_\lambda}
W_\nu \right) V_\sigma\\
+ \ii \tilde\kappa_V W^\dagger_\mu W_\nu \tilde{V}^{\mu\nu}
+ \ii\frac{\tilde\lambda_V}{m_W^2}
W^\dagger_{\lambda\mu} W^\mu_{\hphantom{\mu}\nu} \tilde{V}^{\nu\lambda}
\end{multline}
Here $V^\mu$ stands for either the photon or the~$Z$ field, $W^\mu$ is the
$W^-$ field, $W_{\mu\nu} = \partial_\mu W_\nu - \partial_\nu W_\mu$,
$V_{\mu\nu} = \partial_\mu V_\nu - \partial_\nu V_\mu$, and
$\tilde{V}_{\mu\nu} = \frac{1}{2} \epsilon_{\mu\nu\lambda\sigma}
V^{\lambda\sigma}$.
\end{dubious} *)
let anomalous_triple_gauge =
List.map tgc
[ ((Ga, Wm, Wp), Dim4_Vector_Vector_Vector_T (-1),
I_G1_AWW);
((Z, Wm, Wp), Dim4_Vector_Vector_Vector_T (-1),
I_G1_ZWW);
((Wm, Ga, Wp), Dim4_Vector_Vector_Vector_T 1,
I_G1_plus_kappa_minus_G4_AWW);
((Wm, Z, Wp), Dim4_Vector_Vector_Vector_T 1,
I_G1_plus_kappa_minus_G4_ZWW);
((Wp, Ga, Wm), Dim4_Vector_Vector_Vector_T (-1),
I_G1_plus_kappa_plus_G4_AWW);
((Wp, Z, Wm), Dim4_Vector_Vector_Vector_T (-1),
I_G1_plus_kappa_plus_G4_ZWW);
((Wm, Ga, Wp), Dim4_Vector_Vector_Vector_L (-1),
I_G1_minus_kappa_plus_G4_AWW);
((Wm, Z, Wp), Dim4_Vector_Vector_Vector_L (-1),
I_G1_minus_kappa_plus_G4_ZWW);
((Wp, Ga, Wm), Dim4_Vector_Vector_Vector_L 1,
I_G1_minus_kappa_minus_G4_AWW);
((Wp, Z, Wm), Dim4_Vector_Vector_Vector_L 1,
I_G1_minus_kappa_minus_G4_ZWW);
((Ga, Wm, Wp), Dim4_Vector_Vector_Vector_L5 (-1),
I_kappa5_AWW);
((Z, Wm, Wp), Dim4_Vector_Vector_Vector_L5 (-1),
I_kappa5_ZWW);
((Ga, Wm, Wp), Dim4_Vector_Vector_Vector_T5 (-1),
G5_AWW);
((Z, Wm, Wp), Dim4_Vector_Vector_Vector_T5 (-1),
G5_ZWW);
((Ga, Wp, Wm), Dim6_Gauge_Gauge_Gauge (-1),
I_lambda_AWW);
((Z, Wp, Wm), Dim6_Gauge_Gauge_Gauge (-1),
I_lambda_ZWW);
((Ga, Wp, Wm), Dim6_Gauge_Gauge_Gauge_5 (-1),
I_lambda5_AWW);
((Z, Wp, Wm), Dim6_Gauge_Gauge_Gauge_5 (-1),
I_lambda5_ZWW) ]
let triple_gauge =
if Flags.triple_anom then
anomalous_triple_gauge
else
standard_triple_gauge
(* \begin{equation}
\mathcal{L}_{\textrm{QGC}} =
- g^2 W_{+,\mu} W_{-,\nu} W_+^\mu W_-^\nu + \ldots
\end{equation} *)
(* Actually, quartic gauge couplings are a little bit more straightforward
using auxiliary fields. Here we have to impose the antisymmetry manually:
\begin{subequations}
\begin{multline}
(W^{+,\mu}_1 W^{-,\nu}_2 - W^{+,\nu}_1 W^{-,\mu}_2)
(W^+_{3,\mu} W^-_{4,\nu} - W^+_{3,\nu} W^-_{4,\mu}) \\
= 2(W^+_1W^+_3)(W^-_2W^-_4) - 2(W^+_1W^-_4)(W^-_2W^+_3)
\end{multline}
also ($V$ can be $A$ or $Z$)
\begin{multline}
(W^{+,\mu}_1 V^\nu_2 - W^{+,\nu}_1 V^\mu_2)
(W^-_{3,\mu} V_{4,\nu} - W^-_{3,\nu} V_{4,\mu}) \\
= 2(W^+_1W^-_3)(V_2V_4) - 2(W^+_1V_4)(V_2W^-_3)
\end{multline}
\end{subequations} *)
(* \begin{subequations}
\begin{multline}
W^{+,\mu} W^{-,\nu} W^+_\mu W^-_\nu
\end{multline}
\end{subequations} *)
let qgc ((g1, g2, g3, g4), t, c) = ((G g1, G g2, G g3, G g4), t, c)
let gauge4 = Vector4 [(2, C_13_42); (-1, C_12_34); (-1, C_14_23)]
let minus_gauge4 = Vector4 [(-2, C_13_42); (1, C_12_34); (1, C_14_23)]
let standard_quartic_gauge =
List.map qgc
[ (Wm, Wp, Wm, Wp), gauge4, G_WWWW;
(Wm, Z, Wp, Z), minus_gauge4, G_ZZWW;
(Wm, Z, Wp, Ga), minus_gauge4, G_AZWW;
(Wm, Ga, Wp, Ga), minus_gauge4, G_AAWW;
(Gl, Gl, Gl, Gl), gauge4, G2 ]
(* \begin{subequations}
\begin{align}
\mathcal{L}_4
&= \alpha_4 \left( \frac{g^4}{2}\left( (W^+_\mu W^{-,\mu})^2
+ W^+_\mu W^{+,\mu} W^-_\mu W^{-,\mu}
\right)\right.\notag \\
&\qquad\qquad\qquad \left.
+ \frac{g^4}{\cos^2\theta_w} W^+_\mu Z^\mu W^-_\nu Z^\nu
+ \frac{g^4}{4\cos^4\theta_w} (Z_\mu Z^\mu)^2 \right) \\
\mathcal{L}_5
&= \alpha_5 \left( g^4 (W^+_\mu W^{-,\mu})^2
+ \frac{g^4}{\cos^2\theta_w} W^+_\mu W^{-,\mu} Z_\nu Z^\nu
+ \frac{g^4}{4\cos^4\theta_w} (Z_\mu Z^\mu)^2 \right)
\end{align}
\end{subequations}
or
\begin{multline}
\mathcal{L}_4 + \mathcal{L}_5
= (\alpha_4+2\alpha_5) g^4 \frac{1}{2} (W^+_\mu W^{-,\mu})^2 \\
+ 2\alpha_4 g^4 \frac{1}{4} W^+_\mu W^{+,\mu} W^-_\mu W^{-,\mu}
+ \alpha_4 \frac{g^4}{\cos^2\theta_w} W^+_\mu Z^\mu W^-_\nu Z^\nu \\
+ 2\alpha_5 \frac{g^4}{\cos^2\theta_w} \frac{1}{2} W^+_\mu W^{-,\mu} Z_\nu Z^\nu
+ (2\alpha_4 + 2\alpha_5) \frac{g^4}{\cos^4\theta_w} \frac{1}{8} (Z_\mu Z^\mu)^2
\end{multline}
and therefore
\begin{subequations}
\begin{align}
\alpha_{(WW)_0} &= (\alpha_4+2\alpha_5) g^4 \\
\alpha_{(WW)_2} &= 2\alpha_4 g^4 \\
\alpha_{(WZ)_0} &= 2\alpha_5 \frac{g^4}{\cos^2\theta_w} \\
\alpha_{(WZ)_1} &= \alpha_4 \frac{g^4}{\cos^2\theta_w} \\
\alpha_{ZZ} &= (2\alpha_4 + 2\alpha_5) \frac{g^4}{\cos^4\theta_w}
\end{align}
\end{subequations} *)
let anomalous_quartic_gauge =
if Flags.quartic_anom then
List.map qgc
[ ((Wm, Wm, Wp, Wp),
Vector4 [(1, C_13_42); (1, C_14_23)], Alpha_WWWW0);
((Wm, Wm, Wp, Wp),
Vector4 [1, C_12_34], Alpha_WWWW2);
((Z, Z, Z, Z),
Vector4 [(1, C_12_34); (1, C_13_42); (1, C_14_23)], Alpha_ZZZZ);
((Wm, Wp, Z, Z),
Vector4 [1, C_12_34], Alpha_ZZWW0);
((Wm, Wp, Z, Z),
Vector4 [(1, C_13_42); (1, C_14_23)], Alpha_ZZWW1)]
@
(if Flags.k_matrix_tm then
List.map qgc
[((Wm, Wm, Wp, Wp),
Dim8_Vector4_t_0 [1, C_13_42], FT0_WWWW0);
((Wm, Wm, Wp, Wp),
Dim8_Vector4_t_0 [1, C_14_23], FT0_WWWW0);
((Wm, Wm, Wp, Wp),
Dim8_Vector4_t_0 [1, C_12_34], FT0_WWWW2);
((Wm, Wm, Wp, Wp),
Dim8_Vector4_t_1 [1, C_13_42], FT1_WWWW0);
((Wm, Wm, Wp, Wp),
Dim8_Vector4_t_1 [1, C_14_23], FT1_WWWW0);
((Wm, Wm, Wp, Wp),
Dim8_Vector4_t_1 [1, C_12_34], FT1_WWWW2);
((Wm, Wm, Wp, Wp),
Dim8_Vector4_t_2 [1, C_13_42], FT2_WWWW0);
((Wm, Wm, Wp, Wp),
Dim8_Vector4_t_2 [1, C_14_23], FT2_WWWW0);
((Wm, Wm, Wp, Wp),
Dim8_Vector4_t_2 [1, C_12_34], FT2_WWWW2);
((Wm, Wm, Wp, Wp),
Dim8_Vector4_m_0 [1, C_13_42], FM0_WWWW0);
((Wm, Wm, Wp, Wp),
Dim8_Vector4_m_0 [1, C_14_23], FM0_WWWW0);
((Wm, Wm, Wp, Wp),
Dim8_Vector4_m_0 [1, C_12_34], FM0_WWWW2);
((Wm, Wm, Wp, Wp),
Dim8_Vector4_m_1 [1, C_13_42], FM1_WWWW0);
((Wm, Wm, Wp, Wp),
Dim8_Vector4_m_1 [1, C_14_23], FM1_WWWW0);
((Wm, Wm, Wp, Wp),
Dim8_Vector4_m_1 [1, C_12_34], FM1_WWWW2);
((Wm, Wm, Wp, Wp),
Dim8_Vector4_m_7 [1, C_13_42], FM7_WWWW0);
((Wm, Wm, Wp, Wp),
Dim8_Vector4_m_7 [1, C_14_23], FM7_WWWW0);
((Wm, Wm, Wp, Wp),
Dim8_Vector4_m_7 [1, C_12_34], FM7_WWWW2);
((Wm, Wp, Z, Z),
Dim8_Vector4_t_0 [1, C_12_34], FT0_ZZWW0);
((Wm, Wp, Z, Z),
Dim8_Vector4_t_0 [1, C_13_42], FT0_ZZWW1);
((Wm, Wp, Z, Z),
Dim8_Vector4_t_0 [1, C_14_23], FT0_ZZWW1);
((Wm, Wp, Z, Z),
Dim8_Vector4_t_1 [1, C_12_34], FT1_ZZWW0);
((Wm, Wp, Z, Z),
Dim8_Vector4_t_1 [1, C_13_42], FT1_ZZWW1);
((Wm, Wp, Z, Z),
Dim8_Vector4_t_1 [1, C_14_23], FT1_ZZWW1);
((Wm, Wp, Z, Z),
Dim8_Vector4_t_2 [1, C_12_34], FT2_ZZWW0);
((Wm, Wp, Z, Z),
Dim8_Vector4_t_2 [1, C_13_42], FT2_ZZWW1);
((Wm, Wp, Z, Z),
Dim8_Vector4_t_2 [1, C_14_23], FT2_ZZWW1);
((Wm, Wp, Z, Z),
Dim8_Vector4_m_0 [1, C_12_34], FM0_ZZWW0);
((Wm, Wp, Z, Z),
Dim8_Vector4_m_0 [1, C_13_42], FM0_ZZWW1);
((Wm, Wp, Z, Z),
Dim8_Vector4_m_0 [1, C_14_23], FM0_ZZWW1);
((Wm, Wp, Z, Z),
Dim8_Vector4_m_1 [1, C_12_34], FM1_ZZWW0);
((Wm, Wp, Z, Z),
Dim8_Vector4_m_1 [1, C_13_42], FM1_ZZWW1);
((Wm, Wp, Z, Z),
Dim8_Vector4_m_1 [1, C_14_23], FM1_ZZWW1);
((Wm, Wp, Z, Z),
Dim8_Vector4_m_7 [1, C_12_34], FM7_ZZWW0);
((Wm, Wp, Z, Z),
Dim8_Vector4_m_7 [1, C_13_42], FM7_ZZWW1);
((Wm, Wp, Z, Z),
Dim8_Vector4_m_7 [1, C_14_23], FM7_ZZWW1);
((Z, Z, Z, Z),
Dim8_Vector4_t_0 [1, C_12_34], FT0_ZZZZ);
((Z, Z, Z, Z),
Dim8_Vector4_t_0 [1, C_13_42], FT0_ZZZZ);
((Z, Z, Z, Z),
Dim8_Vector4_t_0 [1, C_14_23], FT0_ZZZZ);
((Z, Z, Z, Z),
Dim8_Vector4_t_1 [1, C_12_34], FT1_ZZZZ);
((Z, Z, Z, Z),
Dim8_Vector4_t_1 [1, C_13_42], FT1_ZZZZ);
((Z, Z, Z, Z),
Dim8_Vector4_t_1 [1, C_14_23], FT1_ZZZZ);
((Z, Z, Z, Z),
Dim8_Vector4_t_2 [1, C_12_34], FT2_ZZZZ);
((Z, Z, Z, Z),
Dim8_Vector4_t_2 [1, C_13_42], FT2_ZZZZ);
((Z, Z, Z, Z),
Dim8_Vector4_t_2 [1, C_14_23], FT2_ZZZZ);
((Z, Z, Z, Z),
Dim8_Vector4_m_0 [1, C_12_34], FM0_ZZZZ);
((Z, Z, Z, Z),
Dim8_Vector4_m_0 [1, C_13_42], FM0_ZZZZ);
((Z, Z, Z, Z),
Dim8_Vector4_m_0 [1, C_14_23], FM0_ZZZZ);
((Z, Z, Z, Z),
Dim8_Vector4_m_1 [1, C_12_34], FM1_ZZZZ);
((Z, Z, Z, Z),
Dim8_Vector4_m_1 [1, C_13_42], FM1_ZZZZ);
((Z, Z, Z, Z),
Dim8_Vector4_m_1 [1, C_14_23], FM1_ZZZZ);
((Z, Z, Z, Z),
Dim8_Vector4_m_7 [1, C_12_34], FM7_ZZZZ);
((Z, Z, Z, Z),
Dim8_Vector4_m_7 [1, C_13_42], FM7_ZZZZ);
((Z, Z, Z, Z),
Dim8_Vector4_m_7 [1, C_14_23], FM7_ZZZZ);
((Ga, Ga, Ga, Ga),
Dim8_Vector4_t_0 [1, C_12_34], FT0_AAAA);
((Ga, Ga, Ga, Ga),
Dim8_Vector4_t_0 [1, C_13_42], FT0_AAAA);
((Ga, Ga, Ga, Ga),
Dim8_Vector4_t_0 [1, C_14_23], FT0_AAAA);
((Ga, Ga, Ga, Ga),
Dim8_Vector4_t_1 [1, C_12_34], FT1_AAAA);
((Ga, Ga, Ga, Ga),
Dim8_Vector4_t_1 [1, C_13_42], FT1_AAAA);
((Ga, Ga, Ga, Ga),
Dim8_Vector4_t_1 [1, C_14_23], FT1_AAAA);
((Ga, Ga, Ga, Ga),
Dim8_Vector4_t_2 [1, C_12_34], FT2_AAAA);
((Ga, Ga, Ga, Ga),
Dim8_Vector4_t_2 [1, C_13_42], FT2_AAAA);
((Ga, Ga, Ga, Ga),
Dim8_Vector4_t_2 [1, C_14_23], FT2_AAAA);
((Wm, Wp, Ga, Ga),
Dim8_Vector4_t_0 [1, C_12_34], FT0_AAWW0);
((Wm, Wp, Ga, Ga),
Dim8_Vector4_t_0 [1, C_13_42], FT0_AAWW1);
((Wm, Wp, Ga, Ga),
Dim8_Vector4_t_0 [1, C_14_23], FT0_AAWW1);
((Wm, Wp, Ga, Ga),
Dim8_Vector4_t_1 [1, C_12_34], FT1_AAWW0);
((Wm, Wp, Ga, Ga),
Dim8_Vector4_t_1 [1, C_13_42], FT1_AAWW1);
((Wm, Wp, Ga, Ga),
Dim8_Vector4_t_1 [1, C_14_23], FT1_AAWW1);
((Wm, Wp, Ga, Ga),
Dim8_Vector4_t_2 [1, C_12_34], FT2_AAWW0);
((Wm, Wp, Ga, Ga),
Dim8_Vector4_t_2 [1, C_13_42], FT2_AAWW1);
((Wm, Wp, Ga, Ga),
Dim8_Vector4_t_2 [1, C_14_23], FT2_AAWW1);
((Z, Z, Ga, Ga),
Dim8_Vector4_t_0 [1, C_12_34], FT0_AAZZ);
((Z, Z, Ga, Ga),
Dim8_Vector4_t_0 [1, C_13_42], FT0_AAZZ);
((Z, Z, Ga, Ga),
Dim8_Vector4_t_0 [1, C_14_23], FT0_AAZZ);
((Z, Z, Ga, Ga),
Dim8_Vector4_t_1 [1, C_12_34], FT1_AAZZ);
((Z, Z, Ga, Ga),
Dim8_Vector4_t_1 [1, C_13_42], FT1_AAZZ);
((Z, Z, Ga, Ga),
Dim8_Vector4_t_1 [1, C_14_23], FT1_AAZZ);
((Z, Z, Ga, Ga),
Dim8_Vector4_t_2 [1, C_12_34], FT2_AAZZ);
((Z, Z, Ga, Ga),
Dim8_Vector4_t_2 [1, C_13_42], FT2_AAZZ);
((Z, Z, Ga, Ga),
Dim8_Vector4_t_2 [1, C_14_23], FT2_AAZZ);
((Ga, Z, Wp, Wm),
Dim8_Vector4_t_0 [1, C_12_34], FT0_AZWW0);
((Ga, Z, Wp, Wm),
Dim8_Vector4_t_0 [1, C_13_42], FT0_AZWW1);
((Ga, Z, Wp, Wm),
Dim8_Vector4_t_0 [1, C_14_23], FT0_AZWW1);
((Ga, Z, Wp, Wm),
Dim8_Vector4_t_1 [1, C_12_34], FT1_AZWW0);
((Ga, Z, Wp, Wm),
Dim8_Vector4_t_1 [1, C_13_42], FT1_AZWW1);
((Ga, Z, Wp, Wm),
Dim8_Vector4_t_1 [1, C_14_23], FT1_AZWW1);
((Ga, Z, Wp, Wm),
Dim8_Vector4_t_2 [1, C_12_34], FT2_AZWW0);
((Ga, Z, Wp, Wm),
Dim8_Vector4_t_2 [1, C_13_42], FT2_AZWW1);
((Ga, Z, Wp, Wm),
Dim8_Vector4_t_2 [1, C_14_23], FT2_AZWW1);
((Ga, Ga, Ga, Z),
Dim8_Vector4_t_0 [1, C_12_34], FT0_AAAZ);
((Ga, Ga, Ga, Z),
Dim8_Vector4_t_0 [1, C_13_42], FT0_AAAZ);
((Ga, Ga, Ga, Z),
Dim8_Vector4_t_0 [1, C_14_23], FT0_AAAZ);
((Ga, Ga, Ga, Z),
Dim8_Vector4_t_1 [1, C_12_34], FT1_AAAZ);
((Ga, Ga, Ga, Z),
Dim8_Vector4_t_1 [1, C_13_42], FT1_AAAZ);
((Ga, Ga, Ga, Z),
Dim8_Vector4_t_1 [1, C_14_23], FT1_AAAZ);
((Ga, Ga, Ga, Z),
Dim8_Vector4_t_2 [1, C_12_34], FT2_AAAZ);
((Ga, Ga, Ga, Z),
Dim8_Vector4_t_2 [1, C_13_42], FT2_AAAZ);
((Ga, Ga, Ga, Z),
Dim8_Vector4_t_2 [1, C_14_23], FT2_AAAZ);
((Ga, Z, Z, Z),
Dim8_Vector4_t_0 [1, C_12_34], FT0_AZZZ);
((Ga, Z, Z, Z),
Dim8_Vector4_t_0 [1, C_13_42], FT0_AZZZ);
((Ga, Z, Z, Z),
Dim8_Vector4_t_0 [1, C_14_23], FT0_AZZZ);
((Ga, Z, Z, Z),
Dim8_Vector4_t_1 [1, C_12_34], FT1_AZZZ);
((Ga, Z, Z, Z),
Dim8_Vector4_t_1 [1, C_13_42], FT1_AZZZ);
((Ga, Z, Z, Z),
Dim8_Vector4_t_1 [1, C_14_23], FT1_AZZZ);
((Ga, Z, Z, Z),
Dim8_Vector4_t_2 [1, C_12_34], FT2_AZZZ);
((Ga, Z, Z, Z),
Dim8_Vector4_t_2 [1, C_13_42], FT2_AZZZ);
((Ga, Z, Z, Z),
Dim8_Vector4_t_2 [1, C_14_23], FT2_AZZZ)]
else
[] )
else
[]
(* In any diagonal channel~$\chi$, the scattering amplitude~$a_\chi(s)$ is
unitary iff\footnote{%
Trivial proof:
\begin{equation}
-1 = \textrm{Im}\left(\frac{1}{a_\chi(s)}\right)
= \frac{\textrm{Im}(a_\chi^*(s))}{ |a_\chi(s)|^2 }
= - \frac{\textrm{Im}(a_\chi(s))}{ |a_\chi(s)|^2 }
\end{equation}
i.\,e.~$\textrm{Im}(a_\chi(s)) = |a_\chi(s)|^2$.}
\begin{equation}
\textrm{Im}\left(\frac{1}{a_\chi(s)}\right) = -1
\end{equation}
For a real perturbative scattering amplitude~$r_\chi(s)$ this can be
enforced easily--and arbitrarily--by
\begin{equation}
\frac{1}{a_\chi(s)} = \frac{1}{r_\chi(s)} - \mathrm{i}
\end{equation}
*)
let k_matrix_quartic_gauge =
if Flags.k_matrix then
List.map qgc
[ ((Wm, Wp, Wm, Wp), Vector4_K_Matrix_jr (0,
[(1, C_12_34)]), D_Alpha_WWWW0_S);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_jr (0,
[(1, C_14_23)]), D_Alpha_WWWW0_T);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_jr (0,
[(1, C_13_42)]), D_Alpha_WWWW0_U);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_jr (0,
[(1, C_12_34)]), D_Alpha_WWWW0_S);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_jr (0,
[(1, C_14_23)]), D_Alpha_WWWW0_T);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_jr (0,
[(1, C_13_42)]), D_Alpha_WWWW0_U);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_jr (0,
[(1, C_12_34)]), D_Alpha_WWWW2_S);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_jr (0,
[(1, C_13_42); (1, C_14_23)]), D_Alpha_WWWW2_T);
((Wm, Wp, Z, Z), Vector4_K_Matrix_jr (0,
[(1, C_12_34)]), D_Alpha_ZZWW0_S);
((Wm, Wp, Z, Z), Vector4_K_Matrix_jr (0,
[(1, C_13_42); (1, C_14_23)]), D_Alpha_ZZWW0_T);
((Wm, Z, Wp, Z), Vector4_K_Matrix_jr (0,
[(1, C_12_34)]), D_Alpha_ZZWW1_S);
((Wm, Z, Wp, Z), Vector4_K_Matrix_jr (0,
[(1, C_13_42)]), D_Alpha_ZZWW1_T);
((Wm, Z, Wp, Z), Vector4_K_Matrix_jr (0,
[(1, C_14_23)]), D_Alpha_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_jr (1,
[(1, C_12_34)]), D_Alpha_ZZWW1_S);
((Wp, Z, Z, Wm), Vector4_K_Matrix_jr (1,
[(1, C_13_42)]), D_Alpha_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_jr (1,
[(1, C_14_23)]), D_Alpha_ZZWW1_T);
((Z, Wp, Wm, Z), Vector4_K_Matrix_jr (2,
[(1, C_12_34)]), D_Alpha_ZZWW1_S);
((Z, Wp, Wm, Z), Vector4_K_Matrix_jr (2,
[(1, C_13_42)]), D_Alpha_ZZWW1_U);
((Z, Wp, Wm, Z), Vector4_K_Matrix_jr (2,
[(1, C_14_23)]), D_Alpha_ZZWW1_T);
((Z, Z, Z, Z), Vector4_K_Matrix_jr (0,
[(1, C_12_34)]), D_Alpha_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_jr (0,
[(1, C_13_42); (1, C_14_23)]), D_Alpha_ZZZZ_T);
((Z, Z, Z, Z), Vector4_K_Matrix_jr (3,
[(1, C_14_23)]), D_Alpha_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_jr (3,
[(1, C_13_42); (1, C_12_34)]), D_Alpha_ZZZZ_T)]
else
[]
let k_matrix_quartic_gauge_t_0 =
if Flags.k_matrix_tm then
List.map qgc
[ ((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_t0 (0,
[(1, C_12_34)]), D_FT0_WWWW0_S);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_t0 (0,
[(1, C_14_23)]), D_FT0_WWWW0_T);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_t0 (0,
[(1, C_13_42)]), D_FT0_WWWW0_U);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_t0 (0,
[(1, C_12_34)]), D_FT0_WWWW0_S);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_t0 (0,
[(1, C_14_23)]), D_FT0_WWWW0_T);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_t0 (0,
[(1, C_13_42)]), D_FT0_WWWW0_U);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_t0 (0,
[(1, C_12_34)]), D_FT0_WWWW2_S);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_t0 (0,
[(1, C_13_42)]), D_FT0_WWWW2_T);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_t0 (0,
[(1, C_14_23)]), D_FT0_WWWW2_U);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_t0 (0,
[(1, C_12_34)]), D_FT0_ZZWW0_S);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_t0 (0,
[(1, C_13_42)]), D_FT0_ZZWW0_T);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_t0 (0,
[(1, C_14_23)]), D_FT0_ZZWW0_U);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_t0 (0,
[(1, C_12_34)]), D_FT0_ZZWW1_S);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_t0 (0,
[(1, C_13_42)]), D_FT0_ZZWW1_T);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_t0 (0,
[(1, C_14_23)]), D_FT0_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_t0 (1,
[(1, C_12_34)]), D_FT0_ZZWW1_S);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_t0 (1,
[(1, C_13_42)]), D_FT0_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_t0 (1,
[(1, C_14_23)]), D_FT0_ZZWW1_T);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_t0 (2,
[(1, C_12_34)]), D_FT0_ZZWW1_S);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_t0 (2,
[(1, C_13_42)]), D_FT0_ZZWW1_U);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_t0 (2,
[(1, C_14_23)]), D_FT0_ZZWW1_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t0 (0,
[(1, C_12_34)]), D_FT0_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t0 (0,
[(1, C_13_42)]), D_FT0_ZZZZ_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t0 (0,
[(1, C_14_23)]), D_FT0_ZZZZ_U);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t0 (3,
[(1, C_14_23)]), D_FT0_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t0 (3,
[(1, C_13_42)]), D_FT0_ZZZZ_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t0 (3,
[(1, C_12_34)]), D_FT0_ZZZZ_U);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t0 (0,
[(1, C_12_34)]), D_FT0_AAAA_S);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t0 (0,
[(1, C_13_42)]), D_FT0_AAAA_T);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t0 (0,
[(1, C_14_23)]), D_FT0_AAAA_U);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t0 (3,
[(1, C_14_23)]), D_FT0_AAAA_S);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t0 (3,
[(1, C_13_42)]), D_FT0_AAAA_T);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t0 (3,
[(1, C_12_34)]), D_FT0_AAAA_U);
((Wm, Wp, Ga, Ga), Vector4_K_Matrix_cf_t0 (0,
[(1, C_12_34)]), D_FT0_AAWW0_S);
((Wm, Wp, Ga, Ga), Vector4_K_Matrix_cf_t0 (0,
[(1, C_13_42)]), D_FT0_AAWW0_T);
((Wm, Wp, Ga, Ga), Vector4_K_Matrix_cf_t0 (0,
[(1, C_14_23)]), D_FT0_AAWW0_U);
((Wm, Ga, Wp, Ga), Vector4_K_Matrix_cf_t0 (0,
[(1, C_12_34)]), D_FT0_AAWW1_S);
((Wm, Ga, Wp, Ga), Vector4_K_Matrix_cf_t0 (0,
[(1, C_13_42)]), D_FT0_AAWW1_T);
((Wm, Ga, Wp, Ga), Vector4_K_Matrix_cf_t0 (0,
[(1, C_14_23)]), D_FT0_AAWW1_U);
((Wp, Ga, Ga, Wm), Vector4_K_Matrix_cf_t0 (1,
[(1, C_12_34)]), D_FT0_AAWW1_S);
((Wp, Ga, Ga, Wm), Vector4_K_Matrix_cf_t0 (1,
[(1, C_13_42)]), D_FT0_AAWW1_U);
((Wp, Ga, Ga, Wm), Vector4_K_Matrix_cf_t0 (1,
[(1, C_14_23)]), D_FT0_AAWW1_T);
((Ga, Wp, Wm, Ga), Vector4_K_Matrix_cf_t0 (2,
[(1, C_12_34)]), D_FT0_AAWW1_S);
((Ga, Wp, Wm, Ga), Vector4_K_Matrix_cf_t0 (2,
[(1, C_13_42)]), D_FT0_AAWW1_U);
((Ga, Wp, Wm, Ga), Vector4_K_Matrix_cf_t0 (2,
[(1, C_14_23)]), D_FT0_AAWW1_T);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t0 (0,
[(1, C_12_34)]), D_FT0_AAZZ_S);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t0 (0,
[(1, C_13_42)]), D_FT0_AAZZ_T);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t0 (0,
[(1, C_14_23)]), D_FT0_AAZZ_U);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t0 (3,
[(1, C_14_23)]), D_FT0_AAZZ_S);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t0 (3,
[(1, C_13_42)]), D_FT0_AAZZ_T);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t0 (3,
[(1, C_12_34)]), D_FT0_AAZZ_U);
((Ga, Z, Wp, Wm), Vector4_K_Matrix_cf_t0 (0,
[(1, C_12_34)]), D_FT0_AZWW0_S);
((Ga, Z, Wp, Wm), Vector4_K_Matrix_cf_t0 (0,
[(1, C_13_42)]), D_FT0_AZWW0_T);
((Ga, Z, Wp, Wm), Vector4_K_Matrix_cf_t0 (0,
[(1, C_14_23)]), D_FT0_AZWW0_U);
((Wp, Ga, Wm, Z), Vector4_K_Matrix_cf_t0 (1,
[(1, C_12_34)]), D_FT0_AZWW1_S);
((Wp, Ga, Wm, Z), Vector4_K_Matrix_cf_t0 (1,
[(1, C_13_42)]), D_FT0_AZWW1_T);
((Wp, Ga, Wm, Z), Vector4_K_Matrix_cf_t0 (1,
[(1, C_14_23)]), D_FT0_AZWW1_U);
((Wm, Ga, Wp, Z), Vector4_K_Matrix_cf_t0 (1,
[(1, C_12_34)]), D_FT0_AZWW1_S);
((Wm, Ga, Wp, Z), Vector4_K_Matrix_cf_t0 (1,
[(1, C_13_42)]), D_FT0_AZWW1_T);
((Wm, Ga, Wp, Z), Vector4_K_Matrix_cf_t0 (1,
[(1, C_14_23)]), D_FT0_AZWW1_U);
((Z, Wm, Ga, Wp), Vector4_K_Matrix_cf_t0 (1,
[(1, C_12_34)]), D_FT0_AZWW1_S);
((Z, Wm, Ga, Wp), Vector4_K_Matrix_cf_t0 (1,
[(1, C_13_42)]), D_FT0_AZWW1_T);
((Z, Wm, Ga, Wp), Vector4_K_Matrix_cf_t0 (1,
[(1, C_14_23)]), D_FT0_AZWW1_U);
((Wp, Z, Wm, Ga), Vector4_K_Matrix_cf_t0 (1,
[(1, C_12_34)]), D_FT0_AZWW1_S);
((Wp, Z, Wm, Ga), Vector4_K_Matrix_cf_t0 (1,
[(1, C_13_42)]), D_FT0_AZWW1_T);
((Wp, Z, Wm, Ga), Vector4_K_Matrix_cf_t0 (1,
[(1, C_14_23)]), D_FT0_AZWW1_U);
((Ga, Ga, Ga, Z), Vector4_K_Matrix_cf_t0 (3,
[(1, C_12_34)]), D_FT0_AAAZ_S);
((Ga, Ga, Ga, Z), Vector4_K_Matrix_cf_t0 (3,
[(1, C_13_42)]), D_FT0_AAAZ_T);
((Ga, Ga, Ga, Z), Vector4_K_Matrix_cf_t0 (3,
[(1, C_14_23)]), D_FT0_AAAZ_U);
((Z, Ga, Ga, Ga), Vector4_K_Matrix_cf_t0 (3,
[(1, C_12_34)]), D_FT0_AAAZ_S);
((Z, Ga, Ga, Ga), Vector4_K_Matrix_cf_t0 (3,
[(1, C_13_42)]), D_FT0_AAAZ_T);
((Z, Ga, Ga, Ga), Vector4_K_Matrix_cf_t0 (3,
[(1, C_14_23)]), D_FT0_AAAZ_U);
((Ga, Ga, Z, Ga), Vector4_K_Matrix_cf_t0 (3,
[(1, C_12_34)]), D_FT0_AAAZ_S);
((Ga, Ga, Z, Ga), Vector4_K_Matrix_cf_t0 (3,
[(1, C_13_42)]), D_FT0_AAAZ_T);
((Ga, Ga, Z, Ga), Vector4_K_Matrix_cf_t0 (3,
[(1, C_14_23)]), D_FT0_AAAZ_U);
((Z, Z, Z, Ga), Vector4_K_Matrix_cf_t0 (3,
[(1, C_12_34)]), D_FT0_AZZZ_S);
((Z, Z, Z, Ga), Vector4_K_Matrix_cf_t0 (3,
[(1, C_13_42)]), D_FT0_AZZZ_T);
((Z, Z, Z, Ga), Vector4_K_Matrix_cf_t0 (3,
[(1, C_14_23)]), D_FT0_AZZZ_U);
((Ga, Z, Z, Z), Vector4_K_Matrix_cf_t0 (3,
[(1, C_12_34)]), D_FT0_AZZZ_S);
((Ga, Z, Z, Z), Vector4_K_Matrix_cf_t0 (3,
[(1, C_13_42)]), D_FT0_AZZZ_T);
((Ga, Z, Z, Z), Vector4_K_Matrix_cf_t0 (3,
[(1, C_14_23)]), D_FT0_AZZZ_U);
((Z, Z, Ga, Z), Vector4_K_Matrix_cf_t0 (3,
[(1, C_12_34)]), D_FT0_AZZZ_S);
((Z, Z, Ga, Z), Vector4_K_Matrix_cf_t0 (3,
[(1, C_13_42)]), D_FT0_AZZZ_T);
((Z, Z, Ga, Z), Vector4_K_Matrix_cf_t0 (3,
[(1, C_14_23)]), D_FT0_AZZZ_U)]
else
[]
let k_matrix_quartic_gauge_t_1 =
if Flags.k_matrix_tm then
List.map qgc
[ ((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_t1 (0,
[(1, C_12_34)]), D_FT1_WWWW0_S);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_t1 (0,
[(1, C_14_23)]), D_FT1_WWWW0_T);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_t1 (0,
[(1, C_13_42)]), D_FT1_WWWW0_U);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_t1 (0,
[(1, C_12_34)]), D_FT1_WWWW0_S);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_t1 (0,
[(1, C_14_23)]), D_FT1_WWWW0_T);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_t1 (0,
[(1, C_13_42)]), D_FT1_WWWW0_U);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_t1 (0,
[(1, C_12_34)]), D_FT1_WWWW2_S);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_t1 (0,
[(1, C_13_42)]), D_FT1_WWWW2_T);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_t1 (0,
[(1, C_14_23)]), D_FT1_WWWW2_U);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_t1 (0,
[(1, C_12_34)]), D_FT1_ZZWW0_S);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_t1 (0,
[(1, C_13_42)]), D_FT1_ZZWW0_T);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_t1 (0,
[(1, C_14_23)]), D_FT1_ZZWW0_U);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_t1 (0,
[(1, C_12_34)]), D_FT1_ZZWW1_S);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_t1 (0,
[(1, C_13_42)]), D_FT1_ZZWW1_T);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_t1 (0,
[(1, C_14_23)]), D_FT1_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_t1 (1,
[(1, C_12_34)]), D_FT1_ZZWW1_S);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_t1 (1,
[(1, C_13_42)]), D_FT1_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_t1 (1,
[(1, C_14_23)]), D_FT1_ZZWW1_T);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_t1 (2,
[(1, C_12_34)]), D_FT1_ZZWW1_S);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_t1 (2,
[(1, C_13_42)]), D_FT1_ZZWW1_U);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_t1 (2,
[(1, C_14_23)]), D_FT1_ZZWW1_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t1 (0,
[(1, C_12_34)]), D_FT1_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t1 (0,
[(1, C_13_42)]), D_FT1_ZZZZ_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t1 (0,
[(1, C_14_23)]), D_FT1_ZZZZ_U);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t1 (3,
[(1, C_14_23)]), D_FT1_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t1 (3,
[(1, C_13_42)]), D_FT1_ZZZZ_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t1 (3,
[(1, C_12_34)]), D_FT1_ZZZZ_U);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t1(0,
[(1, C_12_34)]), D_FT1_AAAA_S);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t1 (0,
[(1, C_13_42)]), D_FT1_AAAA_T);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t1 (0,
[(1, C_14_23)]), D_FT1_AAAA_U);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t1 (3,
[(1, C_14_23)]), D_FT1_AAAA_S);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t1 (3,
[(1, C_13_42)]), D_FT1_AAAA_T);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t1 (3,
[(1, C_12_34)]), D_FT1_AAAA_U);
((Wm, Wp, Ga, Ga), Vector4_K_Matrix_cf_t1 (0,
[(1, C_12_34)]), D_FT1_AAWW0_S);
((Wm, Wp, Ga, Ga), Vector4_K_Matrix_cf_t1 (0,
[(1, C_13_42)]), D_FT1_AAWW0_T);
((Wm, Wp, Ga, Ga), Vector4_K_Matrix_cf_t1 (0,
[(1, C_14_23)]), D_FT1_AAWW0_U);
((Wm, Ga, Wp, Ga), Vector4_K_Matrix_cf_t1 (0,
[(1, C_12_34)]), D_FT1_AAWW1_S);
((Wm, Ga, Wp, Ga), Vector4_K_Matrix_cf_t1 (0,
[(1, C_13_42)]), D_FT1_AAWW1_T);
((Wm, Ga, Wp, Ga), Vector4_K_Matrix_cf_t1 (0,
[(1, C_14_23)]), D_FT1_AAWW1_U);
((Wp, Ga, Ga, Wm), Vector4_K_Matrix_cf_t1 (1,
[(1, C_12_34)]), D_FT1_AAWW1_S);
((Wp, Ga, Ga, Wm), Vector4_K_Matrix_cf_t1 (1,
[(1, C_13_42)]), D_FT1_AAWW1_U);
((Wp, Ga, Ga, Wm), Vector4_K_Matrix_cf_t1 (1,
[(1, C_14_23)]), D_FT1_AAWW1_T);
((Ga, Wp, Wm, Ga), Vector4_K_Matrix_cf_t1 (2,
[(1, C_12_34)]), D_FT1_AAWW1_S);
((Ga, Wp, Wm, Ga), Vector4_K_Matrix_cf_t1 (2,
[(1, C_13_42)]), D_FT1_AAWW1_U);
((Ga, Wp, Wm, Ga), Vector4_K_Matrix_cf_t1 (2,
[(1, C_14_23)]), D_FT1_AAWW1_T);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t1 (0,
[(1, C_12_34)]), D_FT1_AAZZ_S);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t1 (0,
[(1, C_13_42)]), D_FT1_AAZZ_T);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t1 (0,
[(1, C_14_23)]), D_FT1_AAZZ_U);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t1 (3,
[(1, C_14_23)]), D_FT1_AAZZ_S);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t1 (3,
[(1, C_13_42)]), D_FT1_AAZZ_T);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t1 (3,
[(1, C_12_34)]), D_FT1_AAZZ_U);
((Ga, Z, Wp, Wm), Vector4_K_Matrix_cf_t1 (0,
[(1, C_12_34)]), D_FT1_AZWW0_S);
((Ga, Z, Wp, Wm), Vector4_K_Matrix_cf_t1 (0,
[(1, C_13_42)]), D_FT1_AZWW0_T);
((Ga, Z, Wp, Wm), Vector4_K_Matrix_cf_t1 (0,
[(1, C_14_23)]), D_FT1_AZWW0_U);
((Wp, Ga, Wm, Z), Vector4_K_Matrix_cf_t1 (1,
[(1, C_12_34)]), D_FT1_AZWW1_S);
((Wp, Ga, Wm, Z), Vector4_K_Matrix_cf_t1 (1,
[(1, C_13_42)]), D_FT1_AZWW1_T);
((Wp, Ga, Wm, Z), Vector4_K_Matrix_cf_t1 (1,
[(1, C_14_23)]), D_FT1_AZWW1_U);
((Wm, Ga, Wp, Z), Vector4_K_Matrix_cf_t1 (1,
[(1, C_12_34)]), D_FT1_AZWW1_S);
((Wm, Ga, Wp, Z), Vector4_K_Matrix_cf_t1 (1,
[(1, C_13_42)]), D_FT1_AZWW1_T);
((Wm, Ga, Wp, Z), Vector4_K_Matrix_cf_t1 (1,
[(1, C_14_23)]), D_FT1_AZWW1_U);
((Z, Wm, Ga, Wp), Vector4_K_Matrix_cf_t1 (1,
[(1, C_12_34)]), D_FT1_AZWW1_S);
((Z, Wm, Ga, Wp), Vector4_K_Matrix_cf_t1 (1,
[(1, C_13_42)]), D_FT1_AZWW1_T);
((Z, Wm, Ga, Wp), Vector4_K_Matrix_cf_t1 (1,
[(1, C_14_23)]), D_FT1_AZWW1_U);
((Wp, Z, Wm, Ga), Vector4_K_Matrix_cf_t1 (1,
[(1, C_12_34)]), D_FT1_AZWW1_S);
((Wp, Z, Wm, Ga), Vector4_K_Matrix_cf_t1 (1,
[(1, C_13_42)]), D_FT1_AZWW1_T);
((Wp, Z, Wm, Ga), Vector4_K_Matrix_cf_t1 (1,
[(1, C_14_23)]), D_FT1_AZWW1_U);
((Ga, Ga, Ga, Z), Vector4_K_Matrix_cf_t1 (3,
[(1, C_12_34)]), D_FT1_AAAZ_S);
((Ga, Ga, Ga, Z), Vector4_K_Matrix_cf_t1 (3,
[(1, C_13_42)]), D_FT1_AAAZ_T);
((Ga, Ga, Ga, Z), Vector4_K_Matrix_cf_t1 (3,
[(1, C_14_23)]), D_FT1_AAAZ_U);
((Z, Ga, Ga, Ga), Vector4_K_Matrix_cf_t1 (3,
[(1, C_12_34)]), D_FT1_AAAZ_S);
((Z, Ga, Ga, Ga), Vector4_K_Matrix_cf_t1 (3,
[(1, C_13_42)]), D_FT1_AAAZ_T);
((Z, Ga, Ga, Ga), Vector4_K_Matrix_cf_t1 (3,
[(1, C_14_23)]), D_FT1_AAAZ_U);
((Ga, Ga, Z, Ga), Vector4_K_Matrix_cf_t1 (3,
[(1, C_12_34)]), D_FT1_AAAZ_S);
((Ga, Ga, Z, Ga), Vector4_K_Matrix_cf_t1 (3,
[(1, C_13_42)]), D_FT1_AAAZ_T);
((Ga, Ga, Z, Ga), Vector4_K_Matrix_cf_t1 (3,
[(1, C_14_23)]), D_FT1_AAAZ_U);
((Z, Z, Z, Ga), Vector4_K_Matrix_cf_t1 (3,
[(1, C_12_34)]), D_FT1_AZZZ_S);
((Z, Z, Z, Ga), Vector4_K_Matrix_cf_t1 (3,
[(1, C_13_42)]), D_FT1_AZZZ_T);
((Z, Z, Z, Ga), Vector4_K_Matrix_cf_t1 (3,
[(1, C_14_23)]), D_FT1_AZZZ_U);
((Ga, Z, Z, Z), Vector4_K_Matrix_cf_t1 (3,
[(1, C_12_34)]), D_FT1_AZZZ_S);
((Ga, Z, Z, Z), Vector4_K_Matrix_cf_t1 (3,
[(1, C_13_42)]), D_FT1_AZZZ_T);
((Ga, Z, Z, Z), Vector4_K_Matrix_cf_t1 (3,
[(1, C_14_23)]), D_FT1_AZZZ_U);
((Z, Z, Ga, Z), Vector4_K_Matrix_cf_t1 (3,
[(1, C_12_34)]), D_FT1_AZZZ_S);
((Z, Z, Ga, Z), Vector4_K_Matrix_cf_t1 (3,
[(1, C_13_42)]), D_FT1_AZZZ_T);
((Z, Z, Ga, Z), Vector4_K_Matrix_cf_t1 (3,
[(1, C_14_23)]), D_FT1_AZZZ_U)]
else
[]
let k_matrix_quartic_gauge_t_2 =
if Flags.k_matrix_tm then
List.map qgc
[ ((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_t2 (0,
[(1, C_12_34)]), D_FT2_WWWW0_S);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_t2 (0,
[(1, C_14_23)]), D_FT2_WWWW0_T);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_t2 (0,
[(1, C_13_42)]), D_FT2_WWWW0_U);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_t2 (0,
[(1, C_12_34)]), D_FT2_WWWW0_S);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_t2 (0,
[(1, C_14_23)]), D_FT2_WWWW0_T);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_t2 (0,
[(1, C_13_42)]), D_FT2_WWWW0_U);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_t2 (0,
[(1, C_12_34)]), D_FT2_WWWW2_S);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_t2 (0,
[(1, C_13_42)]), D_FT2_WWWW2_T);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_t2 (0,
[(1, C_14_23)]), D_FT2_WWWW2_U);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_t2 (0,
[(1, C_12_34)]), D_FT2_ZZWW0_S);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_t2 (0,
[(1, C_13_42)]), D_FT2_ZZWW0_T);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_t2 (0,
[(1, C_14_23)]), D_FT2_ZZWW0_U);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_t2 (0,
[(1, C_12_34)]), D_FT2_ZZWW1_S);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_t2 (0,
[(1, C_13_42)]), D_FT2_ZZWW1_T);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_t2 (0,
[(1, C_14_23)]), D_FT2_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_t2 (1,
[(1, C_12_34)]), D_FT2_ZZWW1_S);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_t2 (1,
[(1, C_13_42)]), D_FT2_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_t2 (1,
[(1, C_14_23)]), D_FT2_ZZWW1_T);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_t2 (2,
[(1, C_12_34)]), D_FT2_ZZWW1_S);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_t2 (2,
[(1, C_13_42)]), D_FT2_ZZWW1_U);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_t2 (2,
[(1, C_14_23)]), D_FT2_ZZWW1_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t2 (0,
[(1, C_12_34)]), D_FT2_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t2 (0,
[(1, C_13_42)]), D_FT2_ZZZZ_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t2 (0,
[(1, C_14_23)]), D_FT2_ZZZZ_U);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t2 (3,
[(1, C_14_23)]), D_FT2_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t2 (3,
[(1, C_13_42)]), D_FT2_ZZZZ_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t2 (3,
[(1, C_12_34)]), D_FT2_ZZZZ_U);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t2 (0,
[(1, C_12_34)]), D_FT2_AAAA_S);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t2 (0,
[(1, C_13_42)]), D_FT2_AAAA_T);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t2 (0,
[(1, C_14_23)]), D_FT2_AAAA_U);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t2 (3,
[(1, C_14_23)]), D_FT2_AAAA_S);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t2 (3,
[(1, C_13_42)]), D_FT2_AAAA_T);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t2 (3,
[(1, C_12_34)]), D_FT2_AAAA_U);
((Wm, Wp, Ga, Ga), Vector4_K_Matrix_cf_t2 (0,
[(1, C_12_34)]), D_FT2_AAWW0_S);
((Wm, Wp, Ga, Ga), Vector4_K_Matrix_cf_t2 (0,
[(1, C_13_42)]), D_FT2_AAWW0_T);
((Wm, Wp, Ga, Ga), Vector4_K_Matrix_cf_t2 (0,
[(1, C_14_23)]), D_FT2_AAWW0_U);
((Wm, Ga, Wp, Ga), Vector4_K_Matrix_cf_t2 (0,
[(1, C_12_34)]), D_FT2_AAWW1_S);
((Wm, Ga, Wp, Ga), Vector4_K_Matrix_cf_t2 (0,
[(1, C_13_42)]), D_FT2_AAWW1_T);
((Wm, Ga, Wp, Ga), Vector4_K_Matrix_cf_t2 (0,
[(1, C_14_23)]), D_FT2_AAWW1_U);
((Wp, Ga, Ga, Wm), Vector4_K_Matrix_cf_t2 (1,
[(1, C_12_34)]), D_FT2_AAWW1_S);
((Wp, Ga, Ga, Wm), Vector4_K_Matrix_cf_t2 (1,
[(1, C_13_42)]), D_FT2_AAWW1_U);
((Wp, Ga, Ga, Wm), Vector4_K_Matrix_cf_t2 (1,
[(1, C_14_23)]), D_FT2_AAWW1_T);
((Ga, Wp, Wm, Ga), Vector4_K_Matrix_cf_t2 (2,
[(1, C_12_34)]), D_FT2_AAWW1_S);
((Ga, Wp, Wm, Ga), Vector4_K_Matrix_cf_t2 (2,
[(1, C_13_42)]), D_FT2_AAWW1_U);
((Ga, Wp, Wm, Ga), Vector4_K_Matrix_cf_t2 (2,
[(1, C_14_23)]), D_FT2_AAWW1_T);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t2 (0,
[(1, C_12_34)]), D_FT2_AAZZ_S);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t2 (0,
[(1, C_13_42)]), D_FT2_AAZZ_T);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t2 (0,
[(1, C_14_23)]), D_FT2_AAZZ_U);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t2 (3,
[(1, C_14_23)]), D_FT2_AAZZ_S);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t2 (3,
[(1, C_13_42)]), D_FT2_AAZZ_T);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t2 (3,
[(1, C_12_34)]), D_FT2_AAZZ_U);
((Ga, Z, Wp, Wm), Vector4_K_Matrix_cf_t2 (0,
[(1, C_12_34)]), D_FT2_AZWW0_S);
((Ga, Z, Wp, Wm), Vector4_K_Matrix_cf_t2 (0,
[(1, C_13_42)]), D_FT2_AZWW0_T);
((Ga, Z, Wp, Wm), Vector4_K_Matrix_cf_t2 (0,
[(1, C_14_23)]), D_FT2_AZWW0_U);
((Wp, Ga, Wm, Z), Vector4_K_Matrix_cf_t2 (1,
[(1, C_12_34)]), D_FT2_AZWW1_S);
((Wp, Ga, Wm, Z), Vector4_K_Matrix_cf_t2 (1,
[(1, C_13_42)]), D_FT2_AZWW1_T);
((Wp, Ga, Wm, Z), Vector4_K_Matrix_cf_t2 (1,
[(1, C_14_23)]), D_FT2_AZWW1_U);
((Wm, Ga, Wp, Z), Vector4_K_Matrix_cf_t2 (1,
[(1, C_12_34)]), D_FT2_AZWW1_S);
((Wm, Ga, Wp, Z), Vector4_K_Matrix_cf_t2 (1,
[(1, C_13_42)]), D_FT2_AZWW1_T);
((Wm, Ga, Wp, Z), Vector4_K_Matrix_cf_t2 (1,
[(1, C_14_23)]), D_FT2_AZWW1_U);
((Z, Wm, Ga, Wp), Vector4_K_Matrix_cf_t2 (1,
[(1, C_12_34)]), D_FT2_AZWW1_S);
((Z, Wm, Ga, Wp), Vector4_K_Matrix_cf_t2 (1,
[(1, C_13_42)]), D_FT2_AZWW1_T);
((Z, Wm, Ga, Wp), Vector4_K_Matrix_cf_t2 (1,
[(1, C_14_23)]), D_FT2_AZWW1_U);
((Wp, Z, Wm, Ga), Vector4_K_Matrix_cf_t2 (1,
[(1, C_12_34)]), D_FT2_AZWW1_S);
((Wp, Z, Wm, Ga), Vector4_K_Matrix_cf_t2 (1,
[(1, C_13_42)]), D_FT2_AZWW1_T);
((Wp, Z, Wm, Ga), Vector4_K_Matrix_cf_t2 (1,
[(1, C_14_23)]), D_FT2_AZWW1_U);
((Ga, Ga, Ga, Z), Vector4_K_Matrix_cf_t2 (3,
[(1, C_12_34)]), D_FT2_AAAZ_S);
((Ga, Ga, Ga, Z), Vector4_K_Matrix_cf_t2 (3,
[(1, C_13_42)]), D_FT2_AAAZ_T);
((Ga, Ga, Ga, Z), Vector4_K_Matrix_cf_t2 (3,
[(1, C_14_23)]), D_FT2_AAAZ_U);
((Z, Ga, Ga, Ga), Vector4_K_Matrix_cf_t2 (3,
[(1, C_12_34)]), D_FT2_AAAZ_S);
((Z, Ga, Ga, Ga), Vector4_K_Matrix_cf_t2 (3,
[(1, C_13_42)]), D_FT2_AAAZ_T);
((Z, Ga, Ga, Ga), Vector4_K_Matrix_cf_t2 (3,
[(1, C_14_23)]), D_FT2_AAAZ_U);
((Ga, Ga, Z, Ga), Vector4_K_Matrix_cf_t2 (3,
[(1, C_12_34)]), D_FT2_AAAZ_S);
((Ga, Ga, Z, Ga), Vector4_K_Matrix_cf_t2 (3,
[(1, C_13_42)]), D_FT2_AAAZ_T);
((Ga, Ga, Z, Ga), Vector4_K_Matrix_cf_t2 (3,
[(1, C_14_23)]), D_FT2_AAAZ_U);
((Z, Z, Z, Ga), Vector4_K_Matrix_cf_t2 (3,
[(1, C_12_34)]), D_FT2_AZZZ_S);
((Z, Z, Z, Ga), Vector4_K_Matrix_cf_t2 (3,
[(1, C_13_42)]), D_FT2_AZZZ_T);
((Z, Z, Z, Ga), Vector4_K_Matrix_cf_t2 (3,
[(1, C_14_23)]), D_FT2_AZZZ_U);
((Ga, Z, Z, Z), Vector4_K_Matrix_cf_t2 (3,
[(1, C_12_34)]), D_FT2_AZZZ_S);
((Ga, Z, Z, Z), Vector4_K_Matrix_cf_t2 (3,
[(1, C_13_42)]), D_FT2_AZZZ_T);
((Ga, Z, Z, Z), Vector4_K_Matrix_cf_t2 (3,
[(1, C_14_23)]), D_FT2_AZZZ_U);
((Z, Z, Ga, Z), Vector4_K_Matrix_cf_t2 (3,
[(1, C_12_34)]), D_FT2_AZZZ_S);
((Z, Z, Ga, Z), Vector4_K_Matrix_cf_t2 (3,
[(1, C_13_42)]), D_FT2_AZZZ_T);
((Z, Z, Ga, Z), Vector4_K_Matrix_cf_t2 (3,
[(1, C_14_23)]), D_FT2_AZZZ_U)]
else
[]
let k_matrix_quartic_gauge_t_rsi =
if Flags.k_matrix_tm then
List.map qgc
[ ((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_12_34)]), D_FTrsi_WWWW0_S);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_14_23)]), D_FTrsi_WWWW0_T);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_13_42)]), D_FTrsi_WWWW0_U);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_12_34)]), D_FTrsi_WWWW0_S);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_14_23)]), D_FTrsi_WWWW0_T);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_13_42)]), D_FTrsi_WWWW0_U);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_12_34)]), D_FTrsi_WWWW2_S);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_13_42)]), D_FTrsi_WWWW2_T);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_14_23)]), D_FTrsi_WWWW2_U);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_12_34)]), D_FTrsi_ZZWW0_S);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_13_42)]), D_FTrsi_ZZWW0_T);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_14_23)]), D_FTrsi_ZZWW0_U);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_12_34)]), D_FTrsi_ZZWW1_S);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_13_42)]), D_FTrsi_ZZWW1_T);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_14_23)]), D_FTrsi_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_12_34)]), D_FTrsi_ZZWW1_S);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_13_42)]), D_FTrsi_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_14_23)]), D_FTrsi_ZZWW1_T);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_t_rsi (2,
[(1, C_12_34)]), D_FTrsi_ZZWW1_S);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_t_rsi (2,
[(1, C_13_42)]), D_FTrsi_ZZWW1_U);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_t_rsi (2,
[(1, C_14_23)]), D_FTrsi_ZZWW1_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_12_34)]), D_FTrsi_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_13_42)]), D_FTrsi_ZZZZ_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_14_23)]), D_FTrsi_ZZZZ_U);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_14_23)]), D_FTrsi_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_13_42)]), D_FTrsi_ZZZZ_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_12_34)]), D_FTrsi_ZZZZ_U);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_12_34)]), D_FTrsi_AAAA_S);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_13_42)]), D_FTrsi_AAAA_T);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_14_23)]), D_FTrsi_AAAA_U);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_14_23)]), D_FTrsi_AAAA_S);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_13_42)]), D_FTrsi_AAAA_T);
((Ga, Ga, Ga, Ga), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_12_34)]), D_FTrsi_AAAA_U);
((Wm, Wp, Ga, Ga), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_12_34)]), D_FTrsi_AAWW0_S);
((Wm, Wp, Ga, Ga), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_13_42)]), D_FTrsi_AAWW0_T);
((Wm, Wp, Ga, Ga), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_14_23)]), D_FTrsi_AAWW0_U);
((Wm, Ga, Wp, Ga), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_12_34)]), D_FTrsi_AAWW1_S);
((Wm, Ga, Wp, Ga), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_13_42)]), D_FTrsi_AAWW1_T);
((Wm, Ga, Wp, Ga), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_14_23)]), D_FTrsi_AAWW1_U);
((Wp, Ga, Ga, Wm), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_12_34)]), D_FTrsi_AAWW1_S);
((Wp, Ga, Ga, Wm), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_13_42)]), D_FTrsi_AAWW1_U);
((Wp, Ga, Ga, Wm), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_14_23)]), D_FTrsi_AAWW1_T);
((Ga, Wp, Wm, Ga), Vector4_K_Matrix_cf_t_rsi (2,
[(1, C_12_34)]), D_FTrsi_AAWW1_S);
((Ga, Wp, Wm, Ga), Vector4_K_Matrix_cf_t_rsi (2,
[(1, C_13_42)]), D_FTrsi_AAWW1_U);
((Ga, Wp, Wm, Ga), Vector4_K_Matrix_cf_t_rsi (2,
[(1, C_14_23)]), D_FTrsi_AAWW1_T);
((Ga, Z, Ga, Z), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_12_34)]), D_FTrsi_AAZZ_S);
((Ga, Z, Ga, Z), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_14_23)]), D_FTrsi_AAZZ_T);
((Ga, Z, Ga, Z), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_13_42)]), D_FTrsi_AAZZ_U);
((Z, Ga, Z, Ga), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_12_34)]), D_FTrsi_AAZZ_S);
((Z, Ga, Z, Ga), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_14_23)]), D_FTrsi_AAZZ_T);
((Z, Ga, Z, Ga), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_13_42)]), D_FTrsi_AAZZ_U);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_12_34)]), D_FTrsi_AAZZ_S);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_13_42)]), D_FTrsi_AAZZ_T);
((Ga, Ga, Z, Z), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_14_23)]), D_FTrsi_AAZZ_U);
((Ga, Z, Wp, Wm), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_12_34)]), D_FTrsi_AZWW0_S);
((Ga, Z, Wp, Wm), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_13_42)]), D_FTrsi_AZWW0_T);
((Ga, Z, Wp, Wm), Vector4_K_Matrix_cf_t_rsi (0,
[(1, C_14_23)]), D_FTrsi_AZWW0_U);
((Wp, Ga, Wm, Z), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_12_34)]), D_FTrsi_AZWW1_S);
((Wp, Ga, Wm, Z), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_13_42)]), D_FTrsi_AZWW1_T);
((Wp, Ga, Wm, Z), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_14_23)]), D_FTrsi_AZWW1_U);
((Wm, Ga, Wp, Z), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_12_34)]), D_FTrsi_AZWW1_S);
((Wm, Ga, Wp, Z), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_13_42)]), D_FTrsi_AZWW1_T);
((Wm, Ga, Wp, Z), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_14_23)]), D_FTrsi_AZWW1_U);
((Z, Wm, Ga, Wp), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_12_34)]), D_FTrsi_AZWW1_S);
((Z, Wm, Ga, Wp), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_13_42)]), D_FTrsi_AZWW1_T);
((Z, Wm, Ga, Wp), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_14_23)]), D_FTrsi_AZWW1_U);
((Wp, Z, Wm, Ga), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_12_34)]), D_FTrsi_AZWW1_S);
((Wp, Z, Wm, Ga), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_13_42)]), D_FTrsi_AZWW1_T);
((Wp, Z, Wm, Ga), Vector4_K_Matrix_cf_t_rsi (1,
[(1, C_14_23)]), D_FTrsi_AZWW1_U);
((Ga, Ga, Ga, Z), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_12_34)]), D_FTrsi_AAAZ_S);
((Ga, Ga, Ga, Z), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_13_42)]), D_FTrsi_AAAZ_T);
((Ga, Ga, Ga, Z), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_14_23)]), D_FTrsi_AAAZ_U);
((Z, Ga, Ga, Ga), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_12_34)]), D_FTrsi_AAAZ_S);
((Z, Ga, Ga, Ga), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_13_42)]), D_FTrsi_AAAZ_T);
((Z, Ga, Ga, Ga), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_14_23)]), D_FTrsi_AAAZ_U);
((Ga, Ga, Z, Ga), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_12_34)]), D_FTrsi_AAAZ_S);
((Ga, Ga, Z, Ga), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_13_42)]), D_FTrsi_AAAZ_T);
((Ga, Ga, Z, Ga), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_14_23)]), D_FTrsi_AAAZ_U);
((Z, Z, Z, Ga), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_12_34)]), D_FTrsi_AZZZ_S);
((Z, Z, Z, Ga), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_13_42)]), D_FTrsi_AZZZ_T);
((Z, Z, Z, Ga), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_14_23)]), D_FTrsi_AZZZ_U);
((Ga, Z, Z, Z), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_12_34)]), D_FTrsi_AZZZ_S);
((Ga, Z, Z, Z), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_13_42)]), D_FTrsi_AZZZ_T);
((Ga, Z, Z, Z), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_14_23)]), D_FTrsi_AZZZ_U);
((Z, Z, Ga, Z), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_12_34)]), D_FTrsi_AZZZ_S);
((Z, Z, Ga, Z), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_13_42)]), D_FTrsi_AZZZ_T);
((Z, Z, Ga, Z), Vector4_K_Matrix_cf_t_rsi (3,
[(1, C_14_23)]), D_FTrsi_AZZZ_U)]
else
[]
let k_matrix_quartic_gauge_m_0 =
if Flags.k_matrix_tm then
List.map qgc
[ ((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_m0 (0,
[(1, C_12_34)]), D_FM0_WWWW0_S);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_m0 (0,
[(1, C_14_23)]), D_FM0_WWWW0_T);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_m0 (0,
[(1, C_13_42)]), D_FM0_WWWW0_U);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_m0 (0,
[(1, C_12_34)]), D_FM0_WWWW0_S);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_m0 (0,
[(1, C_14_23)]), D_FM0_WWWW0_T);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_m0 (0,
[(1, C_13_42)]), D_FM0_WWWW0_U);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_m0 (0,
[(1, C_12_34)]), D_FM0_WWWW2_S);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_m0 (0,
[(1, C_13_42)]), D_FM0_WWWW2_T);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_m0 (0,
[(1, C_14_23)]), D_FM0_WWWW2_U);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_m0 (0,
[(1, C_12_34)]), D_FM0_ZZWW0_S);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_m0 (0,
[(1, C_13_42)]), D_FM0_ZZWW0_T);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_m0 (0,
[(1, C_14_23)]), D_FM0_ZZWW0_U);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_m0 (0,
[(1, C_12_34)]), D_FM0_ZZWW1_S);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_m0 (0,
[(1, C_13_42)]), D_FM0_ZZWW1_T);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_m0 (0,
[(1, C_14_23)]), D_FM0_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_m0 (1,
[(1, C_12_34)]), D_FM0_ZZWW1_S);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_m0 (1,
[(1, C_13_42)]), D_FM0_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_m0 (1,
[(1, C_14_23)]), D_FM0_ZZWW1_T);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_m0 (2,
[(1, C_12_34)]), D_FM0_ZZWW1_S);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_m0 (2,
[(1, C_13_42)]), D_FM0_ZZWW1_U);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_m0 (2,
[(1, C_14_23)]), D_FM0_ZZWW1_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m0 (0,
[(1, C_12_34)]), D_FM0_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m0 (0,
[(1, C_13_42)]), D_FM0_ZZZZ_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m0 (0,
[(1, C_14_23)]), D_FM0_ZZZZ_U);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m0 (3,
[(1, C_14_23)]), D_FM0_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m0 (3,
[(1, C_13_42)]), D_FM0_ZZZZ_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m0 (3,
[(1, C_12_34)]), D_FM0_ZZZZ_U)]
else
[]
let k_matrix_quartic_gauge_m_1 =
if Flags.k_matrix_tm then
List.map qgc
[ ((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_m1 (0,
[(1, C_12_34)]), D_FM1_WWWW0_S);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_m1 (0,
[(1, C_14_23)]), D_FM1_WWWW0_T);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_m1 (0,
[(1, C_13_42)]), D_FM1_WWWW0_U);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_m1 (0,
[(1, C_12_34)]), D_FM1_WWWW0_S);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_m1 (0,
[(1, C_14_23)]), D_FM1_WWWW0_T);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_m1 (0,
[(1, C_13_42)]), D_FM1_WWWW0_U);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_m1 (0,
[(1, C_12_34)]), D_FM1_WWWW2_S);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_m1 (0,
[(1, C_13_42)]), D_FM1_WWWW2_T);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_m1 (0,
[(1, C_14_23)]), D_FM1_WWWW2_U);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_m1 (0,
[(1, C_12_34)]), D_FM1_ZZWW0_S);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_m1 (0,
[(1, C_13_42)]), D_FM1_ZZWW0_T);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_m1 (0,
[(1, C_14_23)]), D_FM1_ZZWW0_U);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_m1 (0,
[(1, C_12_34)]), D_FM1_ZZWW1_S);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_m1 (0,
[(1, C_13_42)]), D_FM1_ZZWW1_T);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_m1 (0,
[(1, C_14_23)]), D_FM1_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_m1 (1,
[(1, C_12_34)]), D_FM1_ZZWW1_S);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_m1 (1,
[(1, C_13_42)]), D_FM1_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_m1 (1,
[(1, C_14_23)]), D_FM1_ZZWW1_T);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_m1 (2,
[(1, C_12_34)]), D_FM1_ZZWW1_S);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_m1 (2,
[(1, C_13_42)]), D_FM1_ZZWW1_U);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_m1 (2,
[(1, C_14_23)]), D_FM1_ZZWW1_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m1 (0,
[(1, C_12_34)]), D_FM1_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m1 (0,
[(1, C_13_42)]), D_FM1_ZZZZ_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m1 (0,
[(1, C_14_23)]), D_FM1_ZZZZ_U);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m1 (3,
[(1, C_14_23)]), D_FM1_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m1 (3,
[(1, C_13_42)]), D_FM1_ZZZZ_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m1 (3,
[(1, C_12_34)]), D_FM1_ZZZZ_U)]
else
[]
let k_matrix_quartic_gauge_m_7 =
if Flags.k_matrix_tm then
List.map qgc
[ ((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_m7 (0,
[(1, C_12_34)]), D_FM7_WWWW0_S);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_m7 (0,
[(1, C_14_23)]), D_FM7_WWWW0_T);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_cf_m7 (0,
[(1, C_13_42)]), D_FM7_WWWW0_U);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_m7 (0,
[(1, C_12_34)]), D_FM7_WWWW0_S);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_m7 (0,
[(1, C_14_23)]), D_FM7_WWWW0_T);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_cf_m7 (0,
[(1, C_13_42)]), D_FM7_WWWW0_U);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_m7 (0,
[(1, C_12_34)]), D_FM7_WWWW2_S);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_m7 (0,
[(1, C_13_42)]), D_FM7_WWWW2_T);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_cf_m7 (0,
[(1, C_14_23)]), D_FM7_WWWW2_U);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_m7 (0,
[(1, C_12_34)]), D_FM7_ZZWW0_S);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_m7 (0,
[(1, C_13_42)]), D_FM7_ZZWW0_T);
((Wm, Wp, Z, Z), Vector4_K_Matrix_cf_m7 (0,
[(1, C_14_23)]), D_FM7_ZZWW0_U);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_m7 (0,
[(1, C_12_34)]), D_FM7_ZZWW1_S);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_m7 (0,
[(1, C_13_42)]), D_FM7_ZZWW1_T);
((Wm, Z, Wp, Z), Vector4_K_Matrix_cf_m7 (0,
[(1, C_14_23)]), D_FM7_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_m7 (1,
[(1, C_12_34)]), D_FM7_ZZWW1_S);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_m7 (1,
[(1, C_13_42)]), D_FM7_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_cf_m7 (1,
[(1, C_14_23)]), D_FM7_ZZWW1_T);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_m7 (2,
[(1, C_12_34)]), D_FM7_ZZWW1_S);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_m7 (2,
[(1, C_13_42)]), D_FM7_ZZWW1_U);
((Z, Wp, Wm, Z), Vector4_K_Matrix_cf_m7 (2,
[(1, C_14_23)]), D_FM7_ZZWW1_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m7 (0,
[(1, C_12_34)]), D_FM7_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m7 (0,
[(1, C_13_42)]), D_FM7_ZZZZ_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m7 (0,
[(1, C_14_23)]), D_FM7_ZZZZ_U);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m7 (3,
[(1, C_14_23)]), D_FM7_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m7 (3,
[(1, C_13_42)]), D_FM7_ZZZZ_T);
((Z, Z, Z, Z), Vector4_K_Matrix_cf_m7 (3,
[(1, C_12_34)]), D_FM7_ZZZZ_U)]
else
[]
let k_matrix_2scalar_2gauge =
if Flags.k_matrix_tm then
if Flags.higgs_matrix then
[ ((O H,O H,G Z,G Z), DScalar2_Vector2_K_Matrix_ms
(0, [(1, C_12_34)]), D_Alpha_HHZZ0_S);
((O H,O H,G Z,G Z), DScalar2_Vector2_K_Matrix_ms
(0, [(1, C_13_42)]), D_Alpha_HHZZ0_T);
((O H,O H,G Z,G Z), DScalar2_Vector2_K_Matrix_ms
(0, [(1, C_14_23)]), D_Alpha_HHZZ0_T);
((O H,O H,G Z,G Z), DScalar2_Vector2_K_Matrix_ms
(3, [(1, C_14_23)]), D_Alpha_HHZZ1_S);
((O H,O H,G Z,G Z), DScalar2_Vector2_K_Matrix_ms
(3, [(1, C_13_42)]), D_Alpha_HHZZ1_T);
((O H,O H,G Z,G Z), DScalar2_Vector2_K_Matrix_ms
(3, [(1, C_12_34)]), D_Alpha_HHZZ1_U);
((O H,O H,G Z,G Z), DScalar2_Vector2_K_Matrix_ms
(6, [(1, C_13_42)]), D_Alpha_HHZZ1_S);
((O H,O H,G Z,G Z), DScalar2_Vector2_K_Matrix_ms
(6, [(1, C_12_34)]), D_Alpha_HHZZ1_T);
((O H,O H,G Z,G Z), DScalar2_Vector2_K_Matrix_ms
(6, [(1, C_14_23)]), D_Alpha_HHZZ1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_K_Matrix_ms
(0, [(1, C_12_34)]), D_Alpha_HHWW0_S);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_K_Matrix_ms
(2, [(1, C_13_42)]), D_Alpha_HHWW0_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_K_Matrix_ms
(1, [(1, C_14_23)]), D_Alpha_HHWW0_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_K_Matrix_ms
(1, [(1, C_13_42)]), D_Alpha_HHWW0_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_K_Matrix_ms
(2, [(1, C_14_23)]), D_Alpha_HHWW0_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_K_Matrix_ms
(3, [(1, C_14_23)]), D_Alpha_HHWW1_S);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_K_Matrix_ms
(6, [(1, C_13_42)]), D_Alpha_HHWW1_S);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_K_Matrix_ms
(4, [(1, C_13_42)]), D_Alpha_HHWW1_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_K_Matrix_ms
(5, [(1, C_12_34)]), D_Alpha_HHWW1_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_K_Matrix_ms
(8, [(1, C_14_23)]), D_Alpha_HHWW1_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_K_Matrix_ms
(7, [(1, C_12_34)]), D_Alpha_HHWW1_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_K_Matrix_ms
(5, [(1, C_13_42)]), D_Alpha_HHWW1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_K_Matrix_ms
(4, [(1, C_12_34)]), D_Alpha_HHWW1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_K_Matrix_ms
(7, [(1, C_14_23)]), D_Alpha_HHWW1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_K_Matrix_ms
(8, [(1, C_12_34)]), D_Alpha_HHWW1_U) ]
else
[]
else
[]
let k_matrix_2scalar_2gauge_m =
if Flags.k_matrix_tm then
if Flags.higgs_matrix then
[ ((O H,O H,G Z,G Z), DScalar2_Vector2_m_0_K_Matrix_cf
(0, [(1, C_12_34)]), D_FM0_HHZZ0_S);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_0_K_Matrix_cf
(0, [(1, C_13_42)]), D_FM0_HHZZ0_T);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_0_K_Matrix_cf
(0, [(1, C_14_23)]), D_FM0_HHZZ0_U);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_0_K_Matrix_cf
(3, [(1, C_14_23)]), D_FM0_HHZZ1_S);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_0_K_Matrix_cf
(3, [(1, C_13_42)]), D_FM0_HHZZ1_U);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_0_K_Matrix_cf
(3, [(1, C_12_34)]), D_FM0_HHZZ1_T);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_0_K_Matrix_cf
(6, [(1, C_13_42)]), D_FM0_HHZZ1_S);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_0_K_Matrix_cf
(6, [(1, C_12_34)]), D_FM0_HHZZ1_T);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_0_K_Matrix_cf
(6, [(1, C_14_23)]), D_FM0_HHZZ1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_0_K_Matrix_cf
(0, [(1, C_12_34)]), D_FM0_HHWW0_S);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_0_K_Matrix_cf
(2, [(1, C_13_42)]), D_FM0_HHWW0_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_0_K_Matrix_cf
(1, [(1, C_14_23)]), D_FM0_HHWW0_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_0_K_Matrix_cf
(1, [(1, C_13_42)]), D_FM0_HHWW0_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_0_K_Matrix_cf
(2, [(1, C_14_23)]), D_FM0_HHWW0_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_0_K_Matrix_cf
(3, [(1, C_14_23)]), D_FM0_HHWW1_S);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_0_K_Matrix_cf
(6, [(1, C_13_42)]), D_FM0_HHWW1_S);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_0_K_Matrix_cf
(4, [(1, C_13_42)]), D_FM0_HHWW1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_0_K_Matrix_cf
(5, [(1, C_12_34)]), D_FM0_HHWW1_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_0_K_Matrix_cf
(8, [(1, C_14_23)]), D_FM0_HHWW1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_0_K_Matrix_cf
(7, [(1, C_12_34)]), D_FM0_HHWW1_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_0_K_Matrix_cf
(5, [(1, C_13_42)]), D_FM0_HHWW1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_0_K_Matrix_cf
(4, [(1, C_12_34)]), D_FM0_HHWW1_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_0_K_Matrix_cf
(7, [(1, C_14_23)]), D_FM0_HHWW1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_0_K_Matrix_cf
(8, [(1, C_12_34)]), D_FM0_HHWW1_T) ]
else
[]
else
[]
let k_matrix_2scalar_2gauge_m_1 =
if Flags.k_matrix_tm then
if Flags.higgs_matrix then
[ ((O H,O H,G Z,G Z), DScalar2_Vector2_m_1_K_Matrix_cf
(0, [(1, C_12_34)]), D_FM1_HHZZ0_S);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_1_K_Matrix_cf
(0, [(1, C_13_42)]), D_FM1_HHZZ0_T);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_1_K_Matrix_cf
(0, [(1, C_14_23)]), D_FM1_HHZZ0_U);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_1_K_Matrix_cf
(3, [(1, C_14_23)]), D_FM1_HHZZ1_S);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_1_K_Matrix_cf
(3, [(1, C_13_42)]), D_FM1_HHZZ1_U);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_1_K_Matrix_cf
(3, [(1, C_12_34)]), D_FM1_HHZZ1_T);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_1_K_Matrix_cf
(6, [(1, C_13_42)]), D_FM1_HHZZ1_S);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_1_K_Matrix_cf
(6, [(1, C_12_34)]), D_FM1_HHZZ1_T);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_1_K_Matrix_cf
(6, [(1, C_14_23)]), D_FM1_HHZZ1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_1_K_Matrix_cf
(0, [(1, C_12_34)]), D_FM1_HHWW0_S);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_1_K_Matrix_cf
(2, [(1, C_13_42)]), D_FM1_HHWW0_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_1_K_Matrix_cf
(1, [(1, C_14_23)]), D_FM1_HHWW0_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_1_K_Matrix_cf
(1, [(1, C_13_42)]), D_FM1_HHWW0_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_1_K_Matrix_cf
(2, [(1, C_14_23)]), D_FM1_HHWW0_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_1_K_Matrix_cf
(3, [(1, C_14_23)]), D_FM1_HHWW1_S);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_1_K_Matrix_cf
(6, [(1, C_13_42)]), D_FM1_HHWW1_S);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_1_K_Matrix_cf
(4, [(1, C_13_42)]), D_FM1_HHWW1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_1_K_Matrix_cf
(5, [(1, C_12_34)]), D_FM1_HHWW1_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_1_K_Matrix_cf
(8, [(1, C_14_23)]), D_FM1_HHWW1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_1_K_Matrix_cf
(7, [(1, C_12_34)]), D_FM1_HHWW1_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_1_K_Matrix_cf
(5, [(1, C_13_42)]), D_FM1_HHWW1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_1_K_Matrix_cf
(4, [(1, C_12_34)]), D_FM1_HHWW1_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_1_K_Matrix_cf
(7, [(1, C_14_23)]), D_FM1_HHWW1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_1_K_Matrix_cf
(8, [(1, C_12_34)]), D_FM1_HHWW1_T) ]
else
[]
else
[]
let k_matrix_2scalar_2gauge_m_7 =
if Flags.k_matrix_tm then
if Flags.higgs_matrix then
[ ((O H,O H,G Z,G Z), DScalar2_Vector2_m_7_K_Matrix_cf
(0, [(1, C_12_34)]), D_FM7_HHZZ0_S);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_7_K_Matrix_cf
(0, [(1, C_13_42)]), D_FM7_HHZZ0_T);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_7_K_Matrix_cf
(0, [(1, C_14_23)]), D_FM7_HHZZ0_U);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_7_K_Matrix_cf
(3, [(1, C_14_23)]), D_FM7_HHZZ1_S);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_7_K_Matrix_cf
(3, [(1, C_13_42)]), D_FM7_HHZZ1_U);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_7_K_Matrix_cf
(3, [(1, C_12_34)]), D_FM7_HHZZ1_T);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_7_K_Matrix_cf
(6, [(1, C_13_42)]), D_FM7_HHZZ1_S);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_7_K_Matrix_cf
(6, [(1, C_12_34)]), D_FM7_HHZZ1_T);
((O H,O H,G Z,G Z), DScalar2_Vector2_m_7_K_Matrix_cf
(6, [(1, C_14_23)]), D_FM7_HHZZ1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_7_K_Matrix_cf
(0, [(1, C_12_34)]), D_FM7_HHWW0_S);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_7_K_Matrix_cf
(2, [(1, C_13_42)]), D_FM7_HHWW0_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_7_K_Matrix_cf
(1, [(1, C_14_23)]), D_FM7_HHWW0_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_7_K_Matrix_cf
(1, [(1, C_13_42)]), D_FM7_HHWW0_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_7_K_Matrix_cf
(2, [(1, C_14_23)]), D_FM7_HHWW0_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_7_K_Matrix_cf
(3, [(1, C_14_23)]), D_FM7_HHWW1_S);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_7_K_Matrix_cf
(6, [(1, C_13_42)]), D_FM7_HHWW1_S);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_7_K_Matrix_cf
(4, [(1, C_13_42)]), D_FM7_HHWW1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_7_K_Matrix_cf
(5, [(1, C_12_34)]), D_FM7_HHWW1_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_7_K_Matrix_cf
(8, [(1, C_14_23)]), D_FM7_HHWW1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_7_K_Matrix_cf
(7, [(1, C_12_34)]), D_FM7_HHWW1_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_7_K_Matrix_cf
(5, [(1, C_13_42)]), D_FM7_HHWW1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_7_K_Matrix_cf
(4, [(1, C_12_34)]), D_FM7_HHWW1_T);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_7_K_Matrix_cf
(7, [(1, C_14_23)]), D_FM7_HHWW1_U);
((O H,O H,G Wp,G Wm), DScalar2_Vector2_m_7_K_Matrix_cf
(8, [(1, C_12_34)]), D_FM7_HHWW1_T) ]
else
[]
else
[]
let k_matrix_4scalar =
if Flags.k_matrix then
if Flags.higgs_matrix then
[ ((O H,O H,O H,O H), DScalar4_K_Matrix_ms
(0, [(1, C_12_34)]), D_Alpha_HHHH_S);
((O H,O H,O H,O H), DScalar4_K_Matrix_ms
(0, [(1, C_13_42)]), D_Alpha_HHHH_T);
((O H,O H,O H,O H), DScalar4_K_Matrix_ms
(0, [(1, C_14_23)]), D_Alpha_HHHH_T);
((O H,O H,O H,O H), DScalar4_K_Matrix_ms
(3, [(1, C_14_23)]), D_Alpha_HHHH_S);
((O H,O H,O H,O H), DScalar4_K_Matrix_ms
(3, [(1, C_13_42)]), D_Alpha_HHHH_T);
((O H,O H,O H,O H), DScalar4_K_Matrix_ms
(3, [(1, C_12_34)]), D_Alpha_HHHH_T) ]
else
[]
else
[]
(*i Thorsten's original implementation of the K matrix, which we keep since
it still might be usefull for the future.
let k_matrix_quartic_gauge =
if Flags.k_matrix then
List.map qgc
[ ((Wm, Wp, Wm, Wp), Vector4_K_Matrix_tho (0, [K_Matrix_Coeff 0,
K_Matrix_Pole 0]), Alpha_WWWW0);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_tho (0, [K_Matrix_Coeff 2,
K_Matrix_Pole 2]), Alpha_WWWW2);
((Wm, Wp, Z, Z), Vector4_K_Matrix_tho (0, [(K_Matrix_Coeff 0,
K_Matrix_Pole 0); (K_Matrix_Coeff 2,
K_Matrix_Pole 2)]), Alpha_ZZWW0);
((Wm, Z, Wp, Z), Vector4_K_Matrix_tho (0, [K_Matrix_Coeff 1,
K_Matrix_Pole 1]), Alpha_ZZWW1);
((Z, Z, Z, Z), Vector4_K_Matrix_tho (0, [K_Matrix_Coeff 0,
K_Matrix_Pole 0]), Alpha_ZZZZ) ]
else
[]
i*)
let quartic_gauge =
standard_quartic_gauge @ anomalous_quartic_gauge @ k_matrix_quartic_gauge
@ k_matrix_quartic_gauge_t_0 @ k_matrix_quartic_gauge_t_1 @ k_matrix_quartic_gauge_t_2
@ k_matrix_quartic_gauge_t_rsi
@ k_matrix_quartic_gauge_m_0 @ k_matrix_quartic_gauge_m_1 @ k_matrix_quartic_gauge_m_7
let standard_gauge_higgs =
[ ((O H, G Wp, G Wm), Scalar_Vector_Vector 1, G_HWW);
((O H, G Z, G Z), Scalar_Vector_Vector 1, G_HZZ) ]
let standard_gauge_higgs4 =
[ (O H, O H, G Wp, G Wm), Scalar2_Vector2 1, G_HHWW;
(O H, O H, G Z, G Z), Scalar2_Vector2 1, G_HHZZ ]
let dim8_gauge_higgs4 =
[ (O H, O H, G Wp, G Wm), Dim8_Scalar2_Vector2_1 1, FS0_HHWW;
(O H, O H, G Z, G Z), Dim8_Scalar2_Vector2_1 1, FS0_HHZZ;
(O H, O H, G Wp, G Wm), Dim8_Scalar2_Vector2_2 1, FS1_HHWW;
(O H, O H, G Z, G Z), Dim8_Scalar2_Vector2_2 1, FS1_HHZZ ]
let dim8_gauge_higgs4_m =
[ (O H, O H, G Wp, G Wm), Dim8_Scalar2_Vector2_m_0 1, FM0_HHWW;
(O H, O H, G Z, G Z), Dim8_Scalar2_Vector2_m_0 1, FM0_HHZZ;
(O H, O H, G Wp, G Wm), Dim8_Scalar2_Vector2_m_1 1, FM1_HHWW;
(O H, O H, G Z, G Z), Dim8_Scalar2_Vector2_m_1 1, FM1_HHZZ;
(O H, O H, G Wp, G Wm), Dim8_Scalar2_Vector2_m_7 1, FM7_HHWW;
(O H, O H, G Z, G Z), Dim8_Scalar2_Vector2_m_7 1, FM7_HHZZ]
let standard_higgs =
[ (O H, O H, O H), Scalar_Scalar_Scalar 1, G_H3 ]
let standard_higgs4 =
[ (O H, O H, O H, O H), Scalar4 1, G_H4 ]
let fs_higgs4 =
[ (O H, O H, O H, O H), Dim8_Scalar4 1, FS_H4 ]
(* WK's couplings (apparently, he still intends to divide by
$\Lambda^2_{\text{EWSB}}=16\pi^2v_{\mathrm{F}}^2$):
\begin{subequations}
\begin{align}
\mathcal{L}^{\tau}_4 &=
\left\lbrack (\partial_{\mu}H)(\partial^{\mu}H)
+ \frac{g^2v_{\mathrm{F}}^2}{4} V_{\mu} V^{\mu} \right\rbrack^2 \\
\mathcal{L}^{\tau}_5 &=
\left\lbrack (\partial_{\mu}H)(\partial_{\nu}H)
+ \frac{g^2v_{\mathrm{F}}^2}{4} V_{\mu} V_{\nu} \right\rbrack^2
\end{align}
\end{subequations}
with
\begin{equation}
V_{\mu} V_{\nu} =
\frac{1}{2} \left( W^+_{\mu} W^-_{\nu} + W^+_{\nu} W^-_{\mu} \right)
+ \frac{1}{2\cos^2\theta_{w}} Z_{\mu} Z_{\nu}
\end{equation}
(note the symmetrization!), i.\,e.
\begin{subequations}
\begin{align}
\mathcal{L}_4 &= \alpha_4 \frac{g^4v_{\mathrm{F}}^4}{16} (V_{\mu} V_{\nu})^2 \\
\mathcal{L}_5 &= \alpha_5 \frac{g^4v_{\mathrm{F}}^4}{16} (V_{\mu} V^{\mu})^2
\end{align}
\end{subequations} *)
(* Breaking thinks up
\begin{subequations}
\begin{align}
\mathcal{L}^{\tau,H^4}_4 &=
\left\lbrack (\partial_{\mu}H)(\partial^{\mu}H) \right\rbrack^2 \\
\mathcal{L}^{\tau,H^4}_5 &=
\left\lbrack (\partial_{\mu}H)(\partial^{\mu}H) \right\rbrack^2
\end{align}
\end{subequations}
and
\begin{subequations}
\begin{align}
\mathcal{L}^{\tau,H^2V^2}_4 &= \frac{g^2v_{\mathrm{F}}^2}{2}
(\partial_{\mu}H)(\partial^{\mu}H) V_{\mu}V^{\mu} \\
\mathcal{L}^{\tau,H^2V^2}_5 &= \frac{g^2v_{\mathrm{F}}^2}{2}
(\partial_{\mu}H)(\partial_{\nu}H) V_{\mu}V_{\nu}
\end{align}
\end{subequations}
i.\,e.
\begin{subequations}
\begin{align}
\mathcal{L}^{\tau,H^2V^2}_4 &=
\frac{g^2v_{\mathrm{F}}^2}{2}
\left\lbrack
(\partial_{\mu}H)(\partial^{\mu}H) W^+_{\nu}W^{-,\nu}
+ \frac{1}{2\cos^2\theta_{w}} (\partial_{\mu}H)(\partial^{\mu}H) Z_{\nu} Z^{\nu}
\right\rbrack \\
\mathcal{L}^{\tau,H^2V^2}_5 &=
\frac{g^2v_{\mathrm{F}}^2}{2}
\left\lbrack
(W^{+,\mu}\partial_{\mu}H) (W^{-,\nu}\partial_{\nu}H)
+ \frac{1}{2\cos^2\theta_{w}} (Z^{\mu}\partial_{\mu}H)(Z^{\nu}\partial_{\nu}H)
\right\rbrack
\end{align}
\end{subequations} *)
(* \begin{multline}
\tau^4_8 \mathcal{L}^{\tau,H^2V^2}_4 + \tau^5_8 \mathcal{L}^{\tau,H^2V^2}_5 = \\
- \frac{g^2v_{\mathrm{F}}^2}{2} \Biggl\lbrack
2\tau^4_8
\frac{1}{2}(\ii\partial_{\mu}H)(\ii\partial^{\mu}H) W^+_{\nu}W^{-,\nu}
+ \tau^5_8
(W^{+,\mu}\ii\partial_{\mu}H) (W^{-,\nu}\ii\partial_{\nu}H) \\
+ \frac{2\tau^4_8}{\cos^2\theta_{w}}
\frac{1}{4} (\ii\partial_{\mu}H)(\ii\partial^{\mu}H) Z_{\nu} Z^{\nu}
+ \frac{\tau^5_8}{\cos^2\theta_{w}}
\frac{1}{2} (Z^{\mu}\ii\partial_{\mu}H)(Z^{\nu}\ii\partial_{\nu}H)
\Biggr\rbrack
\end{multline}
where the two powers of $\ii$ make the sign conveniently negative,
i.\,e.
\begin{subequations}
\begin{align}
\alpha_{(\partial H)^2W^2}^2 &= \tau^4_8 g^2v_{\mathrm{F}}^2\\
\alpha_{(\partial HW)^2}^2 &= \frac{\tau^5_8 g^2v_{\mathrm{F}}^2}{2} \\
\alpha_{(\partial H)^2Z^2}^2 &= \frac{\tau^4_8 g^2v_{\mathrm{F}}^2}{\cos^2\theta_{w}} \\
\alpha_{(\partial HZ)^2}^2 &=\frac{\tau^5_8 g^2v_{\mathrm{F}}^2}{2\cos^2\theta_{w}}
\end{align}
\end{subequations} *)
let anomalous_gauge_higgs =
[ (O H, G Ga, G Ga), Dim5_Scalar_Gauge2 1, G_HGaGa_anom;
(O H, G Ga, G Z), Dim5_Scalar_Gauge2 1, G_HGaZ_anom;
(O H, G Z, G Z), Dim5_Scalar_Gauge2 1, G_HZZ_anom;
(O H, G Wp, G Wm), Dim5_Scalar_Gauge2 1, G_HWW_anom;
(O H, G Ga, G Z), Dim5_Scalar_Vector_Vector_U 1, G_HGaZ_u;
(O H, G Z, G Z), Dim5_Scalar_Vector_Vector_U 1, G_HZZ_u;
(O H, G Wp, G Wm), Dim5_Scalar_Vector_Vector_U 1, G_HWW_u;
(O H, G Wm, G Wp), Dim5_Scalar_Vector_Vector_U 1, G_HWW_u
]
let anomalous_gauge_higgs4 =
[]
let anomalous_higgs =
[]
let higgs_triangle_vertices =
if Flags.higgs_triangle then
[ (O H, G Ga, G Ga), Dim5_Scalar_Gauge2 1, G_HGaGa;
(O H, G Ga, G Z), Dim5_Scalar_Gauge2 1, G_HGaZ;
(O H, G Gl, G Gl), Dim5_Scalar_Gauge2 1, G_Hgg ]
else
[]
let anomalous_higgs4 =
[]
let gauge_higgs =
if Flags.higgs_anom then
standard_gauge_higgs @ anomalous_gauge_higgs
else
standard_gauge_higgs
let gauge_higgs4 =
( if Flags.higgs_anom then
standard_gauge_higgs4 @ anomalous_gauge_higgs4
else
standard_gauge_higgs4 ) @
( if Flags.higgs_matrix then
(dim8_gauge_higgs4 @ dim8_gauge_higgs4_m @ k_matrix_2scalar_2gauge
@ k_matrix_2scalar_2gauge_m @ k_matrix_2scalar_2gauge_m_1 @ k_matrix_2scalar_2gauge_m_7)
else
[] )
let higgs =
if Flags.higgs_anom then
standard_higgs @ anomalous_higgs
else
standard_higgs
let higgs4 =
( if Flags.higgs_anom then
standard_higgs4 @ anomalous_higgs4
else
standard_higgs4 ) @
( if Flags.higgs_matrix then
(fs_higgs4 @ k_matrix_4scalar )
else
[] )
let goldstone_vertices =
[ ((O Phi0, G Wm, G Wp), Scalar_Vector_Vector 1, I_G_ZWW);
((O Phip, G Ga, G Wm), Scalar_Vector_Vector 1, I_Q_W);
((O Phip, G Z, G Wm), Scalar_Vector_Vector 1, I_G_ZWW);
((O Phim, G Wp, G Ga), Scalar_Vector_Vector 1, I_Q_W);
((O Phim, G Wp, G Z), Scalar_Vector_Vector 1, I_G_ZWW) ]
(* New Resonances *)
(*
\begin{dubious}
There is an extra minus in the Lagrangian to have the same sign as
HWW or HZZ vertex.
Effectivly this doesn't matter for SSC, because $(-1)^2=1$.
This is only for completeness.
\end{dubious}
\begin{subequations}
\begin{align}
\mathbf{V}_\mu &= -\mathrm{i} g\mathbf{W}_\mu+\mathrm{i} g^\prime\mathbf{B}_\mu \\
\mathbf{W}_\mu &= W_\mu^a\frac{\tau^a}{2} \\
\mathbf{B}_\mu &= W_\mu^a\frac{\tau^3}{2} \\
\tau^{++}&= \tau^+ \otimes \tau^+ \\
\tau^+ &= \frac{1}{2} \left (\tau^+ \otimes \tau^3 + \tau^3+\tau^+ \right ) \\
\tau^0 &= \frac{1}{\sqrt{6}} \left (\tau^3\otimes\tau^3 -\tau^+ \otimes \tau^- - \tau^-+\tau^+ \right ) \\
\tau^- &= \frac{1}{2} \left (\tau^- \otimes \tau^3 + \tau^3+\tau^- \right ) \\
\tau^{--}&= \tau^- \otimes \tau^-
\end{align}
\end{subequations}
*)
(* Scalar Isoscalar
Old representation
\begin{equation}
\mathcal{L}_{\sigma}=
-\frac{g_\sigma v}{2} \text{tr}
\left\lbrack \mathbf{V}_\mu \mathbf{V}^\mu \right\rbrack \sigma
\end{equation}
*)
(* \begin{dubious}
Transversal couplings like rsigma3t and rf3t are to be calculated in the new
higgs matrix representation.
\end{dubious} *)
let rsigma3 =
[ ((O Rsigma, G Wp, G Wm), Scalar_Vector_Vector 1, G_SWW);
((O Rsigma, G Z, G Z), Scalar_Vector_Vector 1, G_SZZ) ]
let rsigma3h =
[ ((O Rsigma, O H, O H), Dim5_Scalar_Scalar2 1, G_SHH) ]
let rsigma3t =
[ ((O Rsigma, G Wp, G Wm), Scalar_Vector_Vector_t 1, G_SWW_T);
((O Rsigma, G Z, G Z), Scalar_Vector_Vector_t 1, G_SZZ_T);
((O Rsigma, G Ga, G Ga), Scalar_Vector_Vector_t 1, G_SAA_T);
((O Rsigma, G Ga, G Z), Scalar_Vector_Vector_t 1, G_SAZ_T) ]
let rsigma4 =
[ (O Rsigma, O Rsigma, G Wp, G Wm), Scalar2_Vector2 1, G_SSWW;
(O Rsigma, O Rsigma, G Z, G Z), Scalar2_Vector2 1, G_SSZZ ]
(* Scalar Isotensor
\begin{subequations}
\begin{align}
\mathcal{L}_{\phi}&=
\frac{g_\phi v}{4} \text{Tr}
\left \lbrack \left ( \mathbf{V}_\mu \otimes \mathbf{V}^\mu - \frac{\tau^{aa}}{6} \text{Tr} \left \lbrack \mathbf{V}_\mu \mathbf{V}^\mu \right \rbrack\right ) {\mathbf{\phi}} \right \rbrack\\
\phi&=\sqrt{2} \left (\phi^{++}\tau^{++}+\phi^+\tau^++\phi^0\tau^0+\phi^-\tau^- + \phi^{--}\tau^{--} \right )
\end{align}
\end{subequations}
*)
let rphi3 =
[ ((O Rphin, G Wp, G Wm), Scalar_Vector_Vector 1, G_PNWW);
((O Rphin, G Z, G Z), Scalar_Vector_Vector 1, G_PNZZ) ;
((O Rphisn, G Wp, G Wm), Scalar_Vector_Vector 1, G_PSNWW);
((O Rphisn, G Z, G Z), Scalar_Vector_Vector 1, G_PSNZZ) ;
((O Rphip, G Z, G Wm), Scalar_Vector_Vector 1, G_PWZ) ;
((O Rphipp, G Wm, G Wm), Scalar_Vector_Vector 1, G_PWW) ;
((O Rphim, G Wp, G Z), Scalar_Vector_Vector 1, G_PWZ) ;
((O Rphimm, G Wp, G Wp), Scalar_Vector_Vector 1, G_PWW) ]
let rphi3h =
[ ((O Rphisn, O H, O H), Dim5_Scalar_Scalar2 1, G_PSNHH) ]
(* Tensor IsoScalar
*)
let rf3 =
[ ((O Rf, G Wp, G Wm), Tensor_2_Vector_Vector_1 1, G_FWW);
((O Rf, G Z, G Z), Tensor_2_Vector_Vector_1 1, G_FZZ) ]
let rf3cf =
[ ((O Rf, G Wp, G Wm), Tensor_2_Vector_Vector 1, G_FWW);
((O Rf, G Z, G Z), Tensor_2_Vector_Vector 1, G_FZZ);
((O Rf, G Wp, G Wm), Tensor_2_Vector_Vector_cf 1, G_FWW_CF);
((O Rf, G Z, G Z), Tensor_2_Vector_Vector_cf 1, G_FZZ_CF) ]
let rff3cf =
[ ((O Rff, G Wp, G Wm), Tensor_2_Vector_Vector 1, G_FFWW);
((O Rff, G Z, G Z), Tensor_2_Vector_Vector 1, G_FFZZ);
((O Rff, G Wp, G Wm), Tensor_2_Vector_Vector_cf 1, G_FFWW_CF);
((O Rff, G Z, G Z), Tensor_2_Vector_Vector_cf 1, G_FFZZ_CF) ]
let rfv3cf =
[ ((O Rfv, G Wp, G Wm), TensorVector_Vector_Vector 1, G_FVWW);
((O Rfv, G Z, G Z), TensorVector_Vector_Vector 1, G_FVZZ);
((O Rfv, G Wp, G Wm), TensorVector_Vector_Vector_cf 1, G_FVWW_CF);
((O Rfv, G Z, G Z), TensorVector_Vector_Vector_cf 1, G_FVZZ_CF) ]
let rfddphi3cf =
[ ((O Rfphi, G Wp, G Wm), TensorScalar_Vector_Vector 1, G_FDDSWW);
((O Rfphi, G Z, G Z), TensorScalar_Vector_Vector 1, G_FDDSZZ);
((O Rfphi, G Wp, G Wm), TensorScalar_Vector_Vector_cf 1, G_FDDSWW_CF);
((O Rfphi, G Z, G Z), TensorScalar_Vector_Vector_cf 1, G_FDDSZZ_CF) ]
let rfphi3cf =
[ ((O Rfphi, G Wp, G Wm), Scalar_Vector_Vector 1, G_FSWW);
((O Rfphi, G Z, G Z), Scalar_Vector_Vector 1, G_FSZZ) ]
let rf3h =
[ ((O Rf, O H, O H), Tensor_2_Scalar_Scalar 1, G_FHH);
((O Rf, O H, O H), Tensor_2_Scalar_Scalar_cf 1, G_FHH_CF) ]
let rff3h =
[ ((O Rff, O H, O H), Tensor_2_Scalar_Scalar 1, G_FFHH);
((O Rff, O H, O H), Tensor_2_Scalar_Scalar_cf 1, G_FFHH_CF);
((O Rfv, O H, O H), TensorVector_Scalar_Scalar 1, G_FVHH);
((O Rfv, O H, O H), TensorVector_Scalar_Scalar_cf 1, G_FVHH_CF);
((O Rfphi, O H, O H), TensorScalar_Scalar_Scalar 1, G_FDDSHH);
((O Rfphi, O H, O H), TensorScalar_Scalar_Scalar_cf 1, G_FDDSHH_CF);
((O Rfphi, O H, O H), Dim5_Scalar_Scalar2 1, G_FSHH) ]
let rf3t =
[ ((O Rf, G Wp, G Wm), Tensor_2_Vector_Vector_t 1, G_FWW_T);
((O Rf, G Z, G Z), Tensor_2_Vector_Vector_t 1, G_FZZ_T) ]
(* Tensor Isotensor
\begin{subequations}
\begin{align}
\mathcal{L}_{t}
\end{align}
\end{subequations}
*)
let rt3 =
[ ((O Rtn, G Wp, G Wm), Tensor_2_Vector_Vector_1 1, G_TNWW);
((O Rtn, G Z, G Z), Tensor_2_Vector_Vector_1 1, G_TNZZ) ;
((O Rtsn, G Wp, G Wm), Tensor_2_Vector_Vector_1 1, G_TSNWW);
((O Rtsn, G Z, G Z), Tensor_2_Vector_Vector_1 1, G_TSNZZ) ;
((O Rtp, G Z, G Wm), Tensor_2_Vector_Vector_1 1, G_TWZ) ;
((O Rtpp, G Wm, G Wm), Tensor_2_Vector_Vector_1 1, G_TWW) ;
((O Rtm, G Wp, G Z), Tensor_2_Vector_Vector_1 1, G_TWZ) ;
((O Rtmm, G Wp, G Wp), Tensor_2_Vector_Vector_1 1, G_TWW) ]
let rt3cf =
[ ((O Rtn, G Wp, G Wm), Tensor_2_Vector_Vector 1, G_TNWW);
((O Rtn, G Z, G Z), Tensor_2_Vector_Vector 1, G_TNZZ) ;
((O Rtsn, G Wp, G Wm), Tensor_2_Vector_Vector 1, G_TSNWW);
((O Rtsn, G Z, G Z), Tensor_2_Vector_Vector 1, G_TSNZZ) ;
((O Rtp, G Z, G Wm), Tensor_2_Vector_Vector 1, G_TWZ) ;
((O Rtpp, G Wm, G Wm), Tensor_2_Vector_Vector 1, G_TWW) ;
((O Rtm, G Wp, G Z), Tensor_2_Vector_Vector 1, G_TWZ) ;
((O Rtmm, G Wp, G Wp), Tensor_2_Vector_Vector 1, G_TWW);
((O Rtn, G Wp, G Wm), Tensor_2_Vector_Vector_cf 1, G_TNWW_CF);
((O Rtn, G Z, G Z), Tensor_2_Vector_Vector_cf 1, G_TNZZ_CF) ;
((O Rtsn, G Wp, G Wm), Tensor_2_Vector_Vector_cf 1, G_TSNWW_CF);
((O Rtsn, G Z, G Z), Tensor_2_Vector_Vector_cf 1, G_TSNZZ_CF) ;
((O Rtp, G Z, G Wm), Tensor_2_Vector_Vector_cf 1, G_TWZ_CF) ;
((O Rtpp, G Wm, G Wm), Tensor_2_Vector_Vector_cf 1, G_TWW_CF) ;
((O Rtm, G Wp, G Z), Tensor_2_Vector_Vector_cf 1, G_TWZ_CF) ;
((O Rtmm, G Wp, G Wp), Tensor_2_Vector_Vector_cf 1, G_TWW_CF) ]
(* Anomalous trilinear interactions $f_i f_j V$ and $ttH$:
\begin{equation}
\Delta\mathcal{L}_{tt\gamma} =
- e \frac{\upsilon}{\Lambda^2}
\bar{t} i\sigma^{\mu\nu} k_\nu (d_V(k^2) + i d_A(k^2) \gamma_5) t A_\mu
\end{equation} *)
let anomalous_ttA =
if Flags.top_anom then
[ ((M (U (-3)), G Ga, M (U 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_ttA) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{bb\gamma} =
- e \frac{\upsilon}{\Lambda^2}
\bar{b} i\sigma^{\mu\nu} k_\nu (d_V(k^2) + i d_A(k^2) \gamma_5) b A_\mu
\end{equation} *)
let anomalous_bbA =
if Flags.top_anom then
[ ((M (D (-3)), G Ga, M (D 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_bbA) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{ttg} =
- g_s \frac{\upsilon}{\Lambda^2}
\bar{t}\lambda^a i\sigma^{\mu\nu}k_\nu
(d_V(k^2)+id_A(k^2)\gamma_5)tG^a_\mu
\end{equation} *)
let anomalous_ttG =
if Flags.top_anom then
[ ((M (U (-3)), G Gl, M (U 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_ttG) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{ttZ} =
- \frac{g}{2 c_W} \frac{\upsilon^2}{\Lambda^2}\left\lbrack
\bar{t} \fmslash{Z} (X_L(k^2) P_L + X_R(k^2) P_R) t
+ \bar{t}\frac{i\sigma^{\mu\nu}k_\nu}{m_Z}
(d_V(k^2)+id_A(k^2)\gamma_5)tZ_\mu\right\rbrack
\end{equation} *)
let anomalous_ttZ =
if Flags.top_anom then
[ ((M (U (-3)), G Z, M (U 3)), FBF (1, Psibar, VLRM, Psi), G_VLR_ttZ);
((M (U (-3)), G Z, M (U 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_ttZ) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{bbZ} =
- \frac{g}{2 c_W} \frac{\upsilon^2}{\Lambda^2}
\bar{b}\frac{i\sigma^{\mu\nu}k_\nu}{m_Z}
(d_V(k^2)+id_A(k^2)\gamma_5)bZ_\mu
\end{equation} *)
let anomalous_bbZ =
if Flags.top_anom then
[ ((M (D (-3)), G Z, M (D 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_bbZ) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{tbW} =
- \frac{g}{\sqrt{2}} \frac{\upsilon^2}{\Lambda^2}\left\lbrack
\bar{b}\fmslash{W}^-(V_L(k^2) P_L+V_R(k^2) P_R) t
+ \bar{b}\frac{i\sigma^{\mu\nu}k_\nu}{m_W}
(g_L(k^2)P_L+g_R(k^2)P_R)tW^-_\mu\right\rbrack
+ \textnormal{H.c.}
\end{equation} *)
let anomalous_tbW =
if Flags.top_anom then
[ ((M (D (-3)), G Wm, M (U 3)), FBF (1, Psibar, VLRM, Psi), G_VLR_btW);
((M (U (-3)), G Wp, M (D 3)), FBF (1, Psibar, VLRM, Psi), G_VLR_tbW);
((M (D (-3)), G Wm, M (U 3)), FBF (1, Psibar, TLRM, Psi), G_TLR_btW);
((M (U (-3)), G Wp, M (D 3)), FBF (1, Psibar, TRLM, Psi), G_TRL_tbW) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{ttH} =
- \frac{1}{\sqrt{2}} \bar{t} (Y_V(k^2)+iY_A(k^2)\gamma_5)t H
\end{equation} *)
let anomalous_ttH =
if Flags.top_anom then
[ ((M (U (-3)), O H, M (U 3)), FBF (1, Psibar, SPM, Psi), G_SP_ttH) ]
else
[]
(* quartic fermion-gauge interactions $f_i f_j V_1 V_2$ emerging from gauge-invariant
effective operators:
\begin{equation}
\Delta\mathcal{L}_{ttgg} =
- \frac{g_s^2}{2} f_{abc} \frac{\upsilon}{\Lambda^2}
\bar{t} \lambda^a \sigma^{\mu\nu}
(d_V(k^2)+id_A(k^2)\gamma_5)t G^b_\mu G^c_\nu
\end{equation} *)
let anomalous_ttGG =
if Flags.top_anom then
[ ((M (U (-3)), O (Aux_top (2,1,0,true,TTGG)), M (U 3)), FBF (1, Psibar, TVA, Psi), G_TVA_ttGG);
((O (Aux_top (2,1,0,false,TTGG)), G Gl, G Gl), Aux_Gauge_Gauge 1, I_Gs) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{tbWA} =
- i\sin\theta_w \frac{g^2}{2\sqrt{2}} \frac{\upsilon^2}{\Lambda^2}\left\lbrack
\bar{b}\frac{\sigma^{\mu\nu}}{m_W}
(g_L(k^2)P_L+g_R(k^2)P_R)t A_\mu W^-_\nu \right\rbrack
+ \textnormal{H.c.}
\end{equation} *)
let anomalous_tbWA =
if Flags.top_anom then
[ ((M (D (-3)), O (Aux_top (2,0,-1,true,TBWA)), M (U 3)), FBF (1, Psibar, TLR, Psi), G_TLR_btWA);
((O (Aux_top (2,0,1,false,TBWA)), G Ga, G Wm), Aux_Gauge_Gauge 1, I_G_weak);
((M (U (-3)), O (Aux_top (2,0,1,true,TBWA)), M (D 3)), FBF (1, Psibar, TRL, Psi), G_TRL_tbWA);
((O (Aux_top (2,0,-1,false,TBWA)), G Wp, G Ga), Aux_Gauge_Gauge 1, I_G_weak) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{tbWZ} =
- i\cos\theta_w \frac{g^2}{2\sqrt{2}} \frac{\upsilon^2}{\Lambda^2}\left\lbrack
\bar{b}\frac{\sigma^{\mu\nu}}{m_W}
(g_L(k^2)P_L+g_R(k^2)P_R)t Z_\mu W^-_\nu \right\rbrack
+ \textnormal{H.c.}
\end{equation} *)
let anomalous_tbWZ =
if Flags.top_anom then
[ ((M (D (-3)), O (Aux_top (2,0,-1,true,TBWZ)), M (U 3)), FBF (1, Psibar, TLR, Psi), G_TLR_btWZ);
((O (Aux_top (2,0,1,false,TBWZ)), G Z, G Wm), Aux_Gauge_Gauge 1, I_G_weak);
((M (U (-3)), O (Aux_top (2,0,1,true,TBWZ)), M (D 3)), FBF (1, Psibar, TRL, Psi), G_TRL_tbWZ);
((O (Aux_top (2,0,-1,false,TBWZ)), G Wp, G Z), Aux_Gauge_Gauge 1, I_G_weak) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{ttWW} =
- i \frac{g^2}{2} \frac{\upsilon^2}{\Lambda^2}
\bar{t} \frac{\sigma^{\mu\nu}}{m_W}
(d_V(k^2)+id_A(k^2)\gamma_5)t W^-_\mu W^+_\nu
\end{equation} *)
let anomalous_ttWW =
if Flags.top_anom then
[ ((M (U (-3)), O (Aux_top (2,0,0,true,TTWW)), M (U 3)), FBF (1, Psibar, TVA, Psi), G_TVA_ttWW);
((O (Aux_top (2,0,0,false,TTWW)), G Wm, G Wp), Aux_Gauge_Gauge 1, I_G_weak) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{bbWW} =
- i \frac{g^2}{2} \frac{\upsilon^2}{\Lambda^2}
\bar{b} \frac{\sigma^{\mu\nu}}{m_W}
(d_V(k^2)+id_A(k^2)\gamma_5)b W^-_\mu W^+_\nu
\end{equation} *)
let anomalous_bbWW =
if Flags.top_anom then
[ ((M (D (-3)), O (Aux_top (2,0,0,true,BBWW)), M (D 3)), FBF (1, Psibar, TVA, Psi), G_TVA_bbWW);
((O (Aux_top (2,0,0,false,BBWW)), G Wm, G Wp), Aux_Gauge_Gauge 1, I_G_weak) ]
else
[]
(* 4-fermion contact terms emerging from operator rewriting: *)
let anomalous_top_qGuG_tt =
[ ((M (U (-3)), O (Aux_top (1,1,0,true,QGUG)), M (U 3)), FBF (1, Psibar, VLR, Psi), G_VLR_qGuG) ]
let anomalous_top_qGuG_ff n =
List.map mom
[ ((U (-n), Aux_top (1,1,0,false,QGUG), U n), FBF (1, Psibar, V, Psi), Unit);
((D (-n), Aux_top (1,1,0,false,QGUG), D n), FBF (1, Psibar, V, Psi), Unit) ]
let anomalous_top_qGuG =
if Flags.top_anom_4f then
anomalous_top_qGuG_tt @ ThoList.flatmap anomalous_top_qGuG_ff [1;2;3]
else
[]
let anomalous_top_qBuB_tt =
[ ((M (U (-3)), O (Aux_top (1,0,0,true,QBUB)), M (U 3)), FBF (1, Psibar, VLR, Psi), G_VLR_qBuB) ]
let anomalous_top_qBuB_ff n =
List.map mom
[ ((U (-n), Aux_top (1,0,0,false,QBUB), U n), FBF (1, Psibar, VLR, Psi), G_VLR_qBuB_u);
((D (-n), Aux_top (1,0,0,false,QBUB), D n), FBF (1, Psibar, VLR, Psi), G_VLR_qBuB_d);
((L (-n), Aux_top (1,0,0,false,QBUB), L n), FBF (1, Psibar, VLR, Psi), G_VLR_qBuB_e);
((N (-n), Aux_top (1,0,0,false,QBUB), N n), FBF (1, Psibar, VL, Psi), G_VL_qBuB_n) ]
let anomalous_top_qBuB =
if Flags.top_anom_4f then
anomalous_top_qBuB_tt @ ThoList.flatmap anomalous_top_qBuB_ff [1;2;3]
else
[]
let anomalous_top_qW_tq =
[ ((M (U (-3)), O (Aux_top (1,0,0,true,QW)), M (U 3)), FBF (1, Psibar, VL, Psi), G_VL_qW);
((M (D (-3)), O (Aux_top (1,0,-1,true,QW)), M (U 3)), FBF (1, Psibar, VL, Psi), G_VL_qW);
((M (U (-3)), O (Aux_top (1,0,1,true,QW)), M (D 3)), FBF (1, Psibar, VL, Psi), G_VL_qW) ]
let anomalous_top_qW_ff n =
List.map mom
[ ((U (-n), Aux_top (1,0,0,false,QW), U n), FBF (1, Psibar, VL, Psi), G_VL_qW_u);
((D (-n), Aux_top (1,0,0,false,QW), D n), FBF (1, Psibar, VL, Psi), G_VL_qW_d);
((N (-n), Aux_top (1,0,0,false,QW), N n), FBF (1, Psibar, VL, Psi), G_VL_qW_u);
((L (-n), Aux_top (1,0,0,false,QW), L n), FBF (1, Psibar, VL, Psi), G_VL_qW_d);
((D (-n), Aux_top (1,0,-1,false,QW), U n), FBF (1, Psibar, VL, Psi), Half);
((U (-n), Aux_top (1,0,1,false,QW), D n), FBF (1, Psibar, VL, Psi), Half);
((L (-n), Aux_top (1,0,-1,false,QW), N n), FBF (1, Psibar, VL, Psi), Half);
((N (-n), Aux_top (1,0,1,false,QW), L n), FBF (1, Psibar, VL, Psi), Half) ]
let anomalous_top_qW =
if Flags.top_anom_4f then
anomalous_top_qW_tq @ ThoList.flatmap anomalous_top_qW_ff [1;2;3]
else
[]
let anomalous_top_DuDd =
if Flags.top_anom_4f then
[ ((M (U (-3)), O (Aux_top (0,0,0,true,DR)), M (U 3)), FBF (1, Psibar, SR, Psi), Half);
((M (U (-3)), O (Aux_top (0,0,0,false,DR)), M (U 3)), FBF (1, Psibar, SL, Psi), G_SL_DttR);
((M (D (-3)), O (Aux_top (0,0,0,false,DR)), M (D 3)), FBF (1, Psibar, SR, Psi), G_SR_DttR);
((M (U (-3)), O (Aux_top (0,0,0,true,DL)), M (U 3)), FBF (1, Psibar, SL, Psi), Half);
((M (D (-3)), O (Aux_top (0,0,0,false,DL)), M (D 3)), FBF (1, Psibar, SL, Psi), G_SL_DttL);
((M (D (-3)), O (Aux_top (0,0,-1,true,DR)), M (U 3)), FBF (1, Psibar, SR, Psi), Half);
((M (U (-3)), O (Aux_top (0,0,1,false,DR)), M (D 3)), FBF (1, Psibar, SLR, Psi), G_SLR_DbtR);
((M (D (-3)), O (Aux_top (0,0,-1,true,DL)), M (U 3)), FBF (1, Psibar, SL, Psi), Half);
((M (U (-3)), O (Aux_top (0,0,1,false,DL)), M (D 3)), FBF (1, Psibar, SL, Psi), G_SL_DbtL) ]
else
[]
let vertices3 =
(ThoList.flatmap electromagnetic_currents [1;2;3] @
ThoList.flatmap color_currents [1;2;3] @
ThoList.flatmap neutral_currents [1;2;3] @
(if Flags.ckm_present then
charged_currents_ckm
else
charged_currents_triv) @
yukawa @ triple_gauge @
gauge_higgs @ higgs @ higgs_triangle_vertices
@ goldstone_vertices @
rsigma3 @ rsigma3t @ rphi3 @
( if Flags.cf_arbitrary then
( rt3cf @ rff3cf @
rfv3cf @ rfphi3cf @ rfddphi3cf )
else
(rf3 @ rt3 ) ) @
rf3t @
( if Flags.higgs_matrix then
(rsigma3h @ rff3h )
else
[] ) @
anomalous_ttA @ anomalous_bbA @
anomalous_ttZ @ anomalous_bbZ @
anomalous_tbW @ anomalous_tbWA @ anomalous_tbWZ @
anomalous_ttWW @ anomalous_bbWW @
anomalous_ttG @ anomalous_ttGG @
anomalous_ttH @
anomalous_top_qGuG @ anomalous_top_qBuB @
anomalous_top_qW @ anomalous_top_DuDd)
let vertices4 =
quartic_gauge @ gauge_higgs4 @ higgs4
let vertices () = (vertices3, vertices4, [])
(* For efficiency, make sure that [F.of_vertices vertices] is
evaluated only once. *)
let table = F.of_vertices (vertices ())
let fuse2 = F.fuse2 table
let fuse3 = F.fuse3 table
let fuse = F.fuse table
let max_degree () = 4
let flavor_of_string = function
| "e-" -> M (L 1) | "e+" -> M (L (-1))
| "mu-" -> M (L 2) | "mu+" -> M (L (-2))
| "tau-" -> M (L 3) | "tau+" -> M (L (-3))
| "nue" -> M (N 1) | "nuebar" -> M (N (-1))
| "numu" -> M (N 2) | "numubar" -> M (N (-2))
| "nutau" -> M (N 3) | "nutaubar" -> M (N (-3))
| "u" -> M (U 1) | "ubar" -> M (U (-1))
| "c" -> M (U 2) | "cbar" -> M (U (-2))
| "t" -> M (U 3) | "tbar" -> M (U (-3))
| "d" -> M (D 1) | "dbar" -> M (D (-1))
| "s" -> M (D 2) | "sbar" -> M (D (-2))
| "b" -> M (D 3) | "bbar" -> M (D (-3))
| "g" | "gl" -> G Gl
| "A" -> G Ga | "Z" | "Z0" -> G Z
| "W+" -> G Wp | "W-" -> G Wm
| "H" -> O H | "Rsigma" -> O Rsigma
| "Rphi0" -> O Rphin
| "Rphis0" -> O Rphisn
| "Rphi+" -> O Rphip | "Rphi-" -> O Rphim
| "Rphi++" -> O Rphip | "Rphi--" -> O Rphimm
| "Rf" -> O Rf
| "Rff" -> O Rff
| "Rfv" -> O Rfv
| "Rfphi" -> O Rfphi
| "Rt0" -> O Rtn
| "Rts0" -> O Rtsn
| "Rt+" -> O Rtp | "Rt-" -> O Rtm
| "Rt++" -> O Rtp | "Rt--" -> O Rtmm
| "Aux_t_ttGG0" -> O (Aux_top (2,1, 0,true,TTGG)) | "Aux_ttGG0" -> O (Aux_top (2,1, 0,false,TTGG))
| "Aux_t_tbWA+" -> O (Aux_top (2,0, 1,true,TBWA)) | "Aux_tbWA+" -> O (Aux_top (2,0, 1,false,TBWA))
| "Aux_t_tbWA-" -> O (Aux_top (2,0,-1,true,TBWA)) | "Aux_tbWA-" -> O (Aux_top (2,0,-1,false,TBWA))
| "Aux_t_tbWZ+" -> O (Aux_top (2,0, 1,true,TBWZ)) | "Aux_tbWZ+" -> O (Aux_top (2,0, 1,false,TBWZ))
| "Aux_t_tbWZ-" -> O (Aux_top (2,0,-1,true,TBWZ)) | "Aux_tbWZ-" -> O (Aux_top (2,0,-1,false,TBWZ))
| "Aux_t_ttWW0" -> O (Aux_top (2,0, 0,true,TTWW)) | "Aux_ttWW0" -> O (Aux_top (2,0, 0,false,TTWW))
| "Aux_t_bbWW0" -> O (Aux_top (2,0, 0,true,BBWW)) | "Aux_bbWW0" -> O (Aux_top (2,0, 0,false,BBWW))
| "Aux_t_qGuG0" -> O (Aux_top (1,1, 0,true,QGUG)) | "Aux_qGuG0" -> O (Aux_top (1,1, 0,false,QGUG))
| "Aux_t_qBuB0" -> O (Aux_top (1,0, 0,true,QBUB)) | "Aux_qBuB0" -> O (Aux_top (1,0, 0,false,QBUB))
| "Aux_t_qW0" -> O (Aux_top (1,0, 0,true,QW)) | "Aux_qW0" -> O (Aux_top (1,0, 0,false,QW))
| "Aux_t_qW+" -> O (Aux_top (1,0, 1,true,QW)) | "Aux_qW+" -> O (Aux_top (1,0, 1,false,QW))
| "Aux_t_qW-" -> O (Aux_top (1,0,-1,true,QW)) | "Aux_qW-" -> O (Aux_top (1,0,-1,false,QW))
| "Aux_t_dL0" -> O (Aux_top (0,0, 0,true,DL)) | "Aux_dL0" -> O (Aux_top (0,0, 0,false,DL))
| "Aux_t_dL+" -> O (Aux_top (0,0, 1,true,DL)) | "Aux_dL+" -> O (Aux_top (0,0, 1,false,DL))
| "Aux_t_dL-" -> O (Aux_top (0,0,-1,true,DL)) | "Aux_dL-" -> O (Aux_top (0,0,-1,false,DL))
| "Aux_t_dR0" -> O (Aux_top (0,0, 0,true,DR)) | "Aux_dR0" -> O (Aux_top (0,0, 0,false,DR))
| "Aux_t_dR+" -> O (Aux_top (0,0, 1,true,DR)) | "Aux_dR+" -> O (Aux_top (0,0, 1,false,DR))
| "Aux_t_dR-" -> O (Aux_top (0,0,-1,true,DR)) | "Aux_dR-" -> O (Aux_top (0,0,-1,false,DR))
| _ -> invalid_arg "Modellib_BSM.SSC_AltT.flavor_of_string"
let flavor_to_string = function
| M f ->
begin match f with
| L 1 -> "e-" | L (-1) -> "e+"
| L 2 -> "mu-" | L (-2) -> "mu+"
| L 3 -> "tau-" | L (-3) -> "tau+"
| L _ -> invalid_arg
"Modellib_BSM.SSC_AltT.flavor_to_string: invalid lepton"
| N 1 -> "nue" | N (-1) -> "nuebar"
| N 2 -> "numu" | N (-2) -> "numubar"
| N 3 -> "nutau" | N (-3) -> "nutaubar"
| N _ -> invalid_arg
"Modellib_BSM.SSC_AltT.flavor_to_string: invalid neutrino"
| U 1 -> "u" | U (-1) -> "ubar"
| U 2 -> "c" | U (-2) -> "cbar"
| U 3 -> "t" | U (-3) -> "tbar"
| U _ -> invalid_arg
"Modellib_BSM.SSC_AltT.flavor_to_string: invalid up type quark"
| D 1 -> "d" | D (-1) -> "dbar"
| D 2 -> "s" | D (-2) -> "sbar"
| D 3 -> "b" | D (-3) -> "bbar"
| D _ -> invalid_arg
"Modellib_BSM.SSC_AltT.flavor_to_string: invalid down type quark"
end
| G f ->
begin match f with
| Gl -> "gl"
| Ga -> "A" | Z -> "Z"
| Wp -> "W+" | Wm -> "W-"
end
| O f ->
begin match f with
| Phip -> "phi+" | Phim -> "phi-" | Phi0 -> "phi0"
| H -> "H" | Rsigma -> "Rsigma"
| Rphin -> "Rphin" | Rphip -> "Rphi+" | Rphim -> "Rphi-"
| Rphipp -> "Rphi++" | Rphimm -> "Rphi--"
| Rphisn -> "Rphisn"
| Rf -> "Rf"
| Rff -> "Rff" | Rfv -> "Rfv" | Rfphi -> "Rfphi"
| Rtn -> "Rtn" | Rtsn -> "Rtsn" | Rtp -> "Rt+" | Rtm -> "Rt-"
| Rtpp -> "Rt++" | Rtmm -> "Rt--"
| Aux_top (_,_,ch,n,v) -> "Aux_" ^ (if n then "t_" else "") ^ (
begin match v with
| TTGG -> "ttGG" | TBWA -> "tbWA" | TBWZ -> "tbWZ"
| TTWW -> "ttWW" | BBWW -> "bbWW"
| QGUG -> "qGuG" | QBUB -> "qBuB"
| QW -> "qW" | DL -> "dL" | DR -> "dR"
end ) ^ ( if ch > 0 then "+" else if ch < 0 then "-" else "0" )
end
let flavor_to_TeX = function
| M f ->
begin match f with
| L 1 -> "e^-" | L (-1) -> "e^+"
| L 2 -> "\\mu^-" | L (-2) -> "\\mu^+"
| L 3 -> "\\tau^-" | L (-3) -> "\\tau^+"
| L _ -> invalid_arg
"Modellib_BSM.SSC_AltT.flavor_to_TeX: invalid lepton"
| N 1 -> "\\nu_e" | N (-1) -> "\\bar{\\nu}_e"
| N 2 -> "\\nu_\\mu" | N (-2) -> "\\bar{\\nu}_\\mu"
| N 3 -> "\\nu_\\tau" | N (-3) -> "\\bar{\\nu}_\\tau"
| N _ -> invalid_arg
"Modellib_BSM.SSC_AltT.flavor_to_TeX: invalid neutrino"
| U 1 -> "u" | U (-1) -> "\\bar{u}"
| U 2 -> "c" | U (-2) -> "\\bar{c}"
| U 3 -> "t" | U (-3) -> "\\bar{t}"
| U _ -> invalid_arg
"Modellib_BSM.SSC_AltT.flavor_to_TeX: invalid up type quark"
| D 1 -> "d" | D (-1) -> "\\bar{d}"
| D 2 -> "s" | D (-2) -> "\\bar{s}"
| D 3 -> "b" | D (-3) -> "\\bar{b}"
| D _ -> invalid_arg
"Modellib_BSM.SSC_AltT.flavor_to_TeX: invalid down type quark"
end
| G f ->
begin match f with
| Gl -> "g"
| Ga -> "\\gamma" | Z -> "Z"
| Wp -> "W^+" | Wm -> "W^-"
end
| O f ->
begin match f with
| Phip -> "\\phi^+" | Phim -> "\\phi^-" | Phi0 -> "\\phi^0"
| H -> "H" | Rsigma -> "\\sigma"
| Rphip -> "\\phi^+" | Rphim -> "\\phi^-" | Rphin -> "\\phi^0"
| Rphisn -> "\\phi_s^0"
| Rphipp -> "\\phi^{++}" | Rphimm -> "\\phi^{--}"
| Rf -> "f"
| Rff -> "f^f" | Rfv -> "f^v" | Rfphi -> "f^s"
| Rtp -> "t^+" | Rtm -> "t^-" | Rtn -> "t^0" | Rtsn -> "t_s^0"
| Rtpp -> "t^{++}" | Rtmm -> "t^{--}"
| Aux_top (_,_,ch,n,v) -> "\\textnormal{Aux_" ^ (if n then "t_" else "") ^ (
begin match v with
| TTGG -> "ttGG" | TBWA -> "tbWA" | TBWZ -> "tbWZ"
| TTWW -> "ttWW" | BBWW -> "bbWW"
| QGUG -> "qGuG" | QBUB -> "qBuB"
| QW -> "qW" | DL -> "dL" | DR -> "dR"
end ) ^ ( if ch > 0 then "^+" else if ch < 0 then "^-" else "^0" ) ^ "}"
end
let flavor_symbol = function
| M f ->
begin match f with
| L n when n > 0 -> "l" ^ string_of_int n
| L n -> "l" ^ string_of_int (abs n) ^ "b"
| N n when n > 0 -> "n" ^ string_of_int n
| N n -> "n" ^ string_of_int (abs n) ^ "b"
| U n when n > 0 -> "u" ^ string_of_int n
| U n -> "u" ^ string_of_int (abs n) ^ "b"
| D n when n > 0 -> "d" ^ string_of_int n
| D n -> "d" ^ string_of_int (abs n) ^ "b"
end
| G f ->
begin match f with
| Gl -> "gl"
| Ga -> "a" | Z -> "z"
| Wp -> "wp" | Wm -> "wm"
end
| O f ->
begin match f with
| Phip -> "pp" | Phim -> "pm" | Phi0 -> "p0"
| H -> "h" | Rsigma -> "rsi"
| Rphip -> "rpp" | Rphim -> "rpm" | Rphin -> "rpn"
| Rphisn -> "rpsn"
| Rphipp -> "rppp" | Rphimm -> "rpmm"
| Rf -> "rf"
| Rff -> "rff" | Rfv -> "rfv" | Rfphi -> "rfphi"
| Rtp -> "rtp" | Rtm -> "rtm" | Rtn -> "rtn"
| Rtsn -> "rtsn"
| Rtpp -> "rtpp" | Rtmm -> "rtmm"
| Aux_top (_,_,ch,n,v) -> "aux_" ^ (if n then "t_" else "") ^ (
begin match v with
| TTGG -> "ttgg" | TBWA -> "tbwa" | TBWZ -> "tbwz"
| TTWW -> "ttww" | BBWW -> "bbww"
| QGUG -> "qgug" | QBUB -> "qbub"
| QW -> "qw" | DL -> "dl" | DR -> "dr"
end ) ^ "_" ^ ( if ch > 0 then "p" else if ch < 0 then "m" else "0" )
end
(* Introducing new Resonances from 45, there are no PDG values *)
let pdg = function
| M f ->
begin match f with
| L n when n > 0 -> 9 + 2*n
| L n -> - 9 + 2*n
| N n when n > 0 -> 10 + 2*n
| N n -> - 10 + 2*n
| U n when n > 0 -> 2*n
| U n -> 2*n
| D n when n > 0 -> - 1 + 2*n
| D n -> 1 + 2*n
end
| G f ->
begin match f with
| Gl -> 21
| Ga -> 22 | Z -> 23
| Wp -> 24 | Wm -> (-24)
end
| O f ->
begin match f with
| Phip | Phim -> 27 | Phi0 -> 26
| H -> 25 | Rsigma -> 45
| Rphin -> 46 | Rphip | Rphim -> 47
| Rphipp | Rphimm -> 48
| Rphisn -> 49
| Rf -> 52
| Rtn -> 53 | Rtp | Rtm -> 54
| Rtpp | Rtmm -> 55
| Rff -> 56 | Rfv -> 57 | Rfphi -> 58
| Rtsn -> 59
| Aux_top (_,_,_,_,_) -> 81
end
let mass_symbol f =
"mass(" ^ string_of_int (abs (pdg f)) ^ ")"
let width_symbol f =
"width(" ^ string_of_int (abs (pdg f)) ^ ")"
let constant_symbol = function
| Unit -> "unit" | Half -> "half" | Pi -> "PI"
| Alpha_QED -> "alpha" | E -> "e" | G_weak -> "g" | Vev -> "vev"
| I_G_weak -> "ig"
| Sin2thw -> "sin2thw" | Sinthw -> "sinthw" | Costhw -> "costhw"
| Q_lepton -> "qlep" | Q_up -> "qup" | Q_down -> "qdwn"
| G_NC_lepton -> "gnclep" | G_NC_neutrino -> "gncneu"
| G_NC_up -> "gncup" | G_NC_down -> "gncdwn"
| G_TVA_ttA -> "gtva_tta" | G_TVA_bbA -> "gtva_bba"
| G_VLR_ttZ -> "gvlr_ttz" | G_TVA_ttZ -> "gtva_ttz" | G_TVA_bbZ -> "gtva_bbz"
| G_VLR_btW -> "gvlr_btw" | G_VLR_tbW -> "gvlr_tbw"
| G_TLR_btW -> "gtlr_btw" | G_TRL_tbW -> "gtrl_tbw"
| G_TLR_btWA -> "gtlr_btwa" | G_TRL_tbWA -> "gtrl_tbwa"
| G_TLR_btWZ -> "gtlr_btwz" | G_TRL_tbWZ -> "gtrl_tbwz"
| G_TVA_ttWW -> "gtva_ttww" | G_TVA_bbWW -> "gtva_bbww"
| G_TVA_ttG -> "gtva_ttg" | G_TVA_ttGG -> "gtva_ttgg"
| G_SP_ttH -> "gsp_tth"
| G_VLR_qGuG -> "gvlr_qgug"
| G_VLR_qBuB -> "gvlr_qbub"
| G_VLR_qBuB_u -> "gvlr_qbub_u" | G_VLR_qBuB_d -> "gvlr_qbub_d"
| G_VLR_qBuB_e -> "gvlr_qbub_e" | G_VL_qBuB_n -> "gvl_qbub_n"
| G_VL_qW -> "gvl_qw"
| G_VL_qW_u -> "gvl_qw_u" | G_VL_qW_d -> "gvl_qw_d"
| G_SL_DttR -> "gsl_dttr" | G_SR_DttR -> "gsr_dttr" | G_SL_DttL -> "gsl_dttl"
| G_SLR_DbtR -> "gslr_dbtr" | G_SL_DbtL -> "gsl_dbtl"
| G_CC -> "gcc"
| G_CCQ (n1,n2) -> "gccq" ^ string_of_int n1 ^ string_of_int n2
| I_Q_W -> "iqw" | I_G_ZWW -> "igzww"
| G_WWWW -> "gw4" | G_ZZWW -> "gzzww"
| G_AZWW -> "gazww" | G_AAWW -> "gaaww"
| I_G1_AWW -> "ig1a" | I_G1_ZWW -> "ig1z"
| I_G1_plus_kappa_plus_G4_AWW -> "ig1pkpg4a"
| I_G1_plus_kappa_plus_G4_ZWW -> "ig1pkpg4z"
| I_G1_plus_kappa_minus_G4_AWW -> "ig1pkmg4a"
| I_G1_plus_kappa_minus_G4_ZWW -> "ig1pkmg4z"
| I_G1_minus_kappa_plus_G4_AWW -> "ig1mkpg4a"
| I_G1_minus_kappa_plus_G4_ZWW -> "ig1mkpg4z"
| I_G1_minus_kappa_minus_G4_AWW -> "ig1mkmg4a"
| I_G1_minus_kappa_minus_G4_ZWW -> "ig1mkmg4z"
| I_lambda_AWW -> "ila"
| I_lambda_ZWW -> "ilz"
| G5_AWW -> "rg5a"
| G5_ZWW -> "rg5z"
| I_kappa5_AWW -> "ik5a"
| I_kappa5_ZWW -> "ik5z"
| I_lambda5_AWW -> "il5a" | I_lambda5_ZWW -> "il5z"
| Alpha_WWWW0 -> "alww0" | Alpha_WWWW2 -> "alww2"
| Alpha_ZZWW0 -> "alzw0" | Alpha_ZZWW1 -> "alzw1"
| Alpha_ZZZZ -> "alzz"
| FT0_WWWW0 -> "at0ww0" | FT0_WWWW2 -> "at0ww2"
| FT0_ZZWW0 -> "at0zw0" | FT0_ZZWW1 -> "at0zw1"
| FT0_ZZZZ -> "at0zz" | FT0_AAAA -> "at0aa"
| FT0_AAWW0 -> "at0aw0" | FT0_AAWW1 -> "at0aw1"
| FT0_AAZZ -> "at0az"
| FT0_AZWW0 -> "at0azw0" | FT0_AZWW1 -> "at0azw1"
| FT0_AAAZ -> "at03az" | FT0_AZZZ -> "at0a3z"
| FT1_WWWW0 -> "at1ww0" | FT1_WWWW2 -> "at1ww2"
| FT1_ZZWW0 -> "at1zw0" | FT1_ZZWW1 -> "at1zw1"
| FT1_ZZZZ -> "at1zz" | FT1_AAAA -> "at1aa"
| FT1_AAWW0 -> "at1aw0" | FT1_AAWW1 -> "at1aw1"
| FT1_AAZZ -> "at1az"
| FT1_AZWW0 -> "at1azw0" | FT1_AZWW1 -> "at1azw1"
| FT1_AAAZ -> "at13az" | FT1_AZZZ -> "at1a3z"
| FT2_WWWW0 -> "at2ww0" | FT2_WWWW2 -> "at2ww2"
| FT2_ZZWW0 -> "at2zw0" | FT2_ZZWW1 -> "at2zw1"
| FT2_ZZZZ -> "at2zz" | FT2_AAAA -> "at2aa"
| FT2_AAWW0 -> "at2aw0" | FT2_AAWW1 -> "at2aw1"
| FT2_AAZZ -> "at2az"
| FT2_AZWW0 -> "at2azw0" | FT2_AZWW1 -> "at2azw1"
| FT2_AAAZ -> "at23az" | FT2_AZZZ -> "at2a3z"
| FM0_WWWW0 -> "am0ww0,am0ww0" | FM0_WWWW2 -> "am0ww2,am0ww2"
| FM0_ZZWW0 -> "am0zw0/costhw**2,am0zw0*costhw**2" | FM0_ZZWW1 -> "am0zw1/costhw**2,am0zw1*costhw**2"
| FM0_ZZZZ -> "am0zz,am0zz"
| FM1_WWWW0 -> "am1ww0,am1ww0" | FM1_WWWW2 -> "am1ww2,am1ww2"
| FM1_ZZWW0 -> "am1zw0/costhw**2,am1zw0*costhw**2" | FM1_ZZWW1 -> "am1zw1/costhw**2,am1zw1*costhw**2"
| FM1_ZZZZ -> "am1zz,am1zz"
| FM7_WWWW0 -> "am7ww0,am7ww0,am7ww0" | FM7_WWWW2 -> "am7ww2,am7ww2,am7ww2"
| FM7_ZZWW0 -> "am7zw0/costhw**2,am7zw0,am7zw0*costhw**2" | FM7_ZZWW1 -> "am7zw1/costhw**2,am7zw1,am7zw1*costhw**2"
| FM7_ZZZZ -> "am7zz,am7zz,am7zz"
| FS0_HHWW -> "fs0hhww" | FS0_HHZZ -> "fs0hhzz"
| FS1_HHWW -> "fs1hhww" | FS1_HHZZ -> "fs1hhzz"
| FS_H4 -> "fsh4"
| FM0_HHWW -> "fm0hhww" | FM0_HHZZ -> "fm0hhzz"
| FM1_HHWW -> "fm1hhww" | FM1_HHZZ -> "fm1hhzz"
| FM7_HHWW -> "fm7hhww" | FM7_HHZZ -> "fm7hhzz"
| D_Alpha_ZZWW0_S -> "dalzz0_s(gkm,mkm,"
| D_Alpha_ZZWW0_T -> "dalzz0_t(gkm,mkm,"
| D_Alpha_ZZWW1_S -> "dalzz1_s(gkm,mkm,"
| D_Alpha_ZZWW1_T -> "dalzz1_t(gkm,mkm,"
| D_Alpha_ZZWW1_U -> "dalzz1_u(gkm,mkm,"
| D_Alpha_WWWW0_S -> "dalww0_s(gkm,mkm,"
| D_Alpha_WWWW0_T -> "dalww0_t(gkm,mkm,"
| D_Alpha_WWWW0_U -> "dalww0_u(gkm,mkm,"
| D_Alpha_WWWW2_S -> "dalww2_s(gkm,mkm,"
| D_Alpha_WWWW2_T -> "dalww2_t(gkm,mkm,"
| D_Alpha_ZZZZ_S -> "dalz4_s(gkm,mkm,"
| D_Alpha_ZZZZ_T -> "dalz4_t(gkm,mkm,"
| D_FT0_ZZWW0_S -> "datzz0_s_0(gkm,mkm,"
| D_FT0_ZZWW0_T -> "datzz0_t_0(gkm,mkm,"
| D_FT0_ZZWW0_U -> "datzz0_u_0(gkm,mkm,"
| D_FT0_ZZWW1_S -> "datzz1_s_0(gkm,mkm,"
| D_FT0_ZZWW1_T -> "datzz1_t_0(gkm,mkm,"
| D_FT0_ZZWW1_U -> "datzz1_u_0(gkm,mkm,"
| D_FT0_WWWW0_S -> "datww0_s_0(gkm,mkm,"
| D_FT0_WWWW0_T -> "datww0_t_0(gkm,mkm,"
| D_FT0_WWWW0_U -> "datww0_u_0(gkm,mkm,"
| D_FT0_WWWW2_S -> "datww2_s_0(gkm,mkm,"
| D_FT0_WWWW2_T -> "datww2_t_0(gkm,mkm,"
| D_FT0_WWWW2_U -> "datww2_u_0(gkm,mkm,"
| D_FT0_ZZZZ_S -> "datz4_s_0(gkm,mkm,"
| D_FT0_ZZZZ_T -> "datz4_t_0(gkm,mkm,"
| D_FT0_ZZZZ_U -> "datz4_u_0(gkm,mkm,"
| D_FT0_AAAA_S -> "data4_s_0(gkm,mkm,"
| D_FT0_AAAA_T -> "data4_t_0(gkm,mkm,"
| D_FT0_AAAA_U -> "data4_u_0(gkm,mkm,"
| D_FT0_AAWW0_S -> "dataw0_s_0(gkm,mkm,"
| D_FT0_AAWW0_T -> "dataw0_t_0(gkm,mkm,"
| D_FT0_AAWW0_U -> "dataw0_u_0(gkm,mkm,"
| D_FT0_AAWW1_S -> "dataw1_s_0(gkm,mkm,"
| D_FT0_AAWW1_T -> "dataw1_t_0(gkm,mkm,"
| D_FT0_AAWW1_U -> "dataw1_u_0(gkm,mkm,"
| D_FT0_AAZZ_S -> "dataz_s_0(gkm,mkm,"
| D_FT0_AAZZ_T -> "dataz_t_0(gkm,mkm,"
| D_FT0_AAZZ_U -> "dataz_u_0(gkm,mkm,"
| D_FT0_AZWW0_S -> "datazw0_s_0(gkm,mkm,"
| D_FT0_AZWW0_T -> "datazw0_t_0(gkm,mkm,"
| D_FT0_AZWW0_U -> "datazw0_u_0(gkm,mkm,"
| D_FT0_AZWW1_S -> "datazw0_s_1(gkm,mkm,"
| D_FT0_AZWW1_T -> "datazw0_t_1(gkm,mkm,"
| D_FT0_AZWW1_U -> "datazw0_u_1(gkm,mkm,"
| D_FT0_AAAZ_S -> "dat3az_s_0(gkm,mkm,"
| D_FT0_AAAZ_T -> "dat3az_t_0(gkm,mkm,"
| D_FT0_AAAZ_U -> "dat3az_u_0(gkm,mkm,"
| D_FT0_AZZZ_S -> "data3z_s_0(gkm,mkm,"
| D_FT0_AZZZ_T -> "data3z_t_0(gkm,mkm,"
| D_FT0_AZZZ_U -> "data3z_u_0(gkm,mkm,"
| D_FT1_ZZWW0_S -> "datzz0_s_1(gkm,mkm,"
| D_FT1_ZZWW0_T -> "datzz0_t_1(gkm,mkm,"
| D_FT1_ZZWW0_U -> "datzz0_u_1(gkm,mkm,"
| D_FT1_ZZWW1_S -> "datzz1_s_1(gkm,mkm,"
| D_FT1_ZZWW1_T -> "datzz1_t_1(gkm,mkm,"
| D_FT1_ZZWW1_U -> "datzz1_u_1(gkm,mkm,"
| D_FT1_WWWW0_S -> "datww0_s_1(gkm,mkm,"
| D_FT1_WWWW0_T -> "datww0_t_1(gkm,mkm,"
| D_FT1_WWWW0_U -> "datww0_u_1(gkm,mkm,"
| D_FT1_WWWW2_S -> "datww2_s_1(gkm,mkm,"
| D_FT1_WWWW2_T -> "datww2_t_1(gkm,mkm,"
| D_FT1_WWWW2_U -> "datww2_u_1(gkm,mkm,"
| D_FT1_ZZZZ_S -> "datz4_s_1(gkm,mkm,"
| D_FT1_ZZZZ_T -> "datz4_t_1(gkm,mkm,"
| D_FT1_ZZZZ_U -> "datz4_u_1(gkm,mkm,"
| D_FT1_AAAA_S -> "data4_s_1(gkm,mkm,"
| D_FT1_AAAA_T -> "data4_t_1(gkm,mkm,"
| D_FT1_AAAA_U -> "data4_u_1(gkm,mkm,"
| D_FT1_AAWW0_S -> "dataw0_s_1(gkm,mkm,"
| D_FT1_AAWW0_T -> "dataw0_t_1(gkm,mkm,"
| D_FT1_AAWW0_U -> "dataw0_u_1(gkm,mkm,"
| D_FT1_AAWW1_S -> "dataw1_s_1(gkm,mkm,"
| D_FT1_AAWW1_T -> "dataw1_t_1(gkm,mkm,"
| D_FT1_AAWW1_U -> "dataw1_u_1(gkm,mkm,"
| D_FT1_AAZZ_S -> "dataz_s_1(gkm,mkm,"
| D_FT1_AAZZ_T -> "dataz_t_1(gkm,mkm,"
| D_FT1_AAZZ_U -> "dataz_u_1(gkm,mkm,"
| D_FT1_AZWW0_S -> "datazw0_s_1(gkm,mkm,"
| D_FT1_AZWW0_T -> "datazw0_t_1(gkm,mkm,"
| D_FT1_AZWW0_U -> "datazw0_u_1(gkm,mkm,"
| D_FT1_AZWW1_S -> "datazw1_s_1(gkm,mkm,"
| D_FT1_AZWW1_T -> "datazw1_t_1(gkm,mkm,"
| D_FT1_AZWW1_U -> "datazw1_u_1(gkm,mkm,"
| D_FT1_AAAZ_S -> "dat3az_s_1(gkm,mkm,"
| D_FT1_AAAZ_T -> "dat3az_t_1(gkm,mkm,"
| D_FT1_AAAZ_U -> "dat3az_u_1(gkm,mkm,"
| D_FT1_AZZZ_S -> "data3z_s_1(gkm,mkm,"
| D_FT1_AZZZ_T -> "data3z_t_1(gkm,mkm,"
| D_FT1_AZZZ_U -> "data3z_u_1(gkm,mkm,"
| D_FT2_ZZWW0_S -> "datzz0_s_2(gkm,mkm,"
| D_FT2_ZZWW0_T -> "datzz0_t_2(gkm,mkm,"
| D_FT2_ZZWW0_U -> "datzz0_u_2(gkm,mkm,"
| D_FT2_ZZWW1_S -> "datzz1_s_2(gkm,mkm,"
| D_FT2_ZZWW1_T -> "datzz1_t_2(gkm,mkm,"
| D_FT2_ZZWW1_U -> "datzz1_u_2(gkm,mkm,"
| D_FT2_WWWW0_S -> "datww0_s_2(gkm,mkm,"
| D_FT2_WWWW0_T -> "datww0_t_2(gkm,mkm,"
| D_FT2_WWWW0_U -> "datww0_u_2(gkm,mkm,"
| D_FT2_WWWW2_S -> "datww2_s_2(gkm,mkm,"
| D_FT2_WWWW2_T -> "datww2_t_2(gkm,mkm,"
| D_FT2_WWWW2_U -> "datww2_u_2(gkm,mkm,"
| D_FT2_ZZZZ_S -> "datz4_s_2(gkm,mkm,"
| D_FT2_ZZZZ_T -> "datz4_t_2(gkm,mkm,"
| D_FT2_ZZZZ_U -> "datz4_u_2(gkm,mkm,"
| D_FT2_AAAA_S -> "data4_s_2(gkm,mkm,"
| D_FT2_AAAA_T -> "data4_t_2(gkm,mkm,"
| D_FT2_AAAA_U -> "data4_u_2(gkm,mkm,"
| D_FT2_AAWW0_S -> "dataw0_s_2(gkm,mkm,"
| D_FT2_AAWW0_T -> "dataw0_t_2(gkm,mkm,"
| D_FT2_AAWW0_U -> "dataw0_u_2(gkm,mkm,"
| D_FT2_AAWW1_S -> "dataw1_s_2(gkm,mkm,"
| D_FT2_AAWW1_T -> "dataw1_t_2(gkm,mkm,"
| D_FT2_AAWW1_U -> "dataw1_u_2(gkm,mkm,"
| D_FT2_AAZZ_S -> "dataz_s_2(gkm,mkm,"
| D_FT2_AAZZ_T -> "dataz_t_2(gkm,mkm,"
| D_FT2_AAZZ_U -> "dataz_u_2(gkm,mkm,"
| D_FT2_AZWW0_S -> "datazw0_s_2(gkm,mkm,"
| D_FT2_AZWW0_T -> "datazw0_t_2(gkm,mkm,"
| D_FT2_AZWW0_U -> "datazw0_u_2(gkm,mkm,"
| D_FT2_AZWW1_S -> "datazw1_s_2(gkm,mkm,"
| D_FT2_AZWW1_T -> "datazw1_t_2(gkm,mkm,"
| D_FT2_AZWW1_U -> "datazw1_u_2(gkm,mkm,"
| D_FT2_AAAZ_S -> "dat3az_s_2(gkm,mkm,"
| D_FT2_AAAZ_T -> "dat3az_t_2(gkm,mkm,"
| D_FT2_AAAZ_U -> "dat3az_u_2(gkm,mkm,"
| D_FT2_AZZZ_S -> "data3z_s_2(gkm,mkm,"
| D_FT2_AZZZ_T -> "data3z_t_2(gkm,mkm,"
| D_FT2_AZZZ_U -> "data3z_u_2(gkm,mkm,"
| D_FTrsi_ZZWW0_S -> "datzz0_s_rsi(gkm,mkm,"
| D_FTrsi_ZZWW0_T -> "datzz0_t_rsi(gkm,mkm,"
| D_FTrsi_ZZWW0_U -> "datzz0_u_rsi(gkm,mkm,"
| D_FTrsi_ZZWW1_S -> "datzz1_s_rsi(gkm,mkm,"
| D_FTrsi_ZZWW1_T -> "datzz1_t_rsi(gkm,mkm,"
| D_FTrsi_ZZWW1_U -> "datzz1_u_rsi(gkm,mkm,"
| D_FTrsi_WWWW0_S -> "datww0_s_rsi(gkm,mkm,"
| D_FTrsi_WWWW0_T -> "datww0_t_rsi(gkm,mkm,"
| D_FTrsi_WWWW0_U -> "datww0_u_rsi(gkm,mkm,"
| D_FTrsi_WWWW2_S -> "datww2_s_rsi(gkm,mkm,"
| D_FTrsi_WWWW2_T -> "datww2_t_rsi(gkm,mkm,"
| D_FTrsi_WWWW2_U -> "datww2_u_rsi(gkm,mkm,"
| D_FTrsi_ZZZZ_S -> "datz4_s_rsi(gkm,mkm,"
| D_FTrsi_ZZZZ_T -> "datz4_t_rsi(gkm,mkm,"
| D_FTrsi_ZZZZ_U -> "datz4_u_rsi(gkm,mkm,"
| D_FTrsi_AAAA_S -> "data4_s_rsi(gkm,mkm,"
| D_FTrsi_AAAA_T -> "data4_t_rsi(gkm,mkm,"
| D_FTrsi_AAAA_U -> "data4_u_rsi(gkm,mkm,"
| D_FTrsi_AAWW0_S -> "dataw0_s_rsi(gkm,mkm,"
| D_FTrsi_AAWW0_T -> "dataw0_t_rsi(gkm,mkm,"
| D_FTrsi_AAWW0_U -> "dataw0_u_rsi(gkm,mkm,"
| D_FTrsi_AAWW1_S -> "dataw1_s_rsi(gkm,mkm,"
| D_FTrsi_AAWW1_T -> "dataw1_t_rsi(gkm,mkm,"
| D_FTrsi_AAWW1_U -> "dataw1_u_rsi(gkm,mkm,"
| D_FTrsi_AAZZ_S -> "dataz_s_rsi(gkm,mkm,"
| D_FTrsi_AAZZ_T -> "dataz_t_rsi(gkm,mkm,"
| D_FTrsi_AAZZ_U -> "dataz_u_rsi(gkm,mkm,"
| D_FTrsi_AZWW0_S -> "datazw0_s_rsi(gkm,mkm,"
| D_FTrsi_AZWW0_T -> "datazw0_t_rsi(gkm,mkm,"
| D_FTrsi_AZWW0_U -> "datazw0_u_rsi(gkm,mkm,"
| D_FTrsi_AZWW1_S -> "datazw1_s_rsi(gkm,mkm,"
| D_FTrsi_AZWW1_T -> "datazw1_t_rsi(gkm,mkm,"
| D_FTrsi_AZWW1_U -> "datazw1_u_rsi(gkm,mkm,"
| D_FTrsi_AAAZ_S -> "dat3az_s_rsi(gkm,mkm,"
| D_FTrsi_AAAZ_T -> "dat3az_t_rsi(gkm,mkm,"
| D_FTrsi_AAAZ_U -> "dat3az_u_rsi(gkm,mkm,"
| D_FTrsi_AZZZ_S -> "data3z_s_rsi(gkm,mkm,"
| D_FTrsi_AZZZ_T -> "data3z_t_rsi(gkm,mkm,"
| D_FTrsi_AZZZ_U -> "data3z_u_rsi(gkm,mkm,"
| D_FM0_ZZWW0_S -> "damzz0_s_0(gkm,mkm,"
| D_FM0_ZZWW0_T -> "damzz0_t_0(gkm,mkm,"
| D_FM0_ZZWW0_U -> "damzz0_u_0(gkm,mkm,"
| D_FM0_ZZWW1_S -> "damzz1_s_0(gkm,mkm,"
| D_FM0_ZZWW1_T -> "damzz1_t_0(gkm,mkm,"
| D_FM0_ZZWW1_U -> "damzz1_u_0(gkm,mkm,"
| D_FM0_WWWW0_S -> "damww0_s_0(gkm,mkm,"
| D_FM0_WWWW0_T -> "damww0_t_0(gkm,mkm,"
| D_FM0_WWWW0_U -> "damww0_u_0(gkm,mkm,"
| D_FM0_WWWW2_S -> "damww2_s_0(gkm,mkm,"
| D_FM0_WWWW2_T -> "damww2_t_0(gkm,mkm,"
| D_FM0_WWWW2_U -> "damww2_u_0(gkm,mkm,"
| D_FM0_ZZZZ_S -> "damz4_s_0(gkm,mkm,"
| D_FM0_ZZZZ_T -> "damz4_t_0(gkm,mkm,"
| D_FM0_ZZZZ_U -> "damz4_u_0(gkm,mkm,"
| D_FM1_ZZWW0_S -> "damzz0_s_1(gkm,mkm,"
| D_FM1_ZZWW0_T -> "damzz0_t_1(gkm,mkm,"
| D_FM1_ZZWW0_U -> "damzz0_u_1(gkm,mkm,"
| D_FM1_ZZWW1_S -> "damzz1_s_1(gkm,mkm,"
| D_FM1_ZZWW1_T -> "damzz1_t_1(gkm,mkm,"
| D_FM1_ZZWW1_U -> "damzz1_u_1(gkm,mkm,"
| D_FM1_WWWW0_S -> "damww0_s_1(gkm,mkm,"
| D_FM1_WWWW0_T -> "damww0_t_1(gkm,mkm,"
| D_FM1_WWWW0_U -> "damww0_u_1(gkm,mkm,"
| D_FM1_WWWW2_S -> "damww2_s_1(gkm,mkm,"
| D_FM1_WWWW2_T -> "damww2_t_1(gkm,mkm,"
| D_FM1_WWWW2_U -> "damww2_u_1(gkm,mkm,"
| D_FM1_ZZZZ_S -> "damz4_s_1(gkm,mkm,"
| D_FM1_ZZZZ_T -> "damz4_t_1(gkm,mkm,"
| D_FM1_ZZZZ_U -> "damz4_u_1(gkm,mkm,"
| D_FM7_ZZWW0_S -> "damzz0_s_7(gkm,mkm,"
| D_FM7_ZZWW0_T -> "damzz0_t_7(gkm,mkm,"
| D_FM7_ZZWW0_U -> "damzz0_u_7(gkm,mkm,"
| D_FM7_ZZWW1_S -> "damzz1_s_7(gkm,mkm,"
| D_FM7_ZZWW1_T -> "damzz1_t_7(gkm,mkm,"
| D_FM7_ZZWW1_U -> "damzz1_u_7(gkm,mkm,"
| D_FM7_WWWW0_S -> "damww0_s_7(gkm,mkm,"
| D_FM7_WWWW0_T -> "damww0_t_7(gkm,mkm,"
| D_FM7_WWWW0_U -> "damww0_u_7(gkm,mkm,"
| D_FM7_WWWW2_S -> "damww2_s_7(gkm,mkm,"
| D_FM7_WWWW2_T -> "damww2_t_7(gkm,mkm,"
| D_FM7_WWWW2_U -> "damww2_u_7(gkm,mkm,"
| D_FM7_ZZZZ_S -> "damz4_s_7(gkm,mkm,"
| D_FM7_ZZZZ_T -> "damz4_t_7(gkm,mkm,"
| D_FM7_ZZZZ_U -> "damz4_u_7(gkm,mkm,"
| D_Alpha_HHHH_S -> "dalh4_s(gkm,mkm,"
| D_Alpha_HHHH_T -> "dalh4_t(gkm,mkm,"
| D_Alpha_HHWW0_S -> "dalhw0_s(gkm,mkm,"
| D_Alpha_HHWW0_T -> "dalhw0_t(gkm,mkm,"
| D_Alpha_HHZZ0_S -> "dalhz0_s(gkm,mkm,"
| D_Alpha_HHZZ0_T -> "dalhz0_t(gkm,mkm,"
| D_Alpha_HHWW1_S -> "dalhw1_s(gkm,mkm,"
| D_Alpha_HHWW1_T -> "dalhw1_t(gkm,mkm,"
| D_Alpha_HHWW1_U -> "dalhw1_u(gkm,mkm,"
| D_Alpha_HHZZ1_S -> "dalhz1_s(gkm,mkm,"
| D_Alpha_HHZZ1_T -> "dalhz1_t(gkm,mkm,"
| D_Alpha_HHZZ1_U -> "dalhz1_u(gkm,mkm,"
| D_FM0_HHWW0_S -> "damhw0_s_0(gkm,mkm,"
| D_FM0_HHWW0_T -> "damhw0_t_0(gkm,mkm,"
| D_FM0_HHWW0_U -> "damhw0_u_0(gkm,mkm,"
| D_FM0_HHZZ0_S -> "damhz0_s_0(gkm,mkm,"
| D_FM0_HHZZ0_T -> "damhz0_t_0(gkm,mkm,"
| D_FM0_HHZZ0_U -> "damhz0_u_0(gkm,mkm,"
| D_FM0_HHWW1_S -> "damhw1_s_0(gkm,mkm,"
| D_FM0_HHWW1_T -> "damhw1_t_0(gkm,mkm,"
| D_FM0_HHWW1_U -> "damhw1_u_0(gkm,mkm,"
| D_FM0_HHZZ1_S -> "damhz1_s_0(gkm,mkm,"
| D_FM0_HHZZ1_T -> "damhz1_t_0(gkm,mkm,"
| D_FM0_HHZZ1_U -> "damhz1_u_0(gkm,mkm,"
| D_FM1_HHWW0_S -> "damhw0_s_1(gkm,mkm,"
| D_FM1_HHWW0_T -> "damhw0_t_1(gkm,mkm,"
| D_FM1_HHWW0_U -> "damhw0_u_1(gkm,mkm,"
| D_FM1_HHZZ0_S -> "damhz0_s_1(gkm,mkm,"
| D_FM1_HHZZ0_T -> "damhz0_t_1(gkm,mkm,"
| D_FM1_HHZZ0_U -> "damhz0_u_1(gkm,mkm,"
| D_FM1_HHWW1_S -> "damhw1_s_1(gkm,mkm,"
| D_FM1_HHWW1_T -> "damhw1_t_1(gkm,mkm,"
| D_FM1_HHWW1_U -> "damhw1_u_1(gkm,mkm,"
| D_FM1_HHZZ1_S -> "damhz1_s_1(gkm,mkm,"
| D_FM1_HHZZ1_T -> "damhz1_t_1(gkm,mkm,"
| D_FM1_HHZZ1_U -> "damhz1_u_1(gkm,mkm,"
| D_FM7_HHWW0_S -> "damhw0_s_1(gkm,mkm,"
| D_FM7_HHWW0_T -> "damhw0_t_1(gkm,mkm,"
| D_FM7_HHWW0_U -> "damhw0_u_1(gkm,mkm,"
| D_FM7_HHZZ0_S -> "damhz0_s_1(gkm,mkm,"
| D_FM7_HHZZ0_T -> "damhz0_t_1(gkm,mkm,"
| D_FM7_HHZZ0_U -> "damhz0_u_1(gkm,mkm,"
| D_FM7_HHWW1_S -> "damhw1_s_1(gkm,mkm,"
| D_FM7_HHWW1_T -> "damhw1_t_1(gkm,mkm,"
| D_FM7_HHWW1_U -> "damhw1_u_1(gkm,mkm,"
| D_FM7_HHZZ1_S -> "damhz1_s_1(gkm,mkm,"
| D_FM7_HHZZ1_T -> "damhz1_t_1(gkm,mkm,"
| D_FM7_HHZZ1_U -> "damhz1_u_1(gkm,mkm,"
| G_HWW -> "ghww" | G_HZZ -> "ghzz"
| G_HHWW -> "ghhww" | G_HHZZ -> "ghhzz"
| G_SWW -> "gsww" | G_SZZ -> "gszz"
| G_SHH -> "gshh"
| G_SWW_T -> "gswwt" | G_SZZ_T -> "gszzt"
| G_SAA_T -> "gsaat" | G_SAZ_T -> "gsazt"
| G_PNWW -> "gpnww" | G_PNZZ -> "gpnzz"
| G_PSNWW -> "gpsnww" | G_PSNZZ -> "gpsnzz"
| G_PSNHH -> "gpsnhh"
| G_PWZ -> "gpwz" | G_PWW -> "gpww"
| G_FWW -> "gfww" | G_FZZ -> "gfzz"
| G_FWW_CF -> "gfwwcf" | G_FZZ_CF -> "gfzzcf"
| G_FHH -> "gfhh" | G_FHH_CF -> "gfhhcf"
| G_FWW_T -> "gfwwt" | G_FZZ_T -> "gfzzt"
| G_FFWW -> "gffww" | G_FFZZ -> "gffzz"
| G_FFWW_CF -> "gffwwcf" | G_FFZZ_CF -> "gffzzcf"
| G_FFHH -> "gffhh" | G_FFHH_CF -> "gffhhcf"
| G_FVWW -> "gfvww" | G_FVZZ -> "gfvzz"
| G_FVWW_CF -> "gfvwwcf" | G_FVZZ_CF -> "gfvzzcf"
| G_FVHH -> "gfvhh" | G_FVHH_CF -> "gfvhhcf"
| G_FDDSWW -> "gfddsww" | G_FDDSZZ -> "gfddszz"
| G_FDDSWW_CF -> "gfddswwcf" | G_FDDSZZ_CF -> "gfddszzcf"
| G_FDDSHH -> "gfddshh" | G_FDDSHH_CF -> "gfddshhcf"
| G_FSWW -> "gfsww" | G_FSZZ -> "gfszz"
| G_FSHH -> "gfshh"
| G_TNWW -> "gtnww" | G_TNZZ -> "gtnzz"
| G_TNWW_CF -> "gtnwwcf" | G_TNZZ_CF -> "gtnzzcf"
| G_TSNWW -> "gtsnww" | G_TSNZZ -> "gtsnzz"
| G_TSNWW_CF -> "gtsnwwcf" | G_TSNZZ_CF -> "gtsnzzcf"
| G_TWZ -> "gtwz" | G_TWW -> "gtww"
| G_TWZ_CF -> "gtwzcf" | G_TWW_CF -> "gtwwcf"
| G_SSWW -> "gssww" | G_SSZZ -> "gsszz"
| G_Htt -> "ghtt" | G_Hbb -> "ghbb"
| G_Htautau -> "ghtautau" | G_Hcc -> "ghcc" | G_Hmm -> "ghmm"
| G_HGaZ -> "ghgaz" | G_HGaGa -> "ghgaga" | G_Hgg -> "ghgg"
| G_HGaGa_anom -> "ghgaga_ac" | G_HGaZ_anom -> "ghgaz_ac"
| G_HZZ_anom -> "ghzz_ac" | G_HWW_anom -> "ghww_ac"
| G_HGaZ_u -> "ghgaz_u" | G_HZZ_u -> "ghzz_u"
| G_HWW_u -> "ghww_u"
| G_H3 -> "gh3" | G_H4 -> "gh4"
| Gs -> "gs" | I_Gs -> "igs" | G2 -> "gs**2"
| Mass f -> "mass" ^ flavor_symbol f
| Width f -> "width" ^ flavor_symbol f
| K_Matrix_Coeff i -> "kc" ^ string_of_int i
| K_Matrix_Pole i -> "kp" ^ string_of_int i
end
Index: trunk/omega/src/modeltools.mli
===================================================================
--- trunk/omega/src/modeltools.mli (revision 8899)
+++ trunk/omega/src/modeltools.mli (revision 8900)
@@ -1,84 +1,86 @@
(* modeltools.mli --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
(* \thocwmodulesection{Compilation} *)
module type Flavor =
sig
type f
type c
val compare : f -> f -> int
val conjugate : f -> f
end
module type Fusions =
sig
type t
type f
type c
val fuse2 : t -> f -> f -> (f * c Coupling.t) list
val fuse3 : t -> f -> f -> f -> (f * c Coupling.t) list
val fuse : t -> f list -> (f * c Coupling.t) list
val of_vertices :
(((f * f * f) * c Coupling.vertex3 * c) list
* ((f * f * f * f) * c Coupling.vertex4 * c) list
* (f list * c Coupling.vertexn * c) list) -> t
end
module Fusions : functor (F : Flavor) ->
Fusions with type f = F.f and type c = F.c
(* \thocwmodulesection{Coupling Constants} *)
(* There is no [Model.constant_of_string] function, but we can
construct one by inverting [Model.constant_symbol] on the set
of all coupling constants appearing in the vertices. *)
module type Constant =
sig
type t
val of_string : string -> t
end
module Constant : functor (M : Model.T) -> Constant with type t = M.constant
(* \thocwmodulesection{Mutable Models} *)
-module Mutable : functor (FGC : sig type f and g and c end) ->
+exception Uninitialized of string
+
+module Mutable : functor (FGC : sig type f and g and c and co end) ->
Model.Mutable with type flavor = FGC.f and type gauge = FGC.g
- and type constant = FGC.c
+ and type constant = FGC.c and type coupling_order = FGC.co
module Static (M : Model.T) : Model.Mutable
(* \thocwmodulesection{Topology Only} *)
module Topology (M : Model.T) : Model.T
with type flavor = M.flavor
and type gauge = M.gauge
and type constant = M.constant
module Topology3 (M : Model.T) : Model.T
with type flavor = M.flavor
and type gauge = M.gauge
and type constant = M.constant
Index: trunk/omega/src/thoString.mli
===================================================================
--- trunk/omega/src/thoString.mli (revision 8899)
+++ trunk/omega/src/thoString.mli (revision 8900)
@@ -1,71 +1,71 @@
(* thoString.mli --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
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. *)
-(* This is a very simple library if stroing manipulation functions missing
+(* This is a very simple library if string manipulation functions missing
in O'Caml's standard library. *)
(* [strip_prefix prefix string] returns [string] with 0 or 1
occurences of a leading [prefix] removed. *)
val strip_prefix : string -> string -> string
(* [strip_prefix_star prefix string] returns [string] with any number
of leading occurences of [prefix] removed. *)
val strip_prefix_star : char -> string -> string
(* [strip_prefix prefix string] returns [string] with a leading
[prefix] removed, raises [Invalid_argument] if there's no match. *)
val strip_required_prefix : string -> string -> string
(* [strip_from_first c s] returns [s] with everything starting from
the first [c] removed. [strip_from_last c s] returns [s] with
everything starting from the last [c] removed. *)
val strip_from_first : char -> string -> string
val strip_from_last : char -> string -> string
(* [index_string pattern string] returns the index of the first
occurence of [pattern] in [string], if any. Raises [Not_found], if
[pattern] is not in [string]. *)
val index_string : string -> string -> int
(* This silently fails if the argument contains both single and double quotes! *)
val quote : string -> string
(* The corresponding functions from [String] have become obsolescent
with O'Caml~4.0.3. Quanrantine them here. *)
val uppercase : string -> string
val lowercase : string -> string
(* Ignore the case in comparisons. *)
val compare_caseless : string -> string -> int
(* Match the regular expression
\texttt{\lbrack A-Za-z\rbrack\lbrack A-Za-z0-9\_\rbrack*} *)
val valid_fortran_id : string -> bool
(* Replace any invalid character by ['_'] and prepend ["N_"] iff
the string doesn't start with a letter. *)
val sanitize_fortran_id : string -> string
module Test : sig val suite : OUnit.test end
Index: trunk/omega/src/target_Fortran.mli
===================================================================
--- trunk/omega/src/target_Fortran.mli (revision 0)
+++ trunk/omega/src/target_Fortran.mli (revision 8900)
@@ -0,0 +1,26 @@
+(* targets.mli --
+
+ Copyright (C) 1999-2023 by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+ with contributions from
+ Christian Speckner <cnspeckn@googlemail.com>
+
+ WHIZARD is free software; you can redistribute it and/or modify it
+ under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ WHIZARD is distributed in the hope that it will be useful, but
+ WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
+
+module Make : Target.Maker
+module Make_Majorana : Target.Maker
Index: trunk/omega/src/UFOx_syntax.mli
===================================================================
--- trunk/omega/src/UFOx_syntax.mli (revision 8899)
+++ trunk/omega/src/UFOx_syntax.mli (revision 8900)
@@ -1,55 +1,95 @@
(* vertex_syntax.mli --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
+(* \thocwmodulesection{UFO Extensions}
+
+ We accept the following extensions to the UFO format:
+ \begin{enumerate}
+ \item Young tableaux: they are representated as a list of lists
+ of integers using ``\texttt{,}'' as separators. E.\,g.
+ \ytableausetup{centertableaux,smalltableaux}
+ \begin{equation}
+ \ytableaushort{13,2}
+ \end{equation}
+ is written as \texttt{\lbrack\lbrack1,3\rbrack,\lbrack2\rbrack\rbrack}.
+ The contents of cells in a Young tableau for the representation of a
+ particle must be consecutive positive integers starting with 1.
+ The representation for the anti particle has all integers negated,
+ e.\,g.~\texttt{\lbrack\lbrack-1,-3\rbrack,\lbrack-2\rbrack\rbrack}.
+ \item Young tableaux for particles and anti particles can appear in
+ the \emph{new} optional attribute \texttt{color\_young}.
+ If \texttt{color\_young} is present, \texttt{color} should be set to the
+ non-standard value~$0$.
+ \item Young tableaux for particles (but not for anti particles!)
+ can also appear in the \texttt{color} attribute of vertices as
+ the first argument of the new tensors \texttt{Delta} and \texttt{TY},
+ representing the Kronecker-$\delta$ and the generator~$T_a$ in the
+ given representation. The gauge vertex in the above representation
+ would be written
+ \begin{center}
+ \texttt{color = \lbrack 'TY(\lbrack\lbrack1,3\rbrack,\lbrack2\rbrack\rbrack,3,1,2)'\rbrack}
+ \end{center}
+ where the gluon would be at position 3, the particle at position 1
+ and the anti particle at position 2. The numbers in the Young tableau
+ and the numbers denoting the position of the particles are
+ completely unrelated, of course.
+ \end{enumerate}
+ Note that the cells in the Young tableaux used internally by O'Mega start
+ from~0. Using this in the UFO files would have required to introduce
+ even more special syntax for charge conjugation. *)
+
+
(* \thocwmodulesection{Abstract Syntax} *)
exception Syntax_Error of string * Lexing.position * Lexing.position
type expr =
| Integer of int
| Float of float
| Variable of string
| Quoted of string
+ | Young_Tableau of int Young.tableau
| Sum of expr * expr
| Difference of expr * expr
| Product of expr * expr
| Quotient of expr * expr
| Power of expr * expr
| Application of string * expr list
val integer : int -> expr
val float : float -> expr
val variable : string -> expr
val quoted : string -> expr
+val young_tableau : int Young.tableau -> expr
val add : expr -> expr -> expr
val subtract : expr -> expr -> expr
val multiply : expr -> expr -> expr
val divide : expr -> expr -> expr
val power : expr -> expr -> expr
val apply : string -> expr list -> expr
(* Return the sets of variable and function names referenced
in the expression. *)
val variables : expr -> Sets.String_Caseless.t
val functions : expr -> Sets.String_Caseless.t
Index: trunk/omega/src/omega_NMSSM.ml
===================================================================
--- trunk/omega/src/omega_NMSSM.ml (revision 8899)
+++ trunk/omega/src/omega_NMSSM.ml (revision 8900)
@@ -1,26 +1,26 @@
(* omega_NMSSM.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23_Majorana_vintage(Targets.Fortran_Majorana)(Modellib_NMSSM.NMSSM_func(Modellib_NMSSM.NMSSM))
+module O = Omega.Mixed23_Majorana_vintage(Target_Fortran.Make_Majorana)(Modellib_NMSSM.NMSSM_func(Modellib_NMSSM.NMSSM))
let _ = O.main ()
Index: trunk/omega/src/omega_QCD_VM.ml
===================================================================
--- trunk/omega/src/omega_QCD_VM.ml (revision 8899)
+++ trunk/omega/src/omega_QCD_VM.ml (revision 8900)
@@ -1,27 +1,27 @@
(* omega_QCD_VM.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
cf. main AUTHORS file
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.VM)(Modellib_SM.QCD)
+module O = Omega.Mixed23(Target_VM.Make)(Modellib_SM.QCD)
let _ = O.main ()
Index: trunk/omega/src/omega_SM_CKM.ml
===================================================================
--- trunk/omega/src/omega_SM_CKM.ml (revision 8899)
+++ trunk/omega/src/omega_SM_CKM.ml (revision 8900)
@@ -1,35 +1,26 @@
(* omega_SM_CKM.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.Fortran)
- (Modellib_SM.SM(Modellib_SM.SM_no_anomalous_ckm))
+module O = Omega.Mixed23(Target_Fortran.Make)(Modellib_SM.SM(Modellib_SM.SM_no_anomalous_ckm))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/omega_SM_ac_CKM.ml
===================================================================
--- trunk/omega/src/omega_SM_ac_CKM.ml (revision 8899)
+++ trunk/omega/src/omega_SM_ac_CKM.ml (revision 8900)
@@ -1,35 +1,26 @@
(* omega_SM_ac_CKM.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.Fortran)
- (Modellib_SM.SM(Modellib_SM.SM_anomalous_ckm))
+module O = Omega.Mixed23(Target_Fortran.Make)(Modellib_SM.SM(Modellib_SM.SM_anomalous_ckm))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/target_VM.ml
===================================================================
--- trunk/omega/src/target_VM.ml (revision 0)
+++ trunk/omega/src/target_VM.ml (revision 8900)
@@ -0,0 +1,1777 @@
+(* target_VM.ml --
+
+ Copyright (C) 1999-2023 by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+ with contributions from
+ Christian Speckner <cnspeckn@googlemail.com>
+ Fabian Bach <fabian.bach@t-online.de> (only parts of this file)
+ Marco Sekulla <marco.sekulla@kit.edu> (only parts of this file)
+ Bijan Chokoufe Nejad <bijan.chokoufe@desy.de> (only parts of this file)
+ So Young Shim <soyoung.shim@desy.de>
+
+ WHIZARD is free software; you can redistribute it and/or modify it
+ under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ WHIZARD is distributed in the hope that it will be useful, but
+ WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
+
+(* \thocwmodulesection{O'Mega Virtual Machine with \texttt{Fortran\;90/95}} *)
+
+module Make (Fusion_Maker : Fusion.Maker) (P : Momentum.T) (M : Model.T) =
+ struct
+
+ open Coupling
+ open Format
+
+ module CM = Colorize.It(M)
+ module SCM = Orders.Slice(Colorize.It(M))
+ module F = Fusion_Maker(P)(M)
+ module CF = Fusion.Multi(Fusion_Maker)(P)(M)
+ module CFlow = Color.Flow
+ type amplitudes = CF.amplitudes
+
+(* Options. *)
+ type diagnostic = All | Arguments | Momenta | Gauge
+
+ let wrapper_module = ref "ovm_wrapper"
+ let parameter_module_external = ref "some_external_module_with_model_info"
+ let bytecode_file = ref "bytecode.hbc"
+ let md5sum = ref None
+ let openmp = ref false
+ let kind = ref "default"
+ let whizard = ref false
+
+ let options = Options.create
+ [ "wrapper_module", Arg.String (fun s -> wrapper_module := s),
+ "name name of wrapper module";
+ "bytecode_file", Arg.String (fun s -> bytecode_file := s),
+ "name bytecode file to be used in wrapper";
+ "parameter_module_external", Arg.String (fun s ->
+ parameter_module_external := s),
+ "name external parameter module to be used in wrapper";
+ "md5sum", Arg.String (fun s -> md5sum := Some s),
+ "checksum transfer MD5 checksum in wrapper";
+ "whizard", Arg.Set whizard, " include WHIZARD interface in wrapper";
+ "openmp", Arg.Set openmp,
+ "activate parallel computation of amplitude with OpenMP"]
+
+(* Integers encode the opcodes (operation codes). *)
+ let ovm_ADD_MOMENTA = 1
+ let ovm_CALC_BRAKET = 2
+
+ let ovm_LOAD_SCALAR = 10
+ let ovm_LOAD_SPINOR_INC = 11
+ let ovm_LOAD_SPINOR_OUT = 12
+ let ovm_LOAD_CONJSPINOR_INC = 13
+ let ovm_LOAD_CONJSPINOR_OUT = 14
+ let ovm_LOAD_MAJORANA_INC = 15
+ let ovm_LOAD_MAJORANA_OUT = 16
+ let ovm_LOAD_VECTOR_INC = 17
+ let ovm_LOAD_VECTOR_OUT = 18
+ let ovm_LOAD_VECTORSPINOR_INC = 19
+ let ovm_LOAD_VECTORSPINOR_OUT = 20
+ let ovm_LOAD_TENSOR2_INC = 21
+ let ovm_LOAD_TENSOR2_OUT = 22
+ let ovm_LOAD_BRS_SCALAR = 30
+ let ovm_LOAD_BRS_SPINOR_INC = 31
+ let ovm_LOAD_BRS_SPINOR_OUT = 32
+ let ovm_LOAD_BRS_CONJSPINOR_INC = 33
+ let ovm_LOAD_BRS_CONJSPINOR_OUT = 34
+ let ovm_LOAD_BRS_VECTOR_INC = 37
+ let ovm_LOAD_BRS_VECTOR_OUT = 38
+ let ovm_LOAD_MAJORANA_GHOST_INC = 23
+ let ovm_LOAD_MAJORANA_GHOST_OUT = 24
+ let ovm_LOAD_BRS_MAJORANA_INC = 35
+ let ovm_LOAD_BRS_MAJORANA_OUT = 36
+
+ let ovm_PROPAGATE_SCALAR = 51
+ let ovm_PROPAGATE_COL_SCALAR = 52
+ let ovm_PROPAGATE_GHOST = 53
+ let ovm_PROPAGATE_SPINOR = 54
+ let ovm_PROPAGATE_CONJSPINOR = 55
+ let ovm_PROPAGATE_MAJORANA = 56
+ let ovm_PROPAGATE_COL_MAJORANA = 57
+ let ovm_PROPAGATE_UNITARITY = 58
+ let ovm_PROPAGATE_COL_UNITARITY = 59
+ let ovm_PROPAGATE_FEYNMAN = 60
+ let ovm_PROPAGATE_COL_FEYNMAN = 61
+ let ovm_PROPAGATE_VECTORSPINOR = 62
+ let ovm_PROPAGATE_TENSOR2 = 63
+
+(* \begin{dubious}
+ [ovm_PROPAGATE_NONE] has to be split up to different types to work
+ in conjunction with color MC \dots
+ \end{dubious} *)
+ let ovm_PROPAGATE_NONE = 64
+
+ let ovm_FUSE_V_FF = -1
+ let ovm_FUSE_F_VF = -2
+ let ovm_FUSE_F_FV = -3
+ let ovm_FUSE_VA_FF = -4
+ let ovm_FUSE_F_VAF = -5
+ let ovm_FUSE_F_FVA = -6
+ let ovm_FUSE_VA2_FF = -7
+ let ovm_FUSE_F_VA2F = -8
+ let ovm_FUSE_F_FVA2 = -9
+ let ovm_FUSE_A_FF = -10
+ let ovm_FUSE_F_AF = -11
+ let ovm_FUSE_F_FA = -12
+ let ovm_FUSE_VL_FF = -13
+ let ovm_FUSE_F_VLF = -14
+ let ovm_FUSE_F_FVL = -15
+ let ovm_FUSE_VR_FF = -16
+ let ovm_FUSE_F_VRF = -17
+ let ovm_FUSE_F_FVR = -18
+ let ovm_FUSE_VLR_FF = -19
+ let ovm_FUSE_F_VLRF = -20
+ let ovm_FUSE_F_FVLR = -21
+ let ovm_FUSE_SP_FF = -22
+ let ovm_FUSE_F_SPF = -23
+ let ovm_FUSE_F_FSP = -24
+ let ovm_FUSE_S_FF = -25
+ let ovm_FUSE_F_SF = -26
+ let ovm_FUSE_F_FS = -27
+ let ovm_FUSE_P_FF = -28
+ let ovm_FUSE_F_PF = -29
+ let ovm_FUSE_F_FP = -30
+ let ovm_FUSE_SL_FF = -31
+ let ovm_FUSE_F_SLF = -32
+ let ovm_FUSE_F_FSL = -33
+ let ovm_FUSE_SR_FF = -34
+ let ovm_FUSE_F_SRF = -35
+ let ovm_FUSE_F_FSR = -36
+ let ovm_FUSE_SLR_FF = -37
+ let ovm_FUSE_F_SLRF = -38
+ let ovm_FUSE_F_FSLR = -39
+
+ let ovm_FUSE_G_GG = -40
+ let ovm_FUSE_V_SS = -41
+ let ovm_FUSE_S_VV = -42
+ let ovm_FUSE_S_VS = -43
+ let ovm_FUSE_V_SV = -44
+ let ovm_FUSE_S_SS = -45
+ let ovm_FUSE_S_SVV = -46
+ let ovm_FUSE_V_SSV = -47
+ let ovm_FUSE_S_SSS = -48
+ let ovm_FUSE_V_VVV = -49
+
+ let ovm_FUSE_S_G2 = -50
+ let ovm_FUSE_G_SG = -51
+ let ovm_FUSE_G_GS = -52
+ let ovm_FUSE_S_G2_SKEW = -53
+ let ovm_FUSE_G_SG_SKEW = -54
+ let ovm_FUSE_G_GS_SKEW = -55
+
+ let inst_length = 8
+
+(* Some helper functions. *)
+ let printi ~lhs:l ~rhs1:r1 ?coupl:(cp = 0) ?coeff:(co = 0)
+ ?rhs2:(r2 = 0) ?rhs3:(r3 = 0) ?rhs4:(r4 = 0) code =
+ printf "@\n%d %d %d %d %d %d %d %d" code cp co l r1 r2 r3 r4
+
+ let nl () = printf "@\n"
+
+ let print_int_lst lst = nl (); lst |> List.iter (printf "%d ")
+
+ let print_str_lst lst = nl (); lst |> List.iter (printf "%s ")
+
+ let break () = printi ~lhs:0 ~rhs1:0 0
+
+(* Copied from below. Needed for header. *)
+(* \begin{dubious}
+ Could be fused with [lorentz_ordering].
+ \end{dubious} *)
+ type declarations =
+ { scalars : F.wf list;
+ spinors : F.wf list;
+ conjspinors : F.wf list;
+ realspinors : F.wf list;
+ ghostspinors : F.wf list;
+ vectorspinors : F.wf list;
+ vectors : F.wf list;
+ ward_vectors : F.wf list;
+ massive_vectors : F.wf list;
+ tensors_1 : F.wf list;
+ tensors_2 : F.wf list;
+ brs_scalars : F.wf list;
+ brs_spinors : F.wf list;
+ brs_conjspinors : F.wf list;
+ brs_realspinors : F.wf list;
+ brs_vectorspinors : F.wf list;
+ brs_vectors : F.wf list;
+ brs_massive_vectors : F.wf list }
+
+ let rec classify_wfs' acc = function
+ | [] -> acc
+ | wf :: rest ->
+ classify_wfs'
+ (match SCM.lorentz (F.flavor wf) with
+ | Scalar -> {acc with scalars = wf :: acc.scalars}
+ | Spinor -> {acc with spinors = wf :: acc.spinors}
+ | ConjSpinor -> {acc with conjspinors = wf :: acc.conjspinors}
+ | Majorana -> {acc with realspinors = wf :: acc.realspinors}
+ | Maj_Ghost -> {acc with ghostspinors = wf :: acc.ghostspinors}
+ | Vectorspinor ->
+ {acc with vectorspinors = wf :: acc.vectorspinors}
+ | Vector -> {acc with vectors = wf :: acc.vectors}
+ | Massive_Vector ->
+ {acc with massive_vectors = wf :: acc.massive_vectors}
+ | Tensor_1 -> {acc with tensors_1 = wf :: acc.tensors_1}
+ | Tensor_2 -> {acc with tensors_2 = wf :: acc.tensors_2}
+ | BRS Scalar -> {acc with brs_scalars = wf :: acc.brs_scalars}
+ | BRS Spinor -> {acc with brs_spinors = wf :: acc.brs_spinors}
+ | BRS ConjSpinor -> {acc with brs_conjspinors =
+ wf :: acc.brs_conjspinors}
+ | BRS Majorana -> {acc with brs_realspinors =
+ wf :: acc.brs_realspinors}
+ | BRS Vectorspinor -> {acc with brs_vectorspinors =
+ wf :: acc.brs_vectorspinors}
+ | BRS Vector -> {acc with brs_vectors = wf :: acc.brs_vectors}
+ | BRS Massive_Vector -> {acc with brs_massive_vectors =
+ wf :: acc.brs_massive_vectors}
+ | BRS _ -> invalid_arg "Targets.classify_wfs': not needed here")
+ rest
+
+ let classify_wfs wfs = classify_wfs'
+ { scalars = [];
+ spinors = [];
+ conjspinors = [];
+ realspinors = [];
+ ghostspinors = [];
+ vectorspinors = [];
+ vectors = [];
+ ward_vectors = [];
+ massive_vectors = [];
+ tensors_1 = [];
+ tensors_2 = [];
+ brs_scalars = [];
+ brs_spinors = [];
+ brs_conjspinors = [];
+ brs_realspinors = [];
+ brs_vectorspinors = [];
+ brs_vectors = [];
+ brs_massive_vectors = [] } wfs
+
+(* \thocwmodulesubsection{Sets and maps} *)
+
+(* The OVM identifies all objects via integers. Therefore, we need maps
+ which assign the abstract object a unique ID. *)
+
+(* I want [int list]s with less elements to come first. Used in conjunction
+ with the int list representation of momenta, this will set the outer
+ particles at first position and allows the OVM to set them without further
+ instructions. *)
+
+(* \begin{dubious}
+ Using the Momentum module might give better performance than integer lists?
+ \end{dubious} *)
+ let rec int_lst_compare (e1 : int list) (e2 : int list) =
+ match e1,e2 with
+ | [], [] -> 0
+ | _, [] -> +1
+ | [], _ -> -1
+ | [_;_], [_] -> +1
+ | [_], [_;_] -> -1
+ | hd1 :: tl1, hd2 :: tl2 ->
+ let c = compare hd1 hd2 in
+ if (c != 0 && List.length tl1 = List.length tl2) then
+ c
+ else
+ int_lst_compare tl1 tl2
+
+(* We need a canonical ordering for the different types
+ of wfs. Copied, and slightly modified to order [wf]s, from
+ \texttt{fusion.ml}. *)
+
+ let lorentz_ordering wf =
+ match SCM.lorentz (F.flavor wf) with
+ | Scalar -> 0
+ | Spinor -> 1
+ | ConjSpinor -> 2
+ | Majorana -> 3
+ | Vector -> 4
+ | Massive_Vector -> 5
+ | Tensor_2 -> 6
+ | Tensor_1 -> 7
+ | Vectorspinor -> 8
+ | BRS Scalar -> 9
+ | BRS Spinor -> 10
+ | BRS ConjSpinor -> 11
+ | BRS Majorana -> 12
+ | BRS Vector -> 13
+ | BRS Massive_Vector -> 14
+ | BRS Tensor_2 -> 15
+ | BRS Tensor_1 -> 16
+ | BRS Vectorspinor -> 17
+ | Maj_Ghost -> invalid_arg "lorentz_ordering: not implemented"
+ | BRS _ -> invalid_arg "lorentz_ordering: not needed"
+
+ let wf_compare (wf1, mult1) (wf2, mult2) =
+ let c1 = compare (lorentz_ordering wf1) (lorentz_ordering wf2) in
+ if c1 <> 0 then
+ c1
+ else
+ let c2 = compare wf1 wf2 in
+ if c2 <> 0 then
+ c2
+ else
+ compare mult1 mult2
+
+ let amp_compare amp1 amp2 =
+ let cflow a = SCM.flow (F.incoming a) (F.outgoing a) in
+ let c1 = compare (cflow amp1) (cflow amp2) in
+ if c1 <> 0 then
+ c1
+ else
+ let process_sans_color a =
+ (List.map SCM.flavor_sans_color (F.incoming a),
+ List.map SCM.flavor_sans_color (F.outgoing a)) in
+ compare (process_sans_color amp1) (process_sans_color amp2)
+
+ let level_compare (f1, amp1) (f2, amp2) =
+ let p1 = F.momentum_list (F.lhs f1)
+ and p2 = F.momentum_list (F.lhs f2) in
+ let c1 = int_lst_compare p1 p2 in
+ if c1 <> 0 then
+ c1
+ else
+ let c2 = compare f1 f2 in
+ if c2 <> 0 then
+ c2
+ else
+ amp_compare amp1 amp2
+
+ module ISet = Set.Make (struct type t = int list
+ let compare = int_lst_compare end)
+
+ module WFSet = Set.Make (struct type t = CF.wf * int
+ let compare = wf_compare end)
+
+ module CSet = Set.Make (struct type t = CM.constant
+ let compare = compare end)
+
+ module FSet = Set.Make (struct type t = F.fusion * F.amplitude
+ let compare = level_compare end)
+
+(* \begin{dubious}
+ It might be preferable to use a [PMap] which maps mom to int, instead of
+ this way. More standard functions like [mem] could be used. Also, [get_ID]
+ would be faster, $\mathcal{O}(\log N)$ instead of $\mathcal{O}(N)$, and
+ simpler. For 8 gluons: N=127 momenta. Minor performance issue.
+ \end{dubious} *)
+
+ module IMap = Map.Make(Int)
+
+(* For [wf]s it is crucial for the performance to use a different type of
+ [Map]s. *)
+
+ module WFMap = Map.Make (struct type t = CF.wf * int
+ let compare = wf_compare end)
+
+ type lookups = { pmap : int list IMap.t;
+ wfmap : int WFMap.t;
+ cmap : CM.constant IMap.t * CM.constant IMap.t;
+ amap : F.amplitude IMap.t;
+ n_wfs : int list;
+ amplitudes : CF.amplitudes;
+ dict : F.amplitude -> F.wf -> int }
+
+ let largest_key imap =
+ if (IMap.is_empty imap) then
+ failwith "largest_key: Map is empty!"
+ else
+ fst (IMap.max_binding imap)
+
+(* OCaml's [compare] from pervasives cannot compare functional types, e.g.
+ for type [amplitude], if no specific equality function is given ("equal:
+ functional value"). Therefore, we allow to specify the ordering. *)
+
+ let get_ID' comp map elt : int =
+ let smallmap = IMap.filter (fun _ x -> (comp x elt) = 0 ) map in
+ if IMap.is_empty smallmap then
+ raise Not_found
+ else
+ fst (IMap.min_binding smallmap)
+
+(* \begin{dubious}
+ Trying to curry [map] here leads to type errors of the
+ polymorphic function [get_ID]?
+ \end{dubious} *)
+
+ let get_ID map = match map with
+ | map -> get_ID' compare map
+
+ let get_const_ID map x = match map with
+ | (map1, map2) -> try get_ID' compare map1 x with
+ _ -> try get_ID' compare map2 x with
+ _ -> failwith "Impossible"
+
+(* Creating an integer map of a list with an optional argument that
+ indicates where the map should start counting. *)
+
+ let map_of_list ?start:(st=1) lst =
+ let g (ind, map) wf = (succ ind, IMap.add ind wf map) in
+ lst |> List.fold_left g (st, IMap.empty) |> snd
+
+ let wf_map_of_list ?start:(st=1) lst =
+ let g (ind, map) wf = (succ ind, WFMap.add wf ind map) in
+ lst |> List.fold_left g (st, WFMap.empty) |> snd
+
+(* \thocwmodulesubsection{Header} *)
+
+(* \begin{dubious}
+ [Bijan:]
+ It would be nice to save the creation date as comment. However, the Unix
+ module doesn't seem to be loaded on default.
+ \end{dubious} *)
+
+ let version =
+ String.concat " " [Config.version; Config.status; Config.date]
+ let model_name =
+ let basename = Filename.basename Sys.executable_name in
+ try
+ Filename.chop_extension basename
+ with
+ | _ -> basename
+
+
+ let print_description cmdline =
+ printf "Model %s\n" model_name;
+ printf "OVM %s\n" version;
+ printf "@\nBytecode file generated automatically by O'Mega for OVM";
+ printf "@\nDo not delete any lines. You called O'Mega with";
+ printf "@\n %s" cmdline;
+ (*i
+ let t = Unix.localtime (Unix.time() ) in
+ printf "@\n on %5d %5d %5d" (succ t.Unix.tm_mon) t.Unix.tm_mday
+ t.Unix.tm_year;
+ i*)
+ printf "@\n"
+
+ let num_classified_wfs wfs =
+ let wfs' = classify_wfs wfs in
+ List.map List.length
+ [ wfs'.scalars @ wfs'.brs_scalars;
+ wfs'.spinors @ wfs'.brs_spinors;
+ wfs'.conjspinors @ wfs'.brs_conjspinors;
+ wfs'.realspinors @ wfs'.brs_realspinors @ wfs'.ghostspinors;
+ wfs'.vectors @ wfs'.massive_vectors @ wfs'.brs_vectors
+ @ wfs'.brs_massive_vectors @ wfs'.ward_vectors;
+ wfs'.tensors_2;
+ wfs'.tensors_1;
+ wfs'.vectorspinors ]
+
+ let description_classified_wfs =
+ [ "N_scalars";
+ "N_spinors";
+ "N_conjspinors";
+ "N_bispinors";
+ "N_vectors";
+ "N_tensors_2";
+ "N_tensors_1";
+ "N_vectorspinors" ]
+
+ let num_particles_in amp =
+ match CF.flavors amp with
+ | [] -> 0
+ | (fin, _) :: _ -> List.length fin
+
+ let num_particles_out amp =
+ match CF.flavors amp with
+ | [] -> 0
+ | (_, fout) :: _ -> List.length fout
+
+ let num_particles amp =
+ match CF.flavors amp with
+ | [] -> 0
+ | (fin, fout) :: _ -> List.length fin + List.length fout
+
+ let num_color_indices_default = 2 (* Standard model and non-color-exotica *)
+
+ let num_color_indices amp =
+ try CFlow.rank (List.hd (CF.color_flows amp)) with
+ _ -> num_color_indices_default
+
+ let num_color_factors amp =
+ let table = CF.color_factors amp in
+ let n_cflow = Array.length table
+ and n_cfactors = ref 0 in
+ for c1 = 0 to pred n_cflow do
+ for c2 = 0 to pred n_cflow do
+ if c1 <= c2 then begin
+ match table.(c1).(c2) with
+ | [] -> ()
+ | _ -> incr n_cfactors
+ end
+ done
+ done;
+ !n_cfactors
+
+ let num_helicities amp = amp |> CF.helicities |> List.length
+
+ let num_flavors amp = amp |> CF.flavors |> List.length
+
+ let num_ks amp = amp |> CF.processes |> List.length
+
+ let num_color_flows amp = amp |> CF.color_flows |> List.length
+
+(* Use [fst] since [WFSet.t = F.wf * int]. *)
+ let num_wfs wfset = wfset |> WFSet.elements |> List.map fst
+ |> num_classified_wfs
+
+(* [largest_key] gives the number of momenta if applied to [pmap]. *)
+
+ let num_lst lookups wfset =
+ [ largest_key lookups.pmap;
+ num_particles lookups.amplitudes;
+ num_particles_in lookups.amplitudes;
+ num_particles_out lookups.amplitudes;
+ num_ks lookups.amplitudes;
+ num_helicities lookups.amplitudes;
+ num_color_flows lookups.amplitudes;
+ num_color_indices lookups.amplitudes;
+ num_flavors lookups.amplitudes;
+ num_color_factors lookups.amplitudes ] @ num_wfs wfset
+
+ let description_lst =
+ [ "N_momenta";
+ "N_particles";
+ "N_prt_in";
+ "N_prt_out";
+ "N_amplitudes";
+ "N_helicities";
+ "N_col_flows";
+ "N_col_indices";
+ "N_flavors";
+ "N_col_factors" ] @ description_classified_wfs
+
+ let print_header' numbers =
+ let chopped_num_lst = ThoList.chopn inst_length numbers
+ and chopped_desc_lst = ThoList.chopn inst_length description_lst
+ and printer a b = print_str_lst a; print_int_lst b in
+ List.iter2 printer chopped_desc_lst chopped_num_lst
+
+ let print_header lookups wfset = print_header' (num_lst lookups wfset)
+
+ let print_zero_header () =
+ let rec zero_list' j =
+ if j < 1 then []
+ else 0 :: zero_list' (j - 1) in
+ let zero_list i = zero_list' (i + 1) in
+ description_lst |> List.length |> zero_list |> print_header'
+
+(* \thocwmodulesubsection{Tables} *)
+
+ let print_spin_table' tuples =
+ match tuples with
+ | [] -> ()
+ | _ -> tuples |> List.iter ( fun (tuple1, tuple2) ->
+ tuple1 @ tuple2 |> List.map (Printf.sprintf "%d ")
+ |> String.concat "" |> printf "@\n%s" )
+
+ let print_spin_table amplitudes =
+ printf "@\nSpin states table";
+ print_spin_table' @@ CF.helicities amplitudes
+
+ let print_flavor_table tuples =
+ match tuples with
+ | [] -> ()
+ | _ -> List.iter ( fun tuple -> tuple
+ |> List.map (fun f -> Printf.sprintf "%d " @@ M.pdg f)
+ |> String.concat "" |> printf "@\n%s"
+ ) tuples
+
+ let print_flavor_tables amplitudes =
+ printf "@\nFlavor states table";
+ print_flavor_table @@ List.map (fun (fin, fout) -> fin @ fout)
+ @@ CF.flavors amplitudes
+
+ let print_color_flows_table' tuple =
+ match CFlow.to_lists tuple with
+ | [] -> ()
+ | cfs -> printf "@\n%s" @@ String.concat "" @@ List.map
+ ( fun cf -> cf |> List.map (Printf.sprintf "%d ")
+ |> String.concat ""
+ ) cfs
+
+ let print_color_flows_table tuples =
+ match tuples with
+ | [] -> ()
+ | _ -> List.iter print_color_flows_table' tuples
+
+ let print_ghost_flags_table tuples =
+ match tuples with
+ | [] -> ()
+ | _ ->
+ List.iter (fun tuple ->
+ match CFlow.ghost_flags tuple with
+ | [] -> ()
+ | gfs -> printf "@\n"; List.iter (fun gf -> printf "%s "
+ (if gf then "1" else "0") ) gfs
+ ) tuples
+
+ let format_power
+ { CFlow.num = num; CFlow.den = den; CFlow.power = pwr } =
+ match num, den, pwr with
+ | _, 0, _ -> invalid_arg "targets.format_power: zero denominator"
+ | n, d, p -> [n; d; p]
+
+ let format_powers = function
+ | [] -> [0]
+ | powers -> List.flatten (List.map format_power powers)
+
+ (*i
+ (* We go through the array line by line and collect all colorfactors which
+ * are nonzero because their corresponding color flows match.
+ * With the gained intset, we would be able to print only the necessary
+ * coefficients of the symmetric matrix and indicate from where the OVM
+ * can copy the rest. However, this approach gets really slow for many
+ * gluons and we can save at most 3 numbers per line.*)
+
+ let print_color_factor_table_funct table =
+ let n_cflow = Array.length table in
+ let (intset, _, _ ) =
+ let rec fold_array (set, cf1, cf2) =
+ if cf1 > pred n_cflow then (set, 0, 0)
+ else
+ let returnset =
+ match table.(cf1).(cf2) with
+ | [] -> set
+ | cf ->
+ ISet.add ([succ cf1; succ cf2] @ (format_powers cf)) set
+ in
+ if cf2 < pred n_cflow then
+ fold_array (returnset, cf1, succ cf2) else
+ fold_array (returnset, succ cf1, 0)
+ in
+ fold_array (ISet.empty, 0, 0)
+ in
+ let map = map_of_list (ISet.elements intset) in
+ List.iter (fun x -> printf "@\n"; let xth = List.nth x in
+ if (xth 0 <= xth 1) then List.iter (printf "%d ") x
+ else printf "%d %d" 0 (get_ID map x))
+ (ISet.elements intset)
+
+ let print_color_factor_table_old table =
+ let n_cflow = Array.length table in
+ let (intlsts, _, _ ) =
+ let rec fold_array (lsts, cf1, cf2) =
+ if cf1 > pred n_cflow then (lsts, 0, 0)
+ else
+ let returnlsts =
+ match table.(cf1).(cf2) with
+ | [] -> lsts
+ | cf -> ([succ cf1; succ cf2] @ (format_powers cf)) :: lsts
+ in
+ if cf2 < pred n_cflow then
+ fold_array (returnlsts, cf1, succ cf2) else
+ fold_array (returnlsts, succ cf1, 0)
+ in
+ fold_array ([], 0, 0)
+ in
+ let intlsts = List.rev intlsts in
+ List.iter (fun x -> printf "@\n"; List.iter (printf "%d ") x ) intlsts
+ i*)
+
+(* Straightforward iteration gives a great speedup compared to the fancier
+ approach which only collects nonzero colorfactors. *)
+
+ let print_color_factor_table table =
+ let n_cflow = Array.length table in
+ if n_cflow > 0 then begin
+ for c1 = 0 to pred n_cflow do
+ for c2 = 0 to pred n_cflow do
+ if c1 <= c2 then begin
+ match table.(c1).(c2) with
+ | [] -> ()
+ | cf -> printf "@\n"; List.iter (printf "%9d")
+ ([succ c1; succ c2] @ (format_powers cf));
+ end
+ done
+ done
+ end
+
+ let option_to_binary = function
+ | Some _ -> "1"
+ | None -> "0"
+
+ let print_flavor_color_table n_flv n_cflow table =
+ if n_flv > 0 then begin
+ for c = 0 to pred n_cflow do
+ printf "@\n";
+ for f = 0 to pred n_flv do
+ printf "%s " (option_to_binary table.(f).(c))
+ done;
+ done;
+ end
+
+ let print_color_tables amplitudes =
+ let cflows = CF.color_flows amplitudes
+ and cfactors = CF.color_factors amplitudes in
+ printf "@\nColor flows table: [ (i, j) (k, l) -> (m, n) ...]";
+ print_color_flows_table cflows;
+ printf "@\nColor ghost flags table:";
+ print_ghost_flags_table cflows;
+ printf "@\nColor factors table: [ i, j: num den power], %s"
+ "i, j are indexed color flows";
+ print_color_factor_table cfactors;
+ printf "@\nFlavor color combination is allowed:";
+ print_flavor_color_table (num_flavors amplitudes) (List.length
+ (CF.color_flows amplitudes)) (CF.process_table amplitudes)
+
+(* \thocwmodulesubsection{Momenta} *)
+
+(* Add the momenta of a WFSet to a Iset. For now, we are throwing away the
+ information to which amplitude the momentum belongs. This could be optimized
+ for random color flow computations. *)
+
+ let momenta_set wfset =
+ let get_mom wf = wf |> fst |> F.momentum_list in
+ let momenta = List.map get_mom (WFSet.elements wfset) in
+ momenta |> List.fold_left (fun set x -> set |> ISet.add x) ISet.empty
+
+ let chop_in_3 lst =
+ let ceil_div i j = if (i mod j = 0) then i/j else i/j + 1 in
+ ThoList.chopn (ceil_div (List.length lst) 3) lst
+
+(* Assign momenta via instruction code. External momenta [[_]] are already
+ set by the OVM. To avoid unnecessary look-ups of IDs we seperate two cases.
+ If we have more, we split up in two or three parts. *)
+
+ let add_mom p pmap =
+ let print_mom lhs rhs1 rhs2 rhs3 = if (rhs1!= 0) then
+ printi ~lhs:lhs ~rhs1:rhs1 ~rhs2:rhs2 ~rhs3:rhs3 ovm_ADD_MOMENTA in
+ let get_p_ID = get_ID pmap in
+ match p with
+ | [] | [_] -> print_mom 0 0 0 0
+ | [rhs1;rhs2] -> print_mom (get_p_ID [rhs1;rhs2]) rhs1 rhs2 0
+ | [rhs1;rhs2;rhs3] -> print_mom (get_p_ID [rhs1;rhs2;rhs3]) rhs1 rhs2 rhs3
+ | more ->
+ let ids = List.map get_p_ID (chop_in_3 more) in
+ if (List.length ids = 3) then
+ print_mom (get_p_ID more) (List.nth ids 0) (List.nth ids 1)
+ (List.nth ids 2)
+ else
+ print_mom (get_p_ID more) (List.nth ids 0) (List.nth ids 1) 0
+
+(* Hand through the current level and print level seperators if necessary. *)
+
+ let add_all_mom lookups pset =
+ let add_all' level p =
+ let level' = List.length p in
+ if (level' > level && level' > 3) then break ();
+ add_mom p lookups.pmap; level'
+ in
+ ignore (pset |> ISet.elements |> List.fold_left add_all' 1)
+
+(* Expand a set of momenta to contain all needed momenta for the computation
+ in the OVM. For this, we create a list of sets which contains the chopped
+ momenta and unify them afterwards. If the set has become larger, we
+ expand again. *)
+
+ let rec expand_pset p =
+ let momlst = ISet.elements p in
+ let pset_of lst = List.fold_left (fun s x -> ISet.add x s) ISet.empty
+ lst in
+ let sets = List.map (fun x -> pset_of (chop_in_3 x) ) momlst in
+ let bigset = List.fold_left ISet.union ISet.empty sets in
+ let biggerset = ISet.union bigset p in
+ if (List.length momlst < List.length (ISet.elements biggerset) ) then
+ expand_pset biggerset
+ else
+ biggerset
+
+ let mom_ID pmap wf = get_ID pmap (F.momentum_list wf)
+
+(* \thocwmodulesubsection{Wavefunctions and externals} *)
+
+(* [mult_wf] is needed because the [wf] with same combination of flavor and
+ momentum can have different dependencies and content. *)
+
+ let mult_wf dict amplitude wf =
+ try
+ wf, dict amplitude wf
+ with
+ | Not_found -> wf, 0
+
+(* Build the union of all [wf]s of all amplitudes and a map of the amplitudes. *)
+
+ let wfset_amps amplitudes =
+ let amap = amplitudes |> CF.processes |> List.sort amp_compare
+ |> map_of_list
+ and dict = CF.dictionary amplitudes in
+ let wfset_amp amp =
+ let f = mult_wf dict amp in
+ let lst = List.map f ((F.externals amp) @ (F.variables amp)) in
+ lst |> List.fold_left (fun s x -> WFSet.add x s) WFSet.empty in
+ let list_of_sets = amplitudes |> CF.processes |> List.map wfset_amp in
+ List.fold_left WFSet.union WFSet.empty list_of_sets, amap
+
+(* To obtain the Fortran index, we substract the number of precedent wave
+ functions. *)
+
+ let lorentz_ordering_reduced wf =
+ match SCM.lorentz (F.flavor wf) with
+ | Scalar | BRS Scalar -> 0
+ | Spinor | BRS Spinor -> 1
+ | ConjSpinor | BRS ConjSpinor -> 2
+ | Majorana | BRS Majorana -> 3
+ | Vector | BRS Vector | Massive_Vector | BRS Massive_Vector -> 4
+ | Tensor_2 | BRS Tensor_2 -> 5
+ | Tensor_1 | BRS Tensor_1 -> 6
+ | Vectorspinor | BRS Vectorspinor -> 7
+ | Maj_Ghost -> invalid_arg "lorentz_ordering: not implemented"
+ | BRS _ -> invalid_arg "lorentz_ordering: not needed"
+
+ let wf_index wfmap num_lst (wf, i) =
+ let wf_ID = WFMap.find (wf, i) wfmap
+ and sum lst = List.fold_left (fun x y -> x+y) 0 lst in
+ wf_ID - sum (ThoList.hdn (lorentz_ordering_reduced wf) num_lst)
+
+ let print_ext lookups amp_ID inc (wf, i) =
+ let mom = (F.momentum_list wf) in
+ let outer_index = if List.length mom = 1 then List.hd mom else
+ failwith "targets.print_ext: called with non-external particle"
+ and f = F.flavor wf in
+ let pdg = SCM.pdg f
+ and wf_code =
+ match SCM.lorentz f with
+ | Scalar -> ovm_LOAD_SCALAR
+ | BRS Scalar -> ovm_LOAD_BRS_SCALAR
+ | Spinor ->
+ if inc then ovm_LOAD_SPINOR_INC
+ else ovm_LOAD_SPINOR_OUT
+ | BRS Spinor ->
+ if inc then ovm_LOAD_BRS_SPINOR_INC
+ else ovm_LOAD_BRS_SPINOR_OUT
+ | ConjSpinor ->
+ if inc then ovm_LOAD_CONJSPINOR_INC
+ else ovm_LOAD_CONJSPINOR_OUT
+ | BRS ConjSpinor ->
+ if inc then ovm_LOAD_BRS_CONJSPINOR_INC
+ else ovm_LOAD_BRS_CONJSPINOR_OUT
+ | Vector | Massive_Vector ->
+ if inc then ovm_LOAD_VECTOR_INC
+ else ovm_LOAD_VECTOR_OUT
+ | BRS Vector | BRS Massive_Vector ->
+ if inc then ovm_LOAD_BRS_VECTOR_INC
+ else ovm_LOAD_BRS_VECTOR_OUT
+ | Tensor_2 ->
+ if inc then ovm_LOAD_TENSOR2_INC
+ else ovm_LOAD_TENSOR2_OUT
+ | Vectorspinor | BRS Vectorspinor ->
+ if inc then ovm_LOAD_VECTORSPINOR_INC
+ else ovm_LOAD_VECTORSPINOR_OUT
+ | Majorana ->
+ if inc then ovm_LOAD_MAJORANA_INC
+ else ovm_LOAD_MAJORANA_OUT
+ | BRS Majorana ->
+ if inc then ovm_LOAD_BRS_MAJORANA_INC
+ else ovm_LOAD_BRS_MAJORANA_OUT
+ | Maj_Ghost ->
+ if inc then ovm_LOAD_MAJORANA_GHOST_INC
+ else ovm_LOAD_MAJORANA_GHOST_OUT
+ | Tensor_1 ->
+ invalid_arg "targets.print_ext: Tensor_1 only internal"
+ | BRS _ ->
+ failwith "targets.print_ext: Not implemented"
+ and wf_ind = wf_index lookups.wfmap lookups.n_wfs (wf, i)
+ in
+ printi wf_code ~lhs:wf_ind ~coupl:(abs(pdg)) ~rhs1:outer_index ~rhs4:amp_ID
+
+ let print_ext_amp lookups amplitude =
+ let incoming = (List.map (fun _ -> true) (F.incoming amplitude) @
+ List.map (fun _ -> false) (F.outgoing amplitude))
+ and amp_ID = get_ID' amp_compare lookups.amap amplitude in
+ let wf_tpl wf = mult_wf lookups.dict amplitude wf in
+ let print_ext_wf inc wf = wf |> wf_tpl |> print_ext lookups amp_ID inc in
+ List.iter2 print_ext_wf incoming (F.externals amplitude)
+
+ let print_externals lookups seen_wfs amplitude =
+ let externals =
+ List.combine
+ (F.externals amplitude)
+ (List.map (fun _ -> true) (F.incoming amplitude) @
+ List.map (fun _ -> false) (F.outgoing amplitude)) in
+ List.fold_left (fun seen (wf, incoming) ->
+ let amp_ID = get_ID' amp_compare lookups.amap amplitude in
+ let wf_tpl = mult_wf lookups.dict amplitude wf in
+ if not (WFSet.mem wf_tpl seen) then begin
+ wf_tpl |> print_ext lookups amp_ID incoming
+ end;
+ WFSet.add wf_tpl seen) seen_wfs externals
+
+(* [print_externals] and [print_ext_amp] do in principle the same thing but
+ [print_externals] filters out dublicate external wave functions. Even with
+ [print_externals] the same (numerically) external wave function will be
+ loaded if it belongs to a different color flow, just as in the native Fortran
+ code. For color MC, [print_ext_amp] has to be used (redundant instructions
+ but only one flow is computed) and the filtering of duplicate fusions has to
+ be disabled. *)
+
+ let print_ext_amps lookups =
+ let print_external_amp s x = print_externals lookups s x in
+ ignore (
+ List.fold_left print_external_amp WFSet.empty
+ (CF.processes lookups.amplitudes)
+ )
+ (*i
+ List.iter (print_ext_amp lookups) (CF.processes lookups.amplitudes)
+ i*)
+
+(* \thocwmodulesubsection{Currents} *)
+
+(* Parallelization issues: All fusions have to be completed before the
+ propagation takes place. Preferably each fusion and propagation is done
+ by one thread. Solution: All fusions are subinstructions, i.e. if
+ they are read by the main loop they are skipped. If a propagation
+ occurs, all fusions have to be computed first. The additional control
+ bit is the sign of the first int of an instruction. *)
+
+ (*i TODO: (bcn 2014-07-21) Majorana support will come some day maybe i*)
+ let print_fermion_current code_a code_b code_c coeff lhs c wf1 wf2 fusion =
+ let printc code r1 r2 = printi code ~lhs:lhs ~coupl:c ~coeff:coeff
+ ~rhs1:r1 ~rhs2:r2 in
+ match fusion with
+ | F13 -> printc code_a wf1 wf2
+ | F31 -> printc code_a wf2 wf1
+ | F23 -> printc code_b wf1 wf2
+ | F32 -> printc code_b wf2 wf1
+ | F12 -> printc code_c wf1 wf2
+ | F21 -> printc code_c wf2 wf1
+
+ let ferm_print_current = function
+ | coeff, Psibar, V, Psi -> print_fermion_current
+ ovm_FUSE_V_FF ovm_FUSE_F_VF ovm_FUSE_F_FV coeff
+ | coeff, Psibar, VA, Psi -> print_fermion_current
+ ovm_FUSE_VA_FF ovm_FUSE_F_VAF ovm_FUSE_F_FVA coeff
+ | coeff, Psibar, VA2, Psi -> print_fermion_current
+ ovm_FUSE_VA2_FF ovm_FUSE_F_VA2F ovm_FUSE_F_FVA2 coeff
+ | coeff, Psibar, A, Psi -> print_fermion_current
+ ovm_FUSE_A_FF ovm_FUSE_F_AF ovm_FUSE_F_FA coeff
+ | coeff, Psibar, VL, Psi -> print_fermion_current
+ ovm_FUSE_VL_FF ovm_FUSE_F_VLF ovm_FUSE_F_FVL coeff
+ | coeff, Psibar, VR, Psi -> print_fermion_current
+ ovm_FUSE_VR_FF ovm_FUSE_F_VRF ovm_FUSE_F_FVR coeff
+ | coeff, Psibar, VLR, Psi -> print_fermion_current
+ ovm_FUSE_VLR_FF ovm_FUSE_F_VLRF ovm_FUSE_F_FVLR coeff
+ | coeff, Psibar, SP, Psi -> print_fermion_current
+ ovm_FUSE_SP_FF ovm_FUSE_F_SPF ovm_FUSE_F_FSP coeff
+ | coeff, Psibar, S, Psi -> print_fermion_current
+ ovm_FUSE_S_FF ovm_FUSE_F_SF ovm_FUSE_F_FS coeff
+ | coeff, Psibar, P, Psi -> print_fermion_current
+ ovm_FUSE_P_FF ovm_FUSE_F_PF ovm_FUSE_F_FP coeff
+ | coeff, Psibar, SL, Psi -> print_fermion_current
+ ovm_FUSE_SL_FF ovm_FUSE_F_SLF ovm_FUSE_F_FSL coeff
+ | coeff, Psibar, SR, Psi -> print_fermion_current
+ ovm_FUSE_SR_FF ovm_FUSE_F_SRF ovm_FUSE_F_FSR coeff
+ | coeff, Psibar, SLR, Psi -> print_fermion_current
+ ovm_FUSE_SLR_FF ovm_FUSE_F_SLRF ovm_FUSE_F_FSLR coeff
+ | _, Psibar, _, Psi -> invalid_arg
+ "Targets.Fortran.VM: no superpotential here"
+ | _, Chibar, _, _ | _, _, _, Chi -> invalid_arg
+ "Targets.Fortran.VM: Majorana spinors not handled"
+ | _, Gravbar, _, _ | _, _, _, Grav -> invalid_arg
+ "Targets.Fortran.VM: Gravitinos not handled"
+
+ let children2 rhs =
+ match F.children rhs with
+ | [wf1; wf2] -> (wf1, wf2)
+ | _ -> failwith "Targets.children2: can't happen"
+
+ let children3 rhs =
+ match F.children rhs with
+ | [wf1; wf2; wf3] -> (wf1, wf2, wf3)
+ | _ -> invalid_arg "Targets.children3: can't happen"
+
+ let print_vector4 c lhs wf1 wf2 wf3 fusion (coeff, contraction) =
+ let printc r1 r2 r3 = printi ovm_FUSE_V_VVV ~lhs:lhs ~coupl:c
+ ~coeff:coeff ~rhs1:r1 ~rhs2:r2 ~rhs3:r3 in
+ match contraction, fusion with
+ | C_12_34, (F341|F431|F342|F432|F123|F213|F124|F214)
+ | C_13_42, (F241|F421|F243|F423|F132|F312|F134|F314)
+ | C_14_23, (F231|F321|F234|F324|F142|F412|F143|F413) ->
+ printc wf1 wf2 wf3
+ | C_12_34, (F134|F143|F234|F243|F312|F321|F412|F421)
+ | C_13_42, (F124|F142|F324|F342|F213|F231|F413|F431)
+ | C_14_23, (F123|F132|F423|F432|F214|F241|F314|F341) ->
+ printc wf2 wf3 wf1
+ | C_12_34, (F314|F413|F324|F423|F132|F231|F142|F241)
+ | C_13_42, (F214|F412|F234|F432|F123|F321|F143|F341)
+ | C_14_23, (F213|F312|F243|F342|F124|F421|F134|F431) ->
+ printc wf1 wf3 wf2
+
+ let print_current lookups lhs amplitude rhs =
+ let f = mult_wf lookups.dict amplitude in
+ match F.coupling rhs with
+ | V3 (vertex, fusion, constant) ->
+ let ch1, ch2 = children2 rhs in
+ let wf1 = wf_index lookups.wfmap lookups.n_wfs (f ch1)
+ and wf2 = wf_index lookups.wfmap lookups.n_wfs (f ch2)
+ and p1 = mom_ID lookups.pmap ch1
+ and p2 = mom_ID lookups.pmap ch2
+ and const_ID = get_const_ID lookups.cmap constant in
+ let c = if (F.sign rhs) < 0 then - const_ID else const_ID in
+ begin match vertex with
+ | FBF (coeff, fb, b, f) ->
+ begin match coeff, fb, b, f with
+ | _, Psibar, VLRM, Psi | _, Psibar, SPM, Psi
+ | _, Psibar, TVA, Psi | _, Psibar, TVAM, Psi
+ | _, Psibar, TLR, Psi | _, Psibar, TLRM, Psi
+ | _, Psibar, TRL, Psi | _, Psibar, TRLM, Psi -> failwith
+ "print_current: V3: Momentum dependent fermion couplings not implemented"
+ | _, _, _, _ ->
+ ferm_print_current (coeff, fb, b, f) lhs c wf1 wf2 fusion
+ end
+ | PBP (_, _, _, _) ->
+ failwith "print_current: V3: PBP not implemented"
+ | BBB (_, _, _, _) ->
+ failwith "print_current: V3: BBB not implemented"
+ | GBG (_, _, _, _) ->
+ failwith "print_current: V3: GBG not implemented"
+
+ | Gauge_Gauge_Gauge coeff ->
+ let printc r1 r2 r3 r4 = printi ovm_FUSE_G_GG
+ ~lhs:lhs ~coupl:c ~coeff:coeff ~rhs1:r1 ~rhs2:r2 ~rhs3:r3
+ ~rhs4:r4 in
+ begin match fusion with
+ | (F23|F31|F12) -> printc wf1 p1 wf2 p2
+ | (F32|F13|F21) -> printc wf2 p2 wf1 p1
+ end
+
+ | I_Gauge_Gauge_Gauge _ ->
+ failwith "print_current: I_Gauge_Gauge_Gauge: not implemented"
+
+ | Scalar_Vector_Vector coeff ->
+ let printc code r1 r2 = printi code
+ ~lhs:lhs ~coupl:c ~coeff:coeff ~rhs1:r1 ~rhs2:r2 in
+ begin match fusion with
+ | (F23|F32) -> printc ovm_FUSE_S_VV wf1 wf2
+ | (F12|F13) -> printc ovm_FUSE_V_SV wf1 wf2
+ | (F21|F31) -> printc ovm_FUSE_V_SV wf2 wf1
+ end
+
+ | Scalar_Scalar_Scalar coeff ->
+ printi ovm_FUSE_S_SS ~lhs:lhs ~coupl:c ~coeff:coeff ~rhs1:wf1 ~rhs2:wf2
+
+ | Vector_Scalar_Scalar coeff ->
+ let printc code ?flip:(f = 1) r1 r2 r3 r4 = printi code
+ ~lhs:lhs ~coupl:(c*f) ~coeff:coeff ~rhs1:r1 ~rhs2:r2 ~rhs3:r3
+ ~rhs4:r4 in
+ begin match fusion with
+ | F23 -> printc ovm_FUSE_V_SS wf1 p1 wf2 p2
+ | F32 -> printc ovm_FUSE_V_SS wf2 p2 wf1 p1
+ | F12 -> printc ovm_FUSE_S_VS wf1 p1 wf2 p2
+ | F21 -> printc ovm_FUSE_S_VS wf2 p2 wf1 p1
+ | F13 -> printc ovm_FUSE_S_VS wf1 p1 wf2 p2 ~flip:(-1)
+ | F31 -> printc ovm_FUSE_S_VS wf2 p2 wf1 p1 ~flip:(-1)
+ end
+
+ | Aux_Vector_Vector _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Aux_Scalar_Scalar _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Aux_Scalar_Vector _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Graviton_Scalar_Scalar _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Graviton_Vector_Vector _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Graviton_Spinor_Spinor _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Dim4_Vector_Vector_Vector_T _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Dim4_Vector_Vector_Vector_L _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Dim6_Gauge_Gauge_Gauge _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Dim4_Vector_Vector_Vector_T5 _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Dim4_Vector_Vector_Vector_L5 _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Dim6_Gauge_Gauge_Gauge_5 _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Aux_DScalar_DScalar _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Aux_Vector_DScalar _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Dim5_Scalar_Gauge2 coeff ->
+ let printc code r1 r2 r3 r4 = printi code
+ ~lhs:lhs ~coupl:c ~coeff:coeff ~rhs1:r1 ~rhs2:r2 ~rhs3:r3
+ ~rhs4:r4 in
+ begin match fusion with
+ | (F23|F32) -> printc ovm_FUSE_S_G2 wf1 p1 wf2 p2
+ | (F12|F13) -> printc ovm_FUSE_G_SG wf1 p1 wf2 p2
+ | (F21|F31) -> printc ovm_FUSE_G_GS wf2 p2 wf1 p1
+ end
+
+ | Dim5_Scalar_Gauge2_Skew coeff ->
+ let printc code ?flip:(f = 1) r1 r2 r3 r4 = printi code
+ ~lhs:lhs ~coupl:(c*f) ~coeff:coeff ~rhs1:r1 ~rhs2:r2 ~rhs3:r3
+ ~rhs4:r4 in
+ begin match fusion with
+ | (F23|F32) -> printc ovm_FUSE_S_G2_SKEW wf1 p1 wf2 p2
+ | (F12|F13) -> printc ovm_FUSE_G_SG_SKEW wf1 p1 wf2 p2
+ | (F21|F31) -> printc ovm_FUSE_G_GS_SKEW wf2 p1 wf1 p2 ~flip:(-1)
+ end
+
+ | Dim5_Scalar_Vector_Vector_T _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Dim5_Scalar_Vector_Vector_U _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Dim5_Scalar_Scalar2 _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Dim6_Vector_Vector_Vector_T _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Tensor_2_Vector_Vector _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Tensor_2_Scalar_Scalar _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Dim5_Tensor_2_Vector_Vector_1 _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Dim5_Tensor_2_Vector_Vector_2 _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Dim7_Tensor_2_Vector_Vector_T _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Dim5_Scalar_Vector_Vector_TU _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Scalar_Vector_Vector_t _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Tensor_2_Vector_Vector_cf _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Tensor_2_Scalar_Scalar_cf _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Tensor_2_Vector_Vector_1 _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Tensor_2_Vector_Vector_t _ ->
+ failwith "print_current: V3: not implemented"
+
+ | TensorVector_Vector_Vector _ ->
+ failwith "print_current: V3: not implemented"
+
+ | TensorVector_Vector_Vector_cf _ ->
+ failwith "print_current: V3: not implemented"
+
+ | TensorVector_Scalar_Scalar _ ->
+ failwith "print_current: V3: not implemented"
+
+ | TensorVector_Scalar_Scalar_cf _ ->
+ failwith "print_current: V3: not implemented"
+
+ | TensorScalar_Vector_Vector _ ->
+ failwith "print_current: V3: not implemented"
+
+ | TensorScalar_Vector_Vector_cf _ ->
+ failwith "print_current: V3: not implemented"
+
+ | TensorScalar_Scalar_Scalar _ ->
+ failwith "print_current: V3: not implemented"
+
+ | TensorScalar_Scalar_Scalar_cf _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Dim6_Scalar_Vector_Vector_D _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Dim6_Scalar_Vector_Vector_DP _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Dim6_HAZ_D _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Dim6_HAZ_DP _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Dim6_HHH _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Dim6_Gauge_Gauge_Gauge_i _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Gauge_Gauge_Gauge_i _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Dim6_GGG _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Dim6_AWW_DP _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Dim6_AWW_DW _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Dim6_WWZ_DPWDW _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Dim6_WWZ_DW _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Dim6_WWZ_D _ ->
+ failwith "print_current: V3: not implemented"
+
+ | Aux_Gauge_Gauge _ ->
+ failwith "print_current: V3 (Aux_Gauge_Gauge): not implemented"
+
+ end
+
+(* Flip the sign in [c] to account for the~$\mathrm{i}^2$ relative to diagrams
+ with only cubic couplings. *)
+ | V4 (vertex, fusion, constant) ->
+ let ch1, ch2, ch3 = children3 rhs in
+ let wf1 = wf_index lookups.wfmap lookups.n_wfs (f ch1)
+ and wf2 = wf_index lookups.wfmap lookups.n_wfs (f ch2)
+ and wf3 = wf_index lookups.wfmap lookups.n_wfs (f ch3)
+ (*i
+ (*and p1 = mom_ID lookups.pmap ch1*)
+ (*and p2 = mom_ID lookups.pmap ch2*)
+ (*and p3 = mom_ID lookups.pmap ch2*)
+ i*)
+ and const_ID = get_const_ID lookups.cmap constant in
+ let c =
+ if (F.sign rhs) < 0 then const_ID else - const_ID in
+ begin match vertex with
+ | Scalar4 coeff ->
+ printi ovm_FUSE_S_SSS ~lhs:lhs ~coupl:c ~coeff:coeff ~rhs1:wf1
+ ~rhs2:wf2 ~rhs3:wf3
+ | Scalar2_Vector2 coeff ->
+ let printc code r1 r2 r3 = printi code
+ ~lhs:lhs ~coupl:c ~coeff:coeff ~rhs1:r1 ~rhs2:r2 ~rhs3:r3 in
+ begin match fusion with
+ | F134 | F143 | F234 | F243 ->
+ printc ovm_FUSE_S_SVV wf1 wf2 wf3
+ | F314 | F413 | F324 | F423 ->
+ printc ovm_FUSE_S_SVV wf2 wf1 wf3
+ | F341 | F431 | F342 | F432 ->
+ printc ovm_FUSE_S_SVV wf3 wf1 wf2
+ | F312 | F321 | F412 | F421 ->
+ printc ovm_FUSE_V_SSV wf2 wf3 wf1
+ | F231 | F132 | F241 | F142 ->
+ printc ovm_FUSE_V_SSV wf1 wf3 wf2
+ | F123 | F213 | F124 | F214 ->
+ printc ovm_FUSE_V_SSV wf1 wf2 wf3
+ end
+
+ | Vector4 contractions ->
+ List.iter (print_vector4 c lhs wf1 wf2 wf3 fusion) contractions
+
+ | Vector4_K_Matrix_tho _
+ | Vector4_K_Matrix_jr _
+ | Vector4_K_Matrix_cf_t0 _
+ | Vector4_K_Matrix_cf_t1 _
+ | Vector4_K_Matrix_cf_t2 _
+ | Vector4_K_Matrix_cf_t_rsi _
+ | Vector4_K_Matrix_cf_m0 _
+ | Vector4_K_Matrix_cf_m1 _
+ | Vector4_K_Matrix_cf_m7 _
+ | DScalar2_Vector2_K_Matrix_ms _
+ | DScalar2_Vector2_m_0_K_Matrix_cf _
+ | DScalar2_Vector2_m_1_K_Matrix_cf _
+ | DScalar2_Vector2_m_7_K_Matrix_cf _
+ | DScalar4_K_Matrix_ms _ ->
+ failwith "print_current: V4: K_Matrix not implemented"
+ | Dim8_Scalar2_Vector2_1 _
+ | Dim8_Scalar2_Vector2_2 _
+ | Dim8_Scalar2_Vector2_m_0 _
+ | Dim8_Scalar2_Vector2_m_1 _
+ | Dim8_Scalar2_Vector2_m_7 _
+ | Dim8_Scalar4 _ ->
+ failwith "print_current: V4: not implemented"
+ | Dim8_Vector4_t_0 _ ->
+ failwith "print_current: V4: not implemented"
+ | Dim8_Vector4_t_1 _ ->
+ failwith "print_current: V4: not implemented"
+ | Dim8_Vector4_t_2 _ ->
+ failwith "print_current: V4: not implemented"
+ | Dim8_Vector4_m_0 _ ->
+ failwith "print_current: V4: not implemented"
+ | Dim8_Vector4_m_1 _ ->
+ failwith "print_current: V4: not implemented"
+ | Dim8_Vector4_m_7 _ ->
+ failwith "print_current: V4: not implemented"
+ | GBBG _ ->
+ failwith "print_current: V4: GBBG not implemented"
+ | DScalar4 _
+ | DScalar2_Vector2 _ ->
+ failwith "print_current: V4: DScalars not implemented"
+ | Dim6_H4_P2 _ ->
+ failwith "print_current: V4: not implemented"
+ | Dim6_AHWW_DPB _ ->
+ failwith "print_current: V4: not implemented"
+ | Dim6_AHWW_DPW _ ->
+ failwith "print_current: V4: not implemented"
+ | Dim6_AHWW_DW _ ->
+ failwith "print_current: V4: not implemented"
+ | Dim6_Vector4_DW _ ->
+ failwith "print_current: V4: not implemented"
+ | Dim6_Vector4_W _ ->
+ failwith "print_current: V4: not implemented"
+ | Dim6_Scalar2_Vector2_D _ ->
+ failwith "print_current: V4: not implemented"
+ | Dim6_Scalar2_Vector2_DP _ ->
+ failwith "print_current: V4: not implemented"
+ | Dim6_HWWZ_DW _ ->
+ failwith "print_current: V4: not implemented"
+ | Dim6_HWWZ_DPB _ ->
+ failwith "print_current: V4: not implemented"
+ | Dim6_HWWZ_DDPW _ ->
+ failwith "print_current: V4: not implemented"
+ | Dim6_HWWZ_DPW _ ->
+ failwith "print_current: V4: not implemented"
+ | Dim6_AHHZ_D _ ->
+ failwith "print_current: V4: not implemented"
+ | Dim6_AHHZ_DP _ ->
+ failwith "print_current: V4: not implemented"
+ | Dim6_AHHZ_PB _ ->
+ failwith "print_current: V4: not implemented"
+ | Dim6_Scalar2_Vector2_PB _ ->
+ failwith "print_current: V4: not implemented"
+ | Dim6_HHZZ_T _ ->
+ failwith "print_current: V4: not implemented"
+
+ end
+
+ | Vn (_, _, _) -> invalid_arg "Targets.print_current: n-ary fusion."
+
+(* \thocwmodulesubsection{Fusions} *)
+
+ let print_fusion lookups lhs_momID fusion amplitude =
+ if F.on_shell amplitude (F.lhs fusion) then
+ failwith "print_fusion: on_shell projectors not implemented!";
+ if F.is_gauss amplitude (F.lhs fusion) then
+ failwith "print_fusion: gauss amplitudes not implemented!";
+ let lhs_wf = mult_wf lookups.dict amplitude (F.lhs fusion) in
+ let lhs_wfID = wf_index lookups.wfmap lookups.n_wfs lhs_wf in
+ let f = F.flavor (F.lhs fusion) in
+ let pdg = SCM.pdg f in
+ let w =
+ begin match SCM.width f with
+ | Vanishing | Fudged -> 0
+ | Constant -> 1
+ | Timelike -> 2
+ | Complex_Mass -> 3
+ | Running -> 4
+ | Custom _ -> failwith "Targets.VM: custom width not available"
+ end
+ in
+ let propagate code = printi code ~lhs:lhs_wfID ~rhs1:lhs_momID
+ ~coupl:(abs(pdg)) ~coeff:w ~rhs4:(get_ID' amp_compare lookups.amap amplitude)
+ in
+ begin match SCM.propagator f with
+ | Prop_Scalar ->
+ propagate ovm_PROPAGATE_SCALAR
+ | Prop_Col_Scalar ->
+ propagate ovm_PROPAGATE_COL_SCALAR
+ | Prop_Ghost ->
+ propagate ovm_PROPAGATE_GHOST
+ | Prop_Spinor ->
+ propagate ovm_PROPAGATE_SPINOR
+ | Prop_ConjSpinor ->
+ propagate ovm_PROPAGATE_CONJSPINOR
+ | Prop_Majorana ->
+ propagate ovm_PROPAGATE_MAJORANA
+ | Prop_Col_Majorana ->
+ propagate ovm_PROPAGATE_COL_MAJORANA
+ | Prop_Unitarity ->
+ propagate ovm_PROPAGATE_UNITARITY
+ | Prop_Col_Unitarity ->
+ propagate ovm_PROPAGATE_COL_UNITARITY
+ | Prop_Feynman ->
+ propagate ovm_PROPAGATE_FEYNMAN
+ | Prop_Col_Feynman ->
+ propagate ovm_PROPAGATE_COL_FEYNMAN
+ | Prop_Vectorspinor ->
+ propagate ovm_PROPAGATE_VECTORSPINOR
+ | Prop_Tensor_2 ->
+ propagate ovm_PROPAGATE_TENSOR2
+ | Aux_Col_Scalar | Aux_Col_Vector | Aux_Col_Tensor_1 ->
+ failwith "print_fusion: Aux_Col_* not implemented!"
+ | Aux_Vector | Aux_Tensor_1 | Aux_Scalar | Aux_Spinor | Aux_ConjSpinor
+ | Aux_Majorana | Only_Insertion ->
+ propagate ovm_PROPAGATE_NONE
+ | Prop_Gauge _ ->
+ failwith "print_fusion: Prop_Gauge not implemented!"
+ | Prop_Tensor_pure ->
+ failwith "print_fusion: Prop_Tensor_pure not implemented!"
+ | Prop_Vector_pure ->
+ failwith "print_fusion: Prop_Vector_pure not implemented!"
+ | Prop_Rxi _ ->
+ failwith "print_fusion: Prop_Rxi not implemented!"
+ | Prop_UFO _ ->
+ failwith "print_fusion: Prop_UFO not implemented!"
+ end;
+
+(* Since the OVM knows that we want to propagate a wf, we can send the
+ necessary fusions now. *)
+
+ List.iter (print_current lookups lhs_wfID amplitude) (F.rhs fusion)
+
+ let print_all_fusions lookups =
+ let fusions = CF.fusions lookups.amplitudes in
+ let fset = List.fold_left (fun s x -> FSet.add x s) FSet.empty fusions in
+ ignore (List.fold_left (fun level (f, amplitude) ->
+ let wf = F.lhs f in
+ let lhs_momID = mom_ID lookups.pmap wf in
+ let level' = List.length (F.momentum_list wf) in
+ if (level' > level && level' > 2) then break ();
+ print_fusion lookups lhs_momID f amplitude;
+ level')
+ 1 (FSet.elements fset) )
+
+(* \thocwmodulesubsection{Brakets} *)
+
+ let print_braket lookups amplitude braket =
+ let bra = F.bra braket
+ and ket = F.ket braket in
+ let braID = wf_index lookups.wfmap lookups.n_wfs
+ (mult_wf lookups.dict amplitude bra) in
+ List.iter (print_current lookups braID amplitude) ket
+
+(* \begin{equation}
+ \ii T = \ii^{\#\text{vertices}}\ii^{\#\text{propagators}} \cdots
+ = \ii^{n-2}\ii^{n-3} \cdots
+ = -\ii(-1)^n \cdots
+ \end{equation} *)
+
+(* All brakets for one cflow amplitude should be calculated by one
+ thread to avoid multiple access on the same memory (amplitude).*)
+
+ let print_brakets lookups (amplitude, i) =
+ let n = List.length (F.externals amplitude) in
+ let sign = if n mod 2 = 0 then -1 else 1
+ and sym = F.symmetry amplitude in
+ printi ovm_CALC_BRAKET ~lhs:i ~rhs1:sym ~coupl:sign;
+ match F.brakets amplitude with
+ |[([], brakets)] -> List.iter (print_braket lookups amplitude) brakets
+ | _ -> failwith "Targets.VM().print_brakets: coupling order slices not supported yet"
+
+(* Fortran arrays/OCaml lists start on 1/0. The amplitude list is sorted by
+ [amp_compare] according to their color flows. In this way the amp array
+ is sorted in the same way as [table_color_factors]. *)
+
+ let print_all_brakets lookups =
+ let g i elt = print_brakets lookups (elt, i+1) in
+ lookups.amplitudes |> CF.processes |> List.sort amp_compare
+ |> ThoList.iteri g 0
+
+(* \thocwmodulesubsection{Couplings} *)
+
+(* For now we only care to catch the arrays [gncneu], [gnclep], [gncup] and
+ [gncdown] of the SM. This will need an overhaul when it is clear how we store
+ the type information of coupling constants. *)
+
+ let strip_array_tag = function
+ | Real_Array x -> x
+ | Complex_Array x -> x
+
+ let array_constants_list =
+ let params = M.parameters()
+ and strip_to_constant (lhs, _) = strip_array_tag lhs in
+ List.map strip_to_constant params.derived_arrays
+
+ let is_array x = List.mem x array_constants_list
+
+ let constants_map =
+ let first = fun (x, _, _) -> x in
+ let second = fun (_, y, _) -> y in
+ let third = fun (_, _, z) -> z in
+ let v3 = List.map third (first (M.vertices () ))
+ and v4 = List.map third (second (M.vertices () )) in
+ let set = List.fold_left (fun s x -> CSet.add x s) CSet.empty (v3 @ v4) in
+ let (arrays, singles) = CSet.partition is_array set in
+ (singles |> CSet.elements |> map_of_list,
+ arrays |> CSet.elements |> map_of_list)
+
+(* \thocwmodulesubsection{Output calls} *)
+
+ let amplitudes_to_channel (cmdline : string) (oc : out_channel)
+ (diagnostics : (diagnostic * bool) list ) (amplitudes : CF.amplitudes) =
+
+ set_formatter_out_channel oc;
+ if (num_particles amplitudes = 0) then begin
+ print_description cmdline;
+ print_zero_header (); nl ()
+ end else begin
+ let (wfset, amap) = wfset_amps amplitudes in
+ let pset = expand_pset (momenta_set wfset)
+ and n_wfs = num_wfs wfset in
+ let wfmap = wf_map_of_list (WFSet.elements wfset)
+ and pmap = map_of_list (ISet.elements pset)
+ and cmap = constants_map in
+
+ let lookups = {pmap = pmap; wfmap = wfmap; cmap = cmap; amap = amap;
+ n_wfs = n_wfs; amplitudes = amplitudes;
+ dict = CF.dictionary amplitudes} in
+
+ print_description cmdline;
+ print_header lookups wfset;
+ print_spin_table amplitudes;
+ print_flavor_tables amplitudes;
+ print_color_tables amplitudes;
+ printf "@\n%s" ("OVM instructions for momenta addition," ^
+ " fusions and brakets start here: ");
+ break ();
+ add_all_mom lookups pset;
+ print_ext_amps lookups;
+ break ();
+ print_all_fusions lookups;
+ break ();
+ print_all_brakets lookups;
+ break (); nl ();
+ print_flush ()
+ end
+
+ let parameters_to_fortran oc _ =
+ (*i The -params options is used as wrapper between OVM and Whizard. Most
+ * trouble for the OVM comes from the array dimensionalities of couplings
+ * but O'Mega should also know whether a constant is real or complex.
+ * Hopefully all will be clearer with the fully general Lorentz structures
+ * and UFO support. For now, we stick with this brute-force solution. i*)
+ set_formatter_out_channel oc;
+ let arrays_to_set = not (IMap.is_empty (snd constants_map)) in
+ let set_coupl ty dim cmap = IMap.iter (fun key elt ->
+ printf " %s(%s%d) = %s" ty dim key (M.constant_symbol elt);
+ nl () ) cmap in
+ let declarations () =
+ printf " complex(%s), dimension(%d) :: ovm_coupl_cmplx"
+ !kind (constants_map |> fst |> largest_key); nl ();
+ if arrays_to_set then
+ printf " complex(%s), dimension(2, %d) :: ovm_coupl_cmplx2"
+ !kind (constants_map |> snd |> largest_key); nl () in
+ let print_line str = printf "%s" str; nl() in
+ let print_md5sum = function
+ | Some s ->
+ print_line " function md5sum ()";
+ print_line " character(len=32) :: md5sum";
+ print_line (" bytecode_file = '" ^ !bytecode_file ^ "'");
+ print_line " call initialize_vm (vm, bytecode_file)";
+ print_line " ! DON'T EVEN THINK of modifying the following line!";
+ print_line (" md5sum = '" ^ s ^ "'");
+ print_line " end function md5sum";
+ | None -> ()
+ in
+ let print_inquiry_function_openmp () = begin
+ print_line " pure function openmp_supported () result (status)";
+ print_line " logical :: status";
+ print_line (" status = " ^ (if !openmp then ".true." else ".false."));
+ print_line " end function openmp_supported";
+ nl ()
+ end in
+ let print_interface whizard =
+ if whizard then begin
+ print_line " subroutine init (par, scheme)";
+ print_line " real(kind=default), dimension(*), intent(in) :: par";
+ print_line " integer, intent(in) :: scheme";
+ print_line (" bytecode_file = '" ^ !bytecode_file ^ "'");
+ print_line " call import_from_whizard (par, scheme)";
+ print_line " call initialize_vm (vm, bytecode_file)";
+ print_line " end subroutine init";
+ nl ();
+ print_line " subroutine final ()";
+ print_line " call vm%final ()";
+ print_line " end subroutine final";
+ nl ();
+ print_line " subroutine update_alpha_s (alpha_s)";
+ print_line (" real(kind=" ^ !kind ^ "), intent(in) :: alpha_s");
+ print_line " call model_update_alpha_s (alpha_s)";
+ print_line " end subroutine update_alpha_s";
+ nl ()
+ end
+ else begin
+ print_line " subroutine init ()";
+ print_line (" bytecode_file = '" ^ !bytecode_file ^ "'");
+ print_line " call init_parameters ()";
+ print_line " call initialize_vm (vm, bytecode_file)";
+ print_line " end subroutine"
+ end in
+ let print_lookup_functions () = begin
+ print_line " pure function number_particles_in () result (n)";
+ print_line " integer :: n";
+ print_line " n = vm%number_particles_in ()";
+ print_line " end function number_particles_in";
+ nl();
+ print_line " pure function number_particles_out () result (n)";
+ print_line " integer :: n";
+ print_line " n = vm%number_particles_out ()";
+ print_line " end function number_particles_out";
+ nl();
+ print_line " pure function number_spin_states () result (n)";
+ print_line " integer :: n";
+ print_line " n = vm%number_spin_states ()";
+ print_line " end function number_spin_states";
+ nl();
+ print_line " pure subroutine spin_states (a)";
+ print_line " integer, dimension(:,:), intent(out) :: a";
+ print_line " call vm%spin_states (a)";
+ print_line " end subroutine spin_states";
+ nl();
+ print_line " pure function number_flavor_states () result (n)";
+ print_line " integer :: n";
+ print_line " n = vm%number_flavor_states ()";
+ print_line " end function number_flavor_states";
+ nl();
+ print_line " pure subroutine flavor_states (a)";
+ print_line " integer, dimension(:,:), intent(out) :: a";
+ print_line " call vm%flavor_states (a)";
+ print_line " end subroutine flavor_states";
+ nl();
+ print_line " pure function number_color_indices () result (n)";
+ print_line " integer :: n";
+ print_line " n = vm%number_color_indices ()";
+ print_line " end function number_color_indices";
+ nl();
+ print_line " pure function number_color_flows () result (n)";
+ print_line " integer :: n";
+ print_line " n = vm%number_color_flows ()";
+ print_line " end function number_color_flows";
+ nl();
+ print_line " pure subroutine color_flows (a, g)";
+ print_line " integer, dimension(:,:,:), intent(out) :: a";
+ print_line " logical, dimension(:,:), intent(out) :: g";
+ print_line " call vm%color_flows (a, g)";
+ print_line " end subroutine color_flows";
+ nl();
+ print_line " pure function number_color_factors () result (n)";
+ print_line " integer :: n";
+ print_line " n = vm%number_color_factors ()";
+ print_line " end function number_color_factors";
+ nl();
+ print_line " pure subroutine color_factors (cf)";
+ print_line " use omega_color";
+ print_line " type(omega_color_factor), dimension(:), intent(out) :: cf";
+ print_line " call vm%color_factors (cf)";
+ print_line " end subroutine color_factors";
+ nl();
+ print_line " !pure unless OpenMP";
+ print_line " !pure function color_sum (flv, hel) result (amp2)";
+ print_line " function color_sum (flv, hel) result (amp2)";
+ print_line " use kinds";
+ print_line " integer, intent(in) :: flv, hel";
+ print_line " real(kind=default) :: amp2";
+ print_line " amp2 = vm%color_sum (flv, hel)";
+ print_line " end function color_sum";
+ nl();
+ print_line " subroutine new_event (p)";
+ print_line " use kinds";
+ print_line " real(kind=default), dimension(0:3,*), intent(in) :: p";
+ print_line " call vm%new_event (p)";
+ print_line " end subroutine new_event";
+ nl();
+ print_line " subroutine reset_helicity_selection (threshold, cutoff)";
+ print_line " use kinds";
+ print_line " real(kind=default), intent(in) :: threshold";
+ print_line " integer, intent(in) :: cutoff";
+ print_line " call vm%reset_helicity_selection (threshold, cutoff)";
+ print_line " end subroutine reset_helicity_selection";
+ nl();
+ print_line " pure function is_allowed (flv, hel, col) result (yorn)";
+ print_line " logical :: yorn";
+ print_line " integer, intent(in) :: flv, hel, col";
+ print_line " yorn = vm%is_allowed (flv, hel, col)";
+ print_line " end function is_allowed";
+ nl();
+ print_line " pure function get_amplitude (flv, hel, col) result (amp_result)";
+ print_line " use kinds";
+ print_line " complex(kind=default) :: amp_result";
+ print_line " integer, intent(in) :: flv, hel, col";
+ print_line " amp_result = vm%get_amplitude(flv, hel, col)";
+ print_line " end function get_amplitude";
+ nl();
+ end in
+ print_line ("module " ^ !wrapper_module);
+ print_line (" use " ^ !parameter_module_external);
+ print_line " use iso_varying_string, string_t => varying_string";
+ print_line " use kinds";
+ print_line " use omegavm95";
+ print_line " implicit none";
+ print_line " private";
+ print_line " type(vm_t) :: vm";
+ print_line " type(string_t) :: bytecode_file";
+ print_line (" public :: number_particles_in, number_particles_out," ^
+ " number_spin_states, &");
+ print_line (" spin_states, number_flavor_states, flavor_states," ^
+ " number_color_indices, &");
+ print_line (" number_color_flows, color_flows," ^
+ " number_color_factors, color_factors, &");
+ print_line (" color_sum, new_event, reset_helicity_selection," ^
+ " is_allowed, get_amplitude, &");
+ print_line (" init, " ^
+ (match !md5sum with Some _ -> "md5sum, "
+ | None -> "") ^ "openmp_supported");
+ if !whizard then
+ print_line (" public :: final, update_alpha_s")
+ else
+ print_line (" public :: initialize_vm");
+ declarations ();
+ print_line "contains";
+
+ print_line " subroutine setup_couplings ()";
+ set_coupl "ovm_coupl_cmplx" "" (fst constants_map);
+ if arrays_to_set then
+ set_coupl "ovm_coupl_cmplx2" ":," (snd constants_map);
+ print_line " end subroutine setup_couplings";
+ print_line " subroutine initialize_vm (vm, bytecode_file)";
+ print_line " class(vm_t), intent(out) :: vm";
+ print_line " type(string_t), intent(in) :: bytecode_file";
+ print_line " type(string_t) :: version";
+ print_line " type(string_t) :: model";
+ print_line (" version = 'OVM " ^ version ^ "'");
+ print_line (" model = 'Model " ^ model_name ^ "'");
+ print_line " call setup_couplings ()";
+ print_line " call vm%init (bytecode_file, version, model, verbose=.False., &";
+ print_line " coupl_cmplx=ovm_coupl_cmplx, &";
+ if arrays_to_set then
+ print_line " coupl_cmplx2=ovm_coupl_cmplx2, &";
+ print_line (" mass=mass, width=width, openmp=" ^ (if !openmp then
+ ".true." else ".false.") ^ ")");
+ print_line " end subroutine initialize_vm";
+ nl();
+ print_md5sum !md5sum;
+ print_inquiry_function_openmp ();
+ print_interface !whizard;
+ print_lookup_functions ();
+
+ print_line ("end module " ^ !wrapper_module)
+
+ let parameters_to_channel oc =
+ parameters_to_fortran oc (SCM.parameters ())
+
+ end
Index: trunk/omega/src/algebra.ml
===================================================================
--- trunk/omega/src/algebra.ml (revision 8899)
+++ trunk/omega/src/algebra.ml (revision 8900)
@@ -1,809 +1,848 @@
(* algebra.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-(* Avoid refering to [Pervasives.compare], because [Pervasives] will
- become [Stdlib.Pervasives] in O'Caml 4.07 and [Stdlib] in O'Caml 4.08. *)
-let pcompare = compare
-
module type Test =
sig
val suite : OUnit.test
end
(* The terms will be small and there's no need to be fancy and/or efficient.
It's more important to have a unique representation. *)
module PM = Pmap.List
(* \thocwmodulesection{Coefficients} *)
-(* For our algebra, we need coefficient rings. *)
-
module type CRing =
sig
type t
val null : t
- val unit : t
- val mul : t -> t -> t
+ val is_null : t -> bool
val add : t -> t -> t
- val sub : t -> t -> t
val neg : t -> t
- val to_string : t -> string
+ val sub : t -> t -> t
+ val unit : t
+ val is_unit : t -> bool
+ val mul : t -> t -> t
+ val equal : t -> t -> bool
end
-(* And rational numbers provide a particularly important example: *)
-
module type Rational =
sig
include CRing
- val is_null : t -> bool
- val is_unit : t -> bool
val is_positive : t -> bool
val is_negative : t -> bool
val is_integer : t -> bool
val make : int -> int -> t
val abs : t -> t
val inv : t -> t
val div : t -> t -> t
val pow : t -> int -> t
val sum : t list -> t
val to_ratio : t -> int * int
val to_float : t -> float
val to_integer : t -> int
+ val int : int -> t
+ val fraction : int -> t
+ val compare : t -> t -> int
+ val to_string : t -> string
+ val pp : Format.formatter -> t -> unit
module Test : Test
end
(* \thocwmodulesection{Naive Rational Arithmetic} *)
(* \begin{dubious}
This \emph{is} dangerous and will overflow even for simple
applications. The production code will have to be linked to
a library for large integer arithmetic.
\end{dubious} *)
(* Anyway, here's Euclid's algorithm: *)
let rec gcd i1 i2 =
if i2 = 0 then
abs i1
else
gcd i2 (i1 mod i2)
let lcm i1 i2 = (i1 / gcd i1 i2) * i2
let abs_int = abs
module Small_Rational : Rational =
struct
+
type t = int * int
+
let is_null (n, _) = (n = 0)
let is_unit (n, d) = (n <> 0) && (n = d)
let is_positive (n, d) = n * d > 0
let is_negative (n, d) = n * d < 0
let is_integer (n, d) = (gcd n d = d)
+
let null = (0, 1)
let unit = (1, 1)
+
let make n d =
let c = gcd n d in
(n / c, d / c)
+
let abs (n, d) = (abs n, abs d)
let inv (n, d) = (d, n)
let mul (n1, d1) (n2, d2) = make (n1 * n2) (d1 * d2)
let div q1 q2 = mul q1 (inv q2)
let add (n1, d1) (n2, d2) = make (n1 * d2 + n2 * d1) (d1 * d2)
let sub (n1, d1) (n2, d2) = make (n1 * d2 - n2 * d1) (d1 * d2)
let neg (n, d) = (- n, d)
+
let rec pow q p =
if p = 0 then
unit
else if p < 0 then
pow (inv q) (-p)
else
mul q (pow q (pred p))
+
let sum qs =
List.fold_right add qs null
+
let to_ratio (n, d) =
if d < 0 then
(-n, -d)
else
(n, d)
+
let to_float (n, d) = float n /. float d
+
let to_string (n, d) =
if abs_int d = 1 then
Printf.sprintf "%d" (d * n)
else
let n, d = to_ratio (n, d) in
Printf.sprintf "(%d/%d)" n d
+
+ let pp fmt qc =
+ Format.fprintf fmt "%s" (to_string qc)
+
let to_integer (n, d) =
if is_integer (n, d) then
n
else
invalid_arg "Algebra.Small_Rational.to_integer"
+ let int n = make n 1
+ let fraction n = make 1 n
+
+ let compare q1 q2 =
+ let n1, d1 = to_ratio q1
+ and n2, d2 = to_ratio q2 in
+ compare (d2 * n1) (d1 * n2)
+
+ let equal (n1, d1) (n2, d2) =
+ d2 * n1 = d1 * n2
+
module Test =
struct
open OUnit
- let equal z1 z2 =
- is_null (sub z1 z2)
-
let assert_equal_rational z1 z2 =
assert_equal ~printer:to_string ~cmp:equal z1 z2
let suite_mul =
"mul" >:::
[ "1*1=1" >::
(fun () ->
assert_equal_rational (mul unit unit) unit) ]
let suite =
"Algebra.Small_Rational" >:::
[suite_mul]
end
end
module Q = Small_Rational
(* \thocwmodulesection{Rational Complex Numbers} *)
module type QComplex =
sig
-
+ include CRing
type q
- type t
-
val make : q -> q -> t
- val null : t
- val unit : t
-
- val real : t -> q
- val imag : t -> q
-
+ val re : t -> q
+ val im : t -> q
val conj : t -> t
- val neg : t -> t
-
- val add : t -> t -> t
- val sub : t -> t -> t
- val mul : t -> t -> t
val inv : t -> t
val div : t -> t -> t
-
val pow : t -> int -> t
val sum : t list -> t
-
- val is_null : t -> bool
- val is_unit : t -> bool
val is_positive : t -> bool
val is_negative : t -> bool
val is_integer : t -> bool
val is_real : t -> bool
-
+ val rational : q -> t
+ val int : int -> t
+ val fraction : int -> t
+ val imag : int -> t
+ val compare : t -> t -> int
val to_string : t -> string
-
+ val pp : Format.formatter -> t -> unit
module Test : Test
-
end
module QComplex (Q : Rational) : QComplex with type q = Q.t =
struct
type q = Q.t
type t = { re : q; im : q }
let make re im = { re; im }
let null = { re = Q.null; im = Q.null }
let unit = { re = Q.unit; im = Q.null }
- let real z = z.re
- let imag z = z.im
+ let re z = z.re
+ let im z = z.im
let conj z = { re = z.re; im = Q.neg z.im }
let neg z = { re = Q.neg z.re; im = Q.neg z.im }
let add z1 z2 = { re = Q.add z1.re z2.re; im = Q.add z1.im z2.im }
let sub z1 z2 = { re = Q.sub z1.re z2.re; im = Q.sub z1.im z2.im }
let sum qs =
List.fold_right add qs null
(* Save one multiplication with respect to the standard formula
\begin{equation}
(x+iy)(u+iv) = \lbrack xu-yv\rbrack + i\lbrack(x+u)(y+v)-xu-yv\rbrack\,
\end{equation}
at the expense of one addition and two subtractions. *)
let mul z1 z2 =
let re12 = Q.mul z1.re z2.re
and im12 = Q.mul z1.im z2.im in
{ re = Q.sub re12 im12;
im = Q.sub
(Q.sub (Q.mul (Q.add z1.re z1.im) (Q.add z2.re z2.im)) re12)
im12 }
let inv z =
let modulus = Q.add (Q.mul z.re z.re) (Q.mul z.im z.im) in
{ re = Q.div z.re modulus;
im = Q.div (Q.neg z.im) modulus }
let div n d =
mul (inv d) n
let rec pow q p =
if p = 0 then
unit
else if p < 0 then
pow (inv q) (-p)
else
mul q (pow q (pred p))
let is_real q =
Q.is_null q.im
let test_real test q =
is_real q && test q.re
let is_null = test_real Q.is_null
let is_unit = test_real Q.is_unit
let is_positive = test_real Q.is_positive
let is_negative = test_real Q.is_negative
let is_integer = test_real Q.is_integer
+ let rational q = make q Q.null
+ let int n = rational (Q.int n)
+ let fraction n = rational (Q.fraction n)
+ let imag n = make Q.null (Q.int n)
+
+ let compare { re = re1; im = im1 } { re = re2; im = im2 } =
+ let c = compare re1 re2 in
+ if c <> 0 then
+ c
+ else
+ compare im1 im2
+
+ let equal c1 c2 =
+ compare c1 c2 = 0
+
let q_to_string q =
(if Q.is_negative q then "-" else " ") ^ Q.to_string (Q.abs q)
let to_string z =
if Q.is_null z.im then
q_to_string z.re
else if Q.is_null z.re then
if Q.is_unit z.im then
" I"
else if Q.is_unit (Q.neg z.im) then
"-I"
else
q_to_string z.im ^ "*I"
else
Printf.sprintf "(%s%s*I)" (Q.to_string z.re) (q_to_string z.im)
+ let pp fmt qc =
+ Format.fprintf fmt "%s" (to_string qc)
+
module Test =
struct
open OUnit
- let equal z1 z2 =
- is_null (sub z1 z2)
-
let assert_equal_complex z1 z2 =
assert_equal ~printer:to_string ~cmp:equal z1 z2
let suite_mul =
"mul" >:::
[ "1*1=1" >::
(fun () ->
assert_equal_complex (mul unit unit) unit) ]
let suite =
"Algebra.QComplex" >:::
[suite_mul]
end
end
module QC = QComplex(Q)
(* \thocwmodulesection{Laurent Polynomials} *)
module type Laurent =
sig
+ include CRing
type c
- type t
- val null : t
- val is_null : t -> bool
- val unit : t
val atom : c -> int -> t
val const : c -> t
val scale : c -> t -> t
- val neg : t -> t
- val add : t -> t -> t
- val diff : t -> t -> t
val sum : t list -> t
- val mul : t -> t -> t
val product : t list -> t
- val pow : int -> t -> t
+ val pow : t -> int -> t
+ val log : t -> (c * int) option
+ val to_list : t -> (c * int) list
val eval : c -> t -> c
val compare : t -> t -> int
+ val rationals : (Q.t * int) list -> t
+ val ints : (int * int) list -> t
+ val rational : Q.t -> t
+ val int : int -> t
+ val fraction : int -> t
+ val imag : int -> t
+ val nc : int -> t
+ val over_nc : int -> t
val to_string : string -> t -> string
val pp : Format.formatter -> t -> unit
module Test : Test
end
+
module Laurent : Laurent with type c = QC.t =
struct
- module IMap =
- Map.Make
- (struct
- type t = int
- let compare i1 i2 =
- pcompare i2 i1
- end)
+ module IMap = Map.Make(Int)
type c = QC.t
let qc_minus_one =
QC.neg QC.unit
type t = c IMap.t
let null = IMap.empty
let is_null l = IMap.for_all (fun _ -> QC.is_null) l
let atom qc n =
if qc = QC.null then
null
else
IMap.singleton n qc
let const z = atom z 0
let unit = const QC.unit
+ let is_unit l = IMap.equal QC.equal l unit
let add1 n qc l =
try
let qc' = QC.add qc (IMap.find n l) in
if qc' = QC.null then
IMap.remove n l
else
IMap.add n qc' l
with
| Not_found -> IMap.add n qc l
let add l1 l2 =
IMap.fold add1 l1 l2
let sum = function
| [] -> null
| [l] -> l
| l :: l_list ->
List.fold_left add l l_list
let scale qc l =
IMap.map (QC.mul qc) l
let neg l =
IMap.map QC.neg l
- let diff l1 l2 =
- add l1 (scale qc_minus_one l2)
+ let sub l1 l2 =
+ add l1 (neg l2)
(* cf.~[Product.fold2_rev] *)
let fold2 f l1 l2 acc =
IMap.fold
(fun n1 qc1 acc1 ->
IMap.fold
(fun n2 qc2 acc2 -> f n1 qc1 n2 qc2 acc2)
l2 acc1)
l1 acc
let mul l1 l2 =
fold2
(fun n1 qc1 n2 qc2 acc ->
add1 (n1 + n2) (QC.mul qc1 qc2) acc)
l1 l2 null
let product = function
| [] -> unit
| [l] -> l
| l :: l_list ->
List.fold_left mul l l_list
- let poly_pow multiply one inverse n x =
+ let poly_pow multiply one inverse x n =
let rec pow' i x' acc =
if i < 1 then
acc
else
pow' (pred i) x' (multiply x' acc) in
if n < 0 then
let x' = inverse x in
pow' (pred (-n)) x' x'
else if n = 0 then
one
else
pow' (pred n) x x
- let qc_pow n z =
- poly_pow QC.mul QC.unit QC.inv n z
+ let qc_pow z n =
+ poly_pow QC.mul QC.unit QC.inv z n
- let pow n l =
- poly_pow mul unit (fun _ -> invalid_arg "Algebra.Laurent.pow") n l
+ let pow l n =
+ poly_pow mul unit (fun _ -> invalid_arg "Algebra.Laurent.pow") l n
+
+ let log l =
+ match IMap.bindings l with
+ | [] -> Some (QC.null, 0)
+ | [(p, c)] -> Some (c, p)
+ | _ -> None
+
+ let to_list l =
+ List.map (fun (p, c) -> (c, p)) (IMap.bindings l)
let q_to_string q =
(if Q.is_positive q then "+" else "-") ^ Q.to_string (Q.abs q)
let qc_to_string z =
- let r = QC.real z
- and i = QC.imag z in
+ let r = QC.re z
+ and i = QC.im z in
if Q.is_null i then
q_to_string r
else if Q.is_null r then
if Q.is_unit i then
"+I"
else if Q.is_unit (Q.neg i) then
"-I"
else
q_to_string i ^ "*I"
else
Printf.sprintf "(%s%s*I)" (Q.to_string r) (q_to_string i)
let to_string1 name (n, qc) =
if n = 0 then
qc_to_string qc
else if n = 1 then
if QC.is_unit qc then
name
else if qc = qc_minus_one then
"-" ^ name
else
Printf.sprintf "%s*%s" (qc_to_string qc) name
else if n = -1 then
Printf.sprintf "%s/%s" (qc_to_string qc) name
else if n > 1 then
if QC.is_unit qc then
Printf.sprintf "%s^%d" name n
else if qc = qc_minus_one then
Printf.sprintf "-%s^%d" name n
else
Printf.sprintf "%s*%s^%d" (qc_to_string qc) name n
else
Printf.sprintf "%s/%s^%d" (qc_to_string qc) name (-n)
let to_string name l =
match IMap.bindings l with
| [] -> "0"
| l -> String.concat "" (List.map (to_string1 name) l)
let pp fmt l =
Format.fprintf fmt "%s" (to_string "N" l)
let eval v l =
IMap.fold
- (fun n qc acc -> QC.add (QC.mul qc (qc_pow n v)) acc)
+ (fun n qc acc -> QC.add (QC.mul qc (qc_pow v n)) acc)
l QC.null
let compare l1 l2 =
- pcompare
- (List.sort pcompare (IMap.bindings l1))
- (List.sort pcompare (IMap.bindings l2))
+ IMap.compare Stdlib.compare l1 l2
- let compare l1 l2 =
- IMap.compare pcompare l1 l2
+ let equal l1 l2 =
+ compare l1 l2 = 0
+
+ (* Laurent polynomials: *)
+ let of_pairs f pairs =
+ sum (List.map (fun (coeff, power) -> atom (f coeff) power) pairs)
+
+ let rationals = of_pairs QC.rational
+ let ints = of_pairs QC.int
+
+ let rational q = rationals [(q, 0)]
+ let int n = ints [(n, 0)]
+ let fraction n = const (QC.fraction n)
+ let imag n = const (QC.imag n)
+ let nc n = ints [(n, 1)]
+ let over_nc n = ints [(n, -1)]
module Test =
struct
open OUnit
- let equal l1 l2 =
- compare l1 l2 = 0
-
let assert_equal_laurent l1 l2 =
assert_equal ~printer:(to_string "N") ~cmp:equal l1 l2
let suite_mul =
"mul" >:::
[ "(1+N)(1-N)=1-N^2" >::
(fun () ->
assert_equal_laurent
(sum [unit; atom (QC.neg QC.unit) 2])
(product [sum [unit; atom QC.unit 1];
sum [unit; atom (QC.neg QC.unit) 1]]));
"(1+N)(1-1/N)=N-1/N" >::
(fun () ->
assert_equal_laurent
(sum [atom QC.unit 1; atom (QC.neg QC.unit) (-1)])
(product [sum [unit; atom QC.unit 1];
sum [unit; atom (QC.neg QC.unit) (-1)]])); ]
let suite =
"Algebra.Laurent" >:::
[suite_mul]
end
end
(* \thocwmodulesection{Expressions: Terms, Rings and Linear Combinations} *)
(* The tensor algebra will be spanned by an abelian monoid: *)
module type Term =
sig
type 'a t
val unit : unit -> 'a t
val is_unit : 'a t -> bool
val atom : 'a -> 'a t
- val power : int -> 'a t -> 'a t
+ val power : 'a t -> int -> 'a t
val mul : 'a t -> 'a t -> 'a t
val map : ('a -> 'b) -> 'a t -> 'b t
val to_string : ('a -> string) -> 'a t -> string
val derive : ('a -> 'b option) -> 'a t -> ('b * int * 'a t) list
val product : 'a t list -> 'a t
val atoms : 'a t -> 'a list
end
module type Ring =
sig
module C : Rational
type 'a t
val null : unit -> 'a t
val unit : unit -> 'a t
val is_null : 'a t -> bool
val is_unit : 'a t -> bool
val atom : 'a -> 'a t
val scale : C.t -> 'a t -> 'a t
val add : 'a t -> 'a t -> 'a t
val sub : 'a t -> 'a t -> 'a t
val mul : 'a t -> 'a t -> 'a t
val neg : 'a t -> 'a t
val derive_inner : ('a -> 'a t) -> 'a t -> 'a t (* this? *)
val derive_inner' : ('a -> 'a t option) -> 'a t -> 'a t (* or that? *)
val derive_outer : ('a -> 'b option) -> 'a t -> ('b * 'a t) list
val sum : 'a t list -> 'a t
val product : 'a t list -> 'a t
val atoms : 'a t -> 'a list
val to_string : ('a -> string) -> 'a t -> string
end
module type Linear =
sig
module C : Ring
type ('a, 'c) t
val null : unit -> ('a, 'c) t
val atom : 'a -> ('a, 'c) t
val singleton : 'c C.t -> 'a -> ('a, 'c) t
val scale : 'c C.t -> ('a, 'c) t -> ('a, 'c) t
val add : ('a, 'c) t -> ('a, 'c) t -> ('a, 'c) t
val sub : ('a, 'c) t -> ('a, 'c) t -> ('a, 'c) t
val partial : ('c -> ('a, 'c) t) -> 'c C.t -> ('a, 'c) t
val linear : (('a, 'c) t * 'c C.t) list -> ('a, 'c) t
val map : ('a -> 'c C.t -> ('b, 'd) t) -> ('a, 'c) t -> ('b, 'd) t
val sum : ('a, 'c) t list -> ('a, 'c) t
val atoms : ('a, 'c) t -> 'a list * 'c list
val to_string : ('a -> string) -> ('c -> string) -> ('a, 'c) t -> string
end
module Term : Term =
struct
module M = PM
type 'a t = ('a, int) M.t
let unit () = M.empty
let is_unit = M.is_empty
let atom f = M.singleton f 1
- let power p x = M.map (( * ) p) x
+ let power x p = M.map (( * ) p) x
let insert1 binop f p term =
let p' = binop (try M.find compare f term with Not_found -> 0) p in
if p' = 0 then
M.remove compare f term
else
M.add compare f p' term
let mul1 f p term = insert1 (+) f p term
let mul x y = M.fold mul1 x y
let map f term = M.fold (fun t -> mul1 (f t)) term M.empty
let to_string fmt term =
String.concat "*"
(M.fold (fun f p acc ->
(if p = 0 then
"1"
else if p = 1 then
fmt f
else
"[" ^ fmt f ^ "]^" ^ string_of_int p) :: acc) term [])
let derive derive1 x =
M.fold (fun f p dx ->
if p <> 0 then
match derive1 f with
| Some df -> (df, p, mul1 f (pred p) (M.remove compare f x)) :: dx
| None -> dx
else
dx) x []
let product factors =
List.fold_left mul (unit ()) factors
let atoms t =
List.map fst (PM.elements t)
end
module Make_Ring (C : Rational) (T : Term) : Ring =
struct
module C = C
let one = C.unit
module M = PM
type 'a t = ('a T.t, C.t) M.t
let null () = M.empty
let is_null = M.is_empty
let power t p = M.singleton t p
let unit () = power (T.unit ()) one
let is_unit t = unit () = t
(* \begin{dubious}
The following should be correct too, but produces to many false
positives instead! What's going on?
\end{dubious} *)
let broken__is_unit t =
match M.elements t with
| [(t, p)] -> T.is_unit t || C.is_null p
| _ -> false
let atom t = power (T.atom t) one
let scale c x = M.map (C.mul c) x
let insert1 binop t c sum =
let c' = binop (try M.find compare t sum with Not_found -> C.null) c in
if C.is_null c' then
M.remove compare t sum
else
M.add compare t c' sum
let add x y = M.fold (insert1 C.add) x y
let sub x y = M.fold (insert1 C.sub) y x
(* One might be tempted to use [Product.outer_self M.fold] instead,
but this would require us to combine~[tx] and~[cx] to~[(tx, cx)]. *)
let fold2 f x y =
M.fold (fun tx cx -> M.fold (f tx cx) y) x
let mul x y =
fold2 (fun tx cx ty cy -> insert1 C.add (T.mul tx ty) (C.mul cx cy))
x y (null ())
let neg x =
sub (null ()) x
let neg x =
scale (C.neg C.unit) x
(* Multiply the [derivatives] by [c] and add the result to [dx]. *)
let add_derivatives derivatives c dx =
List.fold_left (fun acc (df, dt_c, dt_t) ->
add (mul df (power dt_t (C.mul c (C.make dt_c 1)))) acc) dx derivatives
let derive_inner derive1 x =
M.fold (fun t ->
add_derivatives (T.derive (fun f -> Some (derive1 f)) t)) x (null ())
let derive_inner' derive1 x =
M.fold (fun t -> add_derivatives (T.derive derive1 t)) x (null ())
let collect_derivatives derivatives c dx =
List.fold_left (fun acc (df, dt_c, dt_t) ->
(df, power dt_t (C.mul c (C.make dt_c 1))) :: acc) dx derivatives
let derive_outer derive1 x =
M.fold (fun t -> collect_derivatives (T.derive derive1 t)) x []
let sum terms =
List.fold_left add (null ()) terms
let product factors =
List.fold_left mul (unit ()) factors
let atoms t =
ThoList.uniq (List.sort compare
(ThoList.flatmap (fun (t, _) -> T.atoms t) (PM.elements t)))
let to_string fmt sum =
"(" ^ String.concat " + "
(M.fold (fun t c acc ->
if C.is_null c then
acc
else if C.is_unit c then
T.to_string fmt t :: acc
else if C.is_unit (C.neg c) then
("(-" ^ T.to_string fmt t ^ ")") :: acc
else
(C.to_string c ^ "*[" ^ T.to_string fmt t ^ "]") :: acc) sum []) ^ ")"
end
module Make_Linear (C : Ring) : Linear with module C = C =
struct
module C = C
module M = PM
type ('a, 'c) t = ('a, 'c C.t) M.t
let null () = M.empty
let is_null = M.is_empty
let atom a = M.singleton a (C.unit ())
let singleton c a = M.singleton a c
let scale c x = M.map (C.mul c) x
let insert1 binop t c sum =
let c' = binop (try M.find compare t sum with Not_found -> C.null ()) c in
if C.is_null c' then
M.remove compare t sum
else
M.add compare t c' sum
let add x y = M.fold (insert1 C.add) x y
let sub x y = M.fold (insert1 C.sub) y x
let map f t =
M.fold (fun a c -> add (f a c)) t M.empty
let sum terms =
List.fold_left add (null ()) terms
let linear terms =
List.fold_left (fun acc (a, c) -> add (scale c a) acc) (null ()) terms
let partial derive t =
let d t' =
let dt' = derive t' in
if is_null dt' then
None
else
Some dt' in
linear (C.derive_outer d t)
let atoms t =
let a, c = List.split (PM.elements t) in
(a, ThoList.uniq (List.sort compare (ThoList.flatmap C.atoms c)))
let to_string fmt cfmt sum =
"(" ^ String.concat " + "
(M.fold (fun t c acc ->
if C.is_null c then
acc
else if C.is_unit c then
fmt t :: acc
else if C.is_unit (C.neg c) then
("(-" ^ fmt t ^ ")") :: acc
else
(C.to_string cfmt c ^ "*" ^ fmt t) :: acc)
sum []) ^ ")"
end
Index: trunk/omega/src/orders.ml
===================================================================
--- trunk/omega/src/orders.ml (revision 0)
+++ trunk/omega/src/orders.ml (revision 8900)
@@ -0,0 +1,980 @@
+(* orders.ml --
+
+ Copyright (C) 1999-2023 by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+
+ WHIZARD is free software; you can redistribute it and/or modify it
+ under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ WHIZARD is distributed in the hope that it will be useful, but
+ WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
+
+(* \thocwmodulesection{Conditions} *)
+module type Conditions =
+ sig
+ type coupling_order
+ type orders = (coupling_order * int) list
+ type t
+ val trivial : t
+ val of_strings : string list -> t
+ val to_strings : t -> string list
+ val constant : t -> orders -> bool
+ val fusion : t -> orders -> bool
+ val braket : t -> orders -> orders option
+ val exclusive_fusion : t -> coupling_order list
+ val exclusive_braket : t -> coupling_order list
+ val square_root : t -> t
+
+ val to_string : t -> string
+ val pp : Format.formatter -> t -> unit
+ end
+
+(* A projection of [Model.T] containing only coupling constants
+ and coupling orders. This is useful for testing without having
+ to link real models. *)
+module type Model_CO =
+ sig
+ type constant
+ type coupling_order
+ val all_coupling_orders : unit -> coupling_order list
+ val coupling_order_to_string : coupling_order -> string
+ val coupling_orders : constant -> (coupling_order * int) list
+ end
+
+module Conditions (M : Model_CO (* $\subset$ [Model.T] *)) : Conditions
+ with type coupling_order = M.coupling_order =
+ struct
+
+ type coupling_order = M.coupling_order
+ type orders = (coupling_order * int) list
+
+ module CO = struct type t = coupling_order let compare = Stdlib.compare end
+ module COSet = Set.Make(CO)
+ module COMap = Map.Make(CO)
+ module COSMap = Partial.Make(String)
+
+ (* Add a [unit] argument to support [Model.Mutable]: *)
+ let co_set () =
+ COSet.of_list (M.all_coupling_orders ())
+
+ let co_map () =
+ COSMap.of_list (List.map (fun co -> (M.coupling_order_to_string co, co)) (M.all_coupling_orders ()))
+
+ let co_set_of_strings pmap co_list =
+ List.fold_left
+ (fun acc s ->
+ match COSMap.apply_opt pmap s with
+ | None ->
+ Printf.eprintf "omega: ignoring unknown coupling_order `%s'!\n" s;
+ acc
+ | Some co ->
+ COSet.add co acc)
+ COSet.empty co_list
+
+ let complement = COSet.diff
+
+ (* All the integers are non negative. We don't need a [LE] constructor,
+ because $i \le n$ is equivalent to $0\le i \le n$ in this case. This saves
+ us redundant match cases below. *)
+ type range =
+ | GE of int
+ | IN of int * int
+ | EQ of int
+
+ type mode = Slice | Sum
+
+ (* The lists of type [orders] must be very short to allow encoding of the
+ counted coupling orders in Fortran variable names! That's why we keep the potentially
+ much larger set of couplings that are set to zero separate.
+
+ One could think of supporting a union of non overlapping ranges, but this adds a lot
+ of complexity for little practical value. *)
+
+ (* \begin{dubious}
+ The correct semantics for \textit{OR}-ing conditions on \emph{different} coupling orders
+ can not be implemented with the following data type. One would need a set or list
+ of [(range * mode) COMap.t] for [orders]. It is not clear if this is worth the effort.
+ \end{dubious} *)
+
+ (* [fusion] is the union of [braket] and [only_fusion]. One of the three is therefore
+ redundant, but we maintain all three for convenience. Similarly,
+ [exclusive_braket] and [exclusive_fusion] are simply the result of applying
+ [List.map fst] to [braket] and [fusion]. They are here just for convenience. *)
+ type t =
+ { braket : (coupling_order * range) list;
+ fusion : (coupling_order * range) list;
+ only_fusion : (coupling_order * range) list;
+ exclusive_braket : coupling_order list;
+ exclusive_fusion : coupling_order list;
+ is_null : COSet.t }
+
+ let trivial =
+ { braket = [];
+ fusion = [];
+ only_fusion = [];
+ exclusive_braket = [];
+ exclusive_fusion = [];
+ is_null = COSet.empty }
+
+ type t_intermediate =
+ { orders_map : (range * mode) COMap.t;
+ null_set : COSet.t }
+
+ let range_to_string l r = function
+ | IN (i, j) -> Printf.sprintf "%c%d..%d%c" l i j r
+ | GE i -> Printf.sprintf "%c%d..%c" l i r
+ | EQ i -> Printf.sprintf "%d" i
+
+ let interval_to_string = range_to_string '[' ']'
+ let slice_to_string = range_to_string '{' '}'
+
+ let co_and_interval_to_string (co, r) =
+ M.coupling_order_to_string co ^ " = " ^ interval_to_string r
+
+ let co_and_slice_to_string (co, r) =
+ M.coupling_order_to_string co ^ " = " ^ slice_to_string r
+
+ let to_string c =
+ let is_null =
+ match COSet.elements c.is_null with
+ | [] -> []
+ | [co] -> [M.coupling_order_to_string co ^ " = 0"]
+ | is_null -> ["{" ^ String.concat ", " (List.map M.coupling_order_to_string is_null) ^ "} = 0"]
+ and intervals = List.map co_and_interval_to_string c.only_fusion
+ and slices = List.map co_and_slice_to_string c.braket in
+ String.concat "; " (is_null @ intervals @ slices)
+
+ let to_string_raw c =
+ let is_null = String.concat ", " (List.map M.coupling_order_to_string (COSet.elements c.is_null))
+ and braket = List.map co_and_slice_to_string c.braket
+ and fusion = List.map co_and_interval_to_string c.fusion
+ and only_fusion = List.map co_and_interval_to_string c.only_fusion in
+ Printf.sprintf
+ "is_null = {%s}; braket = (%s); fusion = (%s); only_fusion = (%s)"
+ is_null (String.concat ", " braket) (String.concat ", " fusion) (String.concat ", " only_fusion)
+
+ let to_strings c =
+ let intervals = List.map co_and_interval_to_string c.only_fusion
+ and slices = List.map co_and_slice_to_string c.braket in
+ match COSet.elements c.is_null with
+ | [] -> List.concat [intervals; slices]
+ | is_null ->
+ List.concat
+ [intervals;
+ slices;
+ List.map
+ (fun co_list ->
+ "disabled: " ^ String.concat ", " (List.map M.coupling_order_to_string co_list))
+ (ThoList.chopn 5 is_null)]
+
+ let accept_all =
+ { orders_map = COMap.empty;
+ null_set = COSet.empty }
+
+ module S = Orders_syntax
+
+ let rec compile_set all_co pmap = function
+ | S.Set co_list -> co_set_of_strings pmap co_list
+ | S.Diff (set, set') -> COSet.diff (compile_set all_co pmap set) (compile_set all_co pmap set')
+ | S.Complement (S.Complement set) -> compile_set all_co pmap set
+ | S.Complement set -> complement all_co (compile_set all_co pmap set)
+
+ let compile_range = function
+ | S.Range (i, j) ->
+ if i = j then
+ EQ i
+ else if i < j then
+ IN (i, j)
+ else
+ EQ 0
+ | S.Min i ->
+ GE (max i 0)
+ | S.Max j ->
+ if j > 0 then
+ IN (0, j)
+ else
+ EQ 0
+
+ let make_interval_or_slice mode all_co pmap co_set range =
+ let co_set = compile_set all_co pmap co_set in
+ let orders_map =
+ COSet.fold (fun co map -> COMap.add co (compile_range range, mode) map) co_set COMap.empty in
+ { accept_all with orders_map }
+
+ let compile_atom all_co pmap = function
+ | S.Null co_set | S.Exact (co_set, 0)
+ | S.Interval (co_set, (S.Max 0 | S.Range (_, 0)))
+ | S.Slices (co_set, (S.Max 0 | S.Range (_, 0))) ->
+ { accept_all with null_set = compile_set all_co pmap co_set }
+ | S.Exact (co_set, n) ->
+ let co_set = compile_set all_co pmap co_set in
+ let orders_map = COSet.fold (fun co map -> COMap.add co (EQ n, Slice) map) co_set COMap.empty in
+ { accept_all with orders_map }
+ | S.Interval (co_set, range) ->
+ make_interval_or_slice Sum all_co pmap co_set range
+ | S.Slices (co_set, range) ->
+ make_interval_or_slice Slice all_co pmap co_set range
+
+ let in_or_eq i j =
+ if i = j then
+ Some (EQ i)
+ else if i <= j then
+ Some (IN (i, j))
+ else
+ None
+
+ let and_range_opt r1 r2 =
+ match r1, r2 with
+ | GE i1, GE i2 ->
+ Some (GE (max i1 i2))
+ | EQ i1, EQ i2 ->
+ if i1 = i2 then Some (EQ i1) else None
+ | IN (i1, j1), IN (i2, j2) ->
+ in_or_eq (max i1 i2) (min j1 j2)
+ | IN (i, j), GE k | GE k, IN (i, j) ->
+ in_or_eq (max i k) j
+ | GE i, EQ j | EQ j, GE i ->
+ if i <= j then Some (EQ i) else None
+ | IN (i, j), EQ k | EQ k, IN (i, j) ->
+ if i <= k && k <= j then Some (EQ k) else None
+
+ let prefer_slice m1 m2 =
+ match m1, m2 with
+ | Sum, Sum -> Sum
+ | Slice, Sum | Sum, Slice | Slice, Slice -> Slice
+
+ let and_range co (r1, m1) (r2, m2) =
+ match and_range_opt r1 r2 with
+ | None -> None
+ | Some r -> Some (r, prefer_slice m1 m2)
+
+ let and_pair c1 c2 =
+ { null_set = COSet.union c1.null_set c2.null_set;
+ orders_map = COMap.union and_range c1.orders_map c2.orders_map }
+
+ let gap co =
+ let co = M.coupling_order_to_string co in
+ invalid_arg (Printf.sprintf "or_range: %s: ranges with gaps not supported!" co)
+
+ let or_range_opt co r1 r2 =
+ match r1, r2 with
+ | GE i1, GE i2 ->
+ Some (GE (max 0 (min i1 i2)))
+ | EQ i1, EQ i2 ->
+ if i1 = i2 then
+ Some (EQ i1)
+ else if i1 = pred i2 then
+ Some (IN (i1, i2))
+ else if i1 = succ i2 then
+ Some (IN (i2, i1))
+ else
+ gap co
+ | IN (i1, j1), IN (i2, j2) ->
+ if i2 <= succ j1 then
+ Some (IN (i1, j2))
+ else if i1 <= succ j2 then
+ Some (IN (i2, j1))
+ else
+ gap co
+ | IN (i, j), GE k | GE k, IN (i, j) ->
+ if k <= succ j then Some (GE i) else gap co
+ | GE i, EQ j | EQ j, GE i ->
+ if j >= pred j then Some (GE j) else gap co
+ | IN (i, j), EQ k | EQ k, IN (i, j) ->
+ if i <= k && k <= j then
+ Some (IN (i, j))
+ else if k = pred i then
+ Some (IN (k, j))
+ else if k = succ j then
+ Some (IN (i, k))
+ else
+ gap co
+
+ let or_range co (r1, m1) (r2, m2) =
+ match or_range_opt co r1 r2 with
+ | None -> None
+ | Some r -> Some (r, prefer_slice m1 m2)
+
+ (* This will be used with [COMap.merge] and fails if the coupling
+ order [co] appears as key in only one of the maps. *)
+ let merge_or_range co r1 r2 =
+ match r1, r2 with
+ | None, None -> None
+ | Some r1, Some r2 -> or_range co r1 r2
+ | None, Some _ | Some _, None ->
+ let co = M.coupling_order_to_string co in
+ invalid_arg (Printf.sprintf "or_range: %s: OR of different coupling_orders not supported!" co)
+
+ let or_pair c1 c2 =
+ { null_set = COSet.inter c1.null_set c2.null_set;
+ orders_map = COMap.merge merge_or_range c1.orders_map c2.orders_map }
+
+ let cleanup_condition c =
+ let null_set =
+ COMap.fold
+ (fun co (r, _) set ->
+ match r with
+ | EQ 0 | IN (_, 0) -> COSet.add co set
+ | _ -> COSet.remove co set)
+ c.orders_map c.null_set in
+ let orders_map = COMap.filter (fun co _ -> not (COSet.mem co null_set)) c.orders_map in
+ { null_set; orders_map }
+
+ let combine_conditions combine_pairs = function
+ | [] -> accept_all
+ | c0 :: clist -> cleanup_condition (List.fold_left combine_pairs c0 clist)
+
+ let compile expr =
+ let all_co = co_set ()
+ and pmap = co_map () in
+ let rec compile' = function
+ | S.Atom atom -> compile_atom all_co pmap atom
+ | S.And clist -> combine_conditions and_pair (List.map compile' clist)
+ | S.Or clist -> combine_conditions or_pair (List.map compile' clist) in
+ let c = cleanup_condition (compile' expr) in
+ let braket_rev, fusion_rev, only_fusion_rev =
+ COMap.fold
+ (fun co (range, mode) (braket, fusion, only_fusion) ->
+ let co_range = (co, range) in
+ match mode with
+ | Slice -> (co_range :: braket, co_range :: fusion, only_fusion)
+ | Sum -> (braket, co_range :: fusion, co_range :: only_fusion))
+ c.orders_map ([], [], []) in
+ { braket = List.rev braket_rev;
+ fusion = List.rev fusion_rev;
+ only_fusion = List.rev only_fusion_rev;
+ exclusive_braket = List.rev_map fst braket_rev;
+ exclusive_fusion = List.rev_map fst fusion_rev;
+ is_null = c.null_set}
+
+ (* An empty list of ranges is interpreted as no constraint.
+ This is used for brakets. *)
+ let in_range n = function
+ | GE i -> n >= i
+ | IN (i, j) -> n >= i && n <= j
+ | EQ i -> n = i
+
+ (* In fusions, the coupling orders may still be below the final range. *)
+ let beneath_range n = function
+ | IN (_, i) | EQ i -> n <= i
+ | GE _ -> true
+
+ (* Test whether to include a vertex at all. *)
+ let test_condition range_tester is_null condition co_list =
+ let rec test_condition' acc = function
+ | [], [] -> (* we're done *)
+ Some (List.rev acc)
+ | (co, r) :: rest, [] -> (* conditions on some orders remain, add them with power 0 *)
+ if range_tester 0 r then
+ test_condition' ((co, 0) :: acc) (rest, [])
+ else
+ None
+ | [], (co', n') :: rest' -> (* no further conditions, check that the remaining couplings are allowed *)
+ if n' > 0 && COSet.mem co' is_null then
+ None
+ else
+ test_condition' acc ([], rest')
+ | ((co, r) :: rest as orders), ((co', n') :: rest' as orders') ->
+ if n' > 0 && COSet.mem co' is_null then (* bail if the coupling is forbidden *)
+ None
+ else if co = co' then (* condition and coupling line up *)
+ begin
+ if range_tester n' r then
+ test_condition' ((co', n') :: acc) (rest, rest')
+ else
+ None
+ end
+ else if co < co' then (* condition missing from the couplings *)
+ begin
+ if range_tester 0 r then
+ test_condition' ((co, 0) :: acc) (rest, orders')
+ else
+ None
+ end
+ else (* coupling not in the conditions, skip it *)
+ test_condition' acc (orders, rest') in
+ test_condition' [] (condition, co_list)
+
+ (* Check that a the sum of coupling orders in a fusion does not exceed
+ the limits. *)
+ let fusion condition co_list =
+ match test_condition beneath_range condition.is_null condition.fusion co_list with
+ | None -> false
+ | Some _ -> true
+
+ (* Check both the intervals in [only_fusion] and the slices in [braket], but
+ return only the matches of the latter: *)
+ let braket condition co_list =
+ match test_condition in_range condition.is_null condition.only_fusion co_list with
+ | None -> None
+ | Some _ -> test_condition in_range condition.is_null condition.braket co_list
+
+ let constant condition co_list =
+ not (List.exists (fun (co, n) -> n > 0 && COSet.mem co condition.is_null) co_list)
+
+ let exclusive_fusion c = c.exclusive_fusion
+ let exclusive_braket c = c.exclusive_braket
+
+ (* Turn all intervals into slices, since we need to sum products.
+ Include \emph{all} lower orders. *)
+ let square_root_range = function
+ | GE _ -> GE 0
+ | IN (_, j) | EQ j -> IN (0, j)
+
+ let square_root_ranges ranges =
+ List.map (fun (co, range) -> (co, square_root_range range)) ranges
+
+ let square_root c =
+ let fusion =
+ square_root_ranges
+ (List.sort
+ (fun (co1, _) (co2, _) -> Stdlib.compare co1 co2)
+ (List.rev_append c.only_fusion c.braket))
+ and exclusive_fusion =
+ List.sort Stdlib.compare (List.rev_append c.exclusive_fusion c.exclusive_braket) in
+ { fusion;
+ braket = fusion;
+ only_fusion = [];
+ exclusive_fusion;
+ exclusive_braket = exclusive_fusion;
+ is_null = c.is_null }
+
+ let parse_string s =
+ Orders_parser.main Orders_lexer.token (Lexing.from_string s)
+
+ let parse_strings slist =
+ parse_string (String.concat "; " slist)
+
+ let of_strings slist =
+ compile (parse_strings slist)
+
+ let pp fmt c =
+ Format.fprintf fmt "%s" (to_string_raw c)
+
+ end
+
+(* \thocwmodulesection{Decorate Flavors with Coupling Constant Orders} *)
+
+module type Coupling_Orders =
+ sig
+ type coupling_order
+
+ (* The list is ordered wrt.~[order] and there must be no duplicate
+ entry.
+ Note that we're using lists instead of [Map.S.t], because we want
+ to be able to use the polymorphic [compare] as long as possible.
+ The lists are assumed to be short and we don't care about
+ tail recursion. *)
+ (* \begin{dubious}
+ Eventually, we want to make this type abstract!
+ \end{dubious} *)
+ type orders = (coupling_order * int) list
+
+ (* Simple constructors. *)
+ val null : orders
+
+ (* Sort the list and test it for duplicates. *)
+ val of_list : (coupling_order * int) list -> orders
+ val to_list : orders -> (coupling_order * int) list
+
+ (* Add the matching powers of the coupling orders. The coupling orders
+ in both operands \emph{must} be identical and the \emph{must} appear
+ in the same order. If the coupling orders would be known at compile
+ time, we could implement this in a type safe way as tuples, but the
+ coupling orders can be selected on the command line and in UFO models
+ not even the set of possible coupling orders is known at compile time. *)
+ val add : orders -> orders -> orders
+
+ (* Increment the powers of the coupling orders in the second operand by
+ the powers of matching coupling orders in the first operand. Ignore
+ the other coupling orders in the first operand. The coupling orders in
+ the operands \emph{must} be ordered according to the same ordering
+ relation. *)
+ val incr : orders -> orders -> orders
+
+ (* [square_root condition orders_list] returns a triple [(used, squares, interferences)]
+ where [used] is a list of are all combinations of powers of coupling orders that appear
+ at least once in [squares] or [interferences]. [squares] are the terms
+ that satisfy [condition] when multiplied with themselves and the pairs in
+ [interferences] satisfy [condition] when multiplied. *)
+ val square_root : (orders -> bool) -> orders list ->
+ orders list * orders list * (orders * orders) list
+
+ (* Debugging: *)
+ val to_string : orders -> string
+
+ end
+
+
+module Coupling_Orders (M : sig type coupling_order val coupling_order_to_string : coupling_order -> string end) : Coupling_Orders
+ with type coupling_order = M.coupling_order =
+ struct
+
+ type coupling_order = M.coupling_order
+ type orders = (coupling_order * int) list
+
+ let to_string ol =
+ "{" ^ ThoList.to_string (fun (co, n) -> M.coupling_order_to_string co ^ ":" ^ string_of_int n) ol ^ "}"
+
+ let null = []
+
+ let rec duplicates = function
+ | [] | [_] -> false
+ | (o1, _) :: ((o2, _) :: _ as tail) ->
+ if o1 = o2 then
+ true
+ else
+ duplicates tail
+
+ let of_list o =
+ let o = List.sort (fun (o1, _) (o2, _) -> Stdlib.compare o1 o2) o in
+ if duplicates o then
+ invalid_arg "Orders.Flavor.of_list: duplicates"
+ else
+ o
+
+ let to_list o = o
+
+ (* Here's a dedicated version, but \ldots *)
+ let rec add ol1 ol2 =
+ match ol1, ol2 with
+ | [], [] -> []
+ | [], tail | tail, [] -> invalid_arg "Orders.Coupling_Orders.add: length mismatch"
+ | (o1, n1) :: tail1, (o2, n2) :: tail2 ->
+ if o1 = o2 then
+ (o1, n1 + n2) :: add tail1 tail2
+ else
+ invalid_arg
+ (Printf.sprintf "Orders.Coupling_Orders.add: mismatch '%s' <> '%s'"
+ (M.coupling_order_to_string o1) (M.coupling_order_to_string o2))
+
+ (* Here's a tail recursive version. Once we can use a modern compiler
+ with the tail-mod-cons optimization, we can go back to the first version. *)
+ let add ol1 ol2 =
+ let rec add' acc ol1 ol2 =
+ match ol1, ol2 with
+ | [], [] -> List.rev acc
+ | [], tail | tail, [] -> invalid_arg "Orders.Coupling_Orders.add: length mismatch"
+ | (o1, n1) :: tail1, (o2, n2) :: tail2 ->
+ if o1 = o2 then
+ add' ((o1, n1 + n2) :: acc) tail1 tail2
+ else
+ invalid_arg
+ (Printf.sprintf "Orders.Coupling_Orders.add: mismatch '%s' <> '%s'"
+ (M.coupling_order_to_string o1) (M.coupling_order_to_string o2)) in
+ add' [] ol1 ol2
+
+ (* This is very similar to [add], but coupling orders that appear only in
+ the first, but not the second argument are ignored. *)
+ let rec incr ol1 ol2 =
+ match ol1, ol2 with
+ | _, [] -> (* we're done with the second argument, ignore the rest of the first *)
+ []
+ | [], tail -> (* we're done with the first argument, keep the rest of the second *)
+ tail
+ | (o1, n1) :: tail1, (o2, n2 as on2) :: tail2 ->
+ if o1 = o2 then (* coupling orders match, add the powers *)
+ (o1, n1 + n2) :: incr tail1 tail2
+ else if o1 < o2 then (* [o1] does not appear in the second argument, ignore it *)
+ incr tail1 ol2
+ else (* [o2] does not appear in the first argument, keep it unchanged *)
+ on2 :: incr ol1 tail2
+
+ (* Here's again a tail recursive version. *)
+ let incr ol1 ol2 =
+ let rec incr' acc ol1 ol2 =
+ match ol1, ol2 with
+ | _, [] -> (* we're done with the second argument, ignore the rest of the first *)
+ List.rev acc
+ | [], tail -> (* we're done with the first argument, keep the rest of the second *)
+ List.rev_append acc tail
+ | (o1, n1) :: tail1, (o2, n2 as on2) :: tail2 ->
+ if o1 = o2 then (* coupling orders match, add the powers *)
+ incr' ((o1, n1 + n2) :: acc) tail1 tail2
+ else if o1 < o2 then (* [o1] does not appear in the second argument, ignore it *)
+ incr' acc tail1 ol2
+ else (* [o2] does not appear in the first argument, keep it unchanged *)
+ incr' (on2 :: acc) ol1 tail2 in
+ incr' [] ol1 ol2
+
+ let _add ol1 ol2 =
+ let ol = add ol1 ol2 in
+ Printf.eprintf "add %s %s -> %s\n" (to_string ol1) (to_string ol2) (to_string ol);
+ ol
+
+ let _incr ol1 ol2 =
+ let ol = incr ol1 ol2 in
+ Printf.eprintf "incr %s %s -> %s\n" (to_string ol1) (to_string ol2) (to_string ol);
+ ol
+
+ (* Resist the temptation to implement this as
+ [List.fold_left add null olist],
+ because then [add] would need to accept orders
+ of different lengths. *)
+ let sum = function
+ | [] -> null
+ | o :: rest -> List.fold_left add o rest
+
+ (* We use the polymorphic compare, because we don't need a particular ordering
+ to test of equality in a [Set]. *)
+ module OSet = Set.Make(struct type t = orders let compare = Stdlib.compare end)
+
+ (* Return the list of all pairs of elements of a list, where the first element
+ appears before the second in the list.
+ E.\,g.~[ ordered_pairs [1; 2; 3] = [(1, 2); (1, 3); (2, 3)] ] *)
+
+ (* For longer lists for which the result will be passed to [List.fold],
+ an implementation of the corresponding [fold] would be more efficient,
+ but the lists will always be short. *)
+ let rec ordered_pairs = function
+ | [] -> []
+ | a1 :: a2_list -> List.map (fun a2 -> (a1, a2)) a2_list @ ordered_pairs a2_list
+
+ let square_root condition orders =
+ let used = OSet.empty in
+ let squares, used =
+ List.fold_right
+ (fun o (squares, used as acc) ->
+ if condition (add o o) then
+ (o :: squares, OSet.add o used)
+ else
+ acc)
+ orders ([], used) in
+ let interferences, used =
+ List.fold_right
+ (fun (o1, o2 as o12) (interferences, used as acc) ->
+ if condition (add o1 o2) then
+ (o12 :: interferences, OSet.add o1 (OSet.add o2 used))
+ else
+ acc)
+ (ordered_pairs orders) ([], used) in
+ (OSet.elements used, squares, interferences)
+
+ end
+
+(* \begin{dubious}
+ Conceptually, there is no need to demand a [Colorized] model as
+ a functor argument. Nevertheless, we should first implement a
+ working example for the common use case, before embarking on
+ a generalization that is mostly of academic interest.
+ \end{dubious} *)
+
+module Flavor (M : Model.Colorized) =
+ struct
+
+ module CO = Coupling_Orders(M)
+
+ type orders = CO.orders
+
+ let add_orders = CO.add
+ let incr_orders = CO.incr
+ let null = CO.null
+ let orders_of_list = CO.of_list
+
+ type t = { all_orders : M.flavor; orders : orders }
+ let all_orders f = f.all_orders
+ let pullback f a = f (all_orders a)
+ let make all_orders orders = { all_orders; orders }
+ let trivial f = make f null
+
+ (* Resist the temptation to implement this as
+ [List.fold_right (fun f -> add_orders f.orders) f_list null],
+ because then [add_orders] would need to accept orders
+ of different lengths. *)
+ let fuse_orders = function
+ | [] -> null
+ | f :: rest -> List.fold_right (fun f -> add_orders f.orders) rest f.orders
+
+ let orders_to_string = CO.to_string
+
+ let digit_to_symbol i =
+ if i < 0 then
+ invalid_arg "Orders.Flavor.digit_to_symbol: negative"
+ else
+ if i < 10 then
+ string_of_int i
+ else if i < 36 then
+ String.make 1 (Char.chr (Char.code 'A' + i - 10))
+ else
+ invalid_arg "Orders.Flavor.digit_to_symbol: too large"
+
+ let orders_symbol orders =
+ match CO.to_list orders with
+ | [] -> ""
+ | orders ->
+ if List.for_all (fun (_, n) -> n = 0) orders then
+ ""
+ else
+ "_c" ^ String.concat "" (List.map (fun (_, n) -> digit_to_symbol n) orders)
+
+ let to_string f =
+ M.flavor_to_string f.all_orders ^ orders_to_string f.orders
+
+ let to_symbol f =
+ M.flavor_symbol f.all_orders ^ orders_symbol f.orders
+
+ end
+
+(* \thocwmodulesection{Slice Amplitudes According to Coupling Constant Orders} *)
+
+let incomplete s =
+ failwith ("Orders.Slice()." ^ s ^ " not done yet!")
+
+module Slice (CM : Model.Colorized) =
+ struct
+
+ module OCF = Flavor(CM)
+
+ type flavor = OCF.t
+ type flavor_sans_color = CM.flavor_sans_color
+ type flavor_all_orders = CM.flavor
+ type gauge = CM.gauge
+ type constant = CM.constant
+ type coupling_order = CM.coupling_order
+ type orders = OCF.orders
+ module Ch = CM.Ch
+ let charges = OCF.pullback CM.charges
+ let flavor_sans_color = OCF.pullback CM.flavor_sans_color
+ let flavor_all_orders = OCF.all_orders
+ let trivial = OCF.trivial
+ let orders f = f.OCF.orders
+ let add_orders = OCF.add_orders
+ let incr_orders = OCF.incr_orders
+ let orders_to_string = OCF.orders_to_string
+ let orders_symbol = OCF.orders_symbol
+ let flavor_equal f1 f2 =
+ CM.flavor_equal (flavor_all_orders f1) (flavor_all_orders f2) && f1.orders = f2.orders
+ let color = OCF.pullback CM.color
+ let pdg = OCF.pullback CM.pdg
+ let lorentz = OCF.pullback CM.lorentz
+ let propagator = OCF.pullback CM.propagator
+ let width = OCF.pullback CM.width
+ let conjugate f = { f with OCF.all_orders = CM.conjugate f.OCF.all_orders }
+ let conjugate_sans_color = CM.conjugate_sans_color
+ let conjugate_all_orders = CM.conjugate
+ let fermion = OCF.pullback CM.fermion
+ let max_degree = CM.max_degree
+ let max_degree = CM.max_degree
+
+ let vertices () =
+ incomplete "vertices"
+
+ let coupling = function
+ | Coupling.V3 (_, _, c) | Coupling.V4 (_, _, c) | Coupling.Vn (_, _, c) -> c
+
+ let incr_coupling_orders orders (f, c) =
+ let coupling_orders = CM.coupling_orders (coupling c) in
+ let orders = OCF.incr_orders (OCF.orders_of_list coupling_orders) orders in
+ (OCF.make f orders, c)
+
+ let fuse2 f1 f2 =
+ let orders = OCF.fuse_orders [f1; f2] in
+ List.map (incr_coupling_orders orders) (CM.fuse2 (flavor_all_orders f1) (flavor_all_orders f2))
+
+ let fuse3 f1 f2 f3 =
+ let orders = OCF.fuse_orders [f1; f2; f3] in
+ List.map (incr_coupling_orders orders) (CM.fuse3 (flavor_all_orders f1) (flavor_all_orders f2) (flavor_all_orders f3))
+
+ let fuse flavors =
+ let orders = OCF.fuse_orders flavors in
+ List.map (incr_coupling_orders orders) (CM.fuse (List.map flavor_all_orders flavors))
+
+ let flavors () =
+ List.map OCF.trivial (CM.flavors ())
+
+ let all_coupling_orders = CM.all_coupling_orders
+ let coupling_order_to_string = CM.coupling_order_to_string
+ let coupling_orders = CM.coupling_orders
+
+ let nc = CM.nc
+
+ let external_flavors () =
+ List.map
+ (fun (group, flavors) ->
+ (group, List.map OCF.trivial flavors))
+ (CM.external_flavors ())
+
+ let goldstone f =
+ match CM.goldstone (OCF.all_orders f) with
+ | None -> None
+ | Some (f, c) -> Some (OCF.trivial f, c)
+
+ let parameters = CM.parameters
+ let flavor_of_string s = OCF.trivial (CM.flavor_of_string s)
+ let flavor_to_string = OCF.to_string
+ let flavor_to_TeX = OCF.pullback CM.flavor_to_TeX
+ let flavor_symbol = OCF.to_symbol
+ let gauge_symbol = CM.gauge_symbol
+ let mass_symbol = OCF.pullback CM.mass_symbol
+ let width_symbol = OCF.pullback CM.width_symbol
+ let constant_symbol = CM.constant_symbol
+ let options = CM.options
+ let caveats = CM.caveats
+
+ let amplitude orders fin fout =
+ (List.map (fun f -> OCF.make f orders) fin,
+ List.map (fun f -> OCF.make f orders) fout)
+
+ let flow fin fout =
+ CM.flow (List.map flavor_all_orders fin) (List.map flavor_all_orders fout)
+
+ end
+
+(* \thocwmodulesection{Unit Tests} *)
+module Test =
+ struct
+
+ module O = Coupling_Orders (struct type coupling_order = int let coupling_order_to_string = string_of_int end)
+
+ open OUnit
+
+ let suite_add =
+
+ "add" >:::
+ [ "[(1,1); (2,4)] + [(1,2); (2,3)]" >::
+ (fun () -> assert_equal [(1,3); (2,7)] (O.add [(1,1); (2,4)] [(1,2); (2,3)])) ]
+
+
+ let suite_incr =
+
+ "incr" >:::
+ [ "[(1,1); (3,4)] + [(2,2); (3,3)]" >::
+ (fun () -> assert_equal [(2,2); (3,7)] (O.incr [(1,1); (3,4)] [(2,2); (3,3)])) ]
+
+
+ module M (* [: Model_CO] *) =
+ struct
+ type constant = E | G | G2 | L
+ type coupling_order = EW | QCD | BSM
+ let all_coupling_orders () = [EW; QCD; BSM]
+ let coupling_order_to_string = function
+ | EW -> "EW"
+ | QCD -> "QCD"
+ | BSM -> "BSM"
+ let coupling_orders = function
+ | E -> [(EW,1)]
+ | G -> [(QCD,1)]
+ | G2 -> [(QCD,2)]
+ | L -> [(BSM,1)]
+ end
+
+ module C = Conditions (M)
+
+ let pup expected slist =
+ assert_equal ~printer:(fun s -> "\"" ^ s ^ "\"")
+ expected (C.to_string (C.of_strings slist))
+
+ let suite_parser =
+ "parsing" >:::
+ [ "EW=1" >:: (fun () -> pup "EW = 1" ["EW=1"]);
+ "~EW" >:: (fun () -> pup "{QCD, BSM} = 0" ["~EW"]);
+ "!BSM,QCD" >:: (fun () -> pup "BSM = 0; QCD = {1..2}" ["BSM; QCD={1..2}"]);
+ "!BSM,QCD'" >:: (fun () -> pup "BSM = 0; QCD = {1..2}" ["BSM={0}; QCD={1..2}"]);
+ "EW/QCD" >:: (fun () -> pup "EW = 2; QCD = 1" ["EW=2; QCD=1"]);
+ "EW/QCD" >:: (fun () -> pup "EW = 1; QCD = 1" ["EW=1; QCD=1"]);
+ "EW/QCD'" >:: (fun () -> pup "EW = 1; QCD = 1" ["{EW,QCD}=1"]);
+ "EW=1,2,3" >:: (fun () -> pup "EW = 3" ["EW=1;EW=2;EW=3"]) ]
+
+ let cos_option_to_string = function
+ | None -> "*"
+ | Some co_list ->
+ ThoList.to_string (fun (co, n) -> M.coupling_order_to_string co ^ "=" ^ string_of_int n) co_list
+
+ let sort orders =
+ List.sort (fun (co1, _) (co2, _) -> compare co1 co2) orders
+
+ let map_opt f = function
+ | None -> None
+ | Some a -> Some (f a)
+
+ let assert_braket expected conditions orders =
+ let conditions = C.of_strings conditions in
+ assert_equal ~printer:cos_option_to_string
+ (map_opt sort expected)
+ (map_opt sort (C.braket conditions (sort orders)))
+
+ let assert_fusion expected conditions orders =
+ let conditions = C.of_strings conditions in
+ assert_equal ~printer:string_of_bool expected (C.fusion conditions (sort orders))
+
+ let suite_fusion =
+ let open M in
+ "fusion" >:::
+ [ "BSM;EW=2;QCD=1: QCD=1" >::
+ (fun () -> assert_fusion true ["BSM;EW=2;QCD=1"] [(QCD,1)]);
+
+ "BSM;EW=2;QCD=1: EW=1" >::
+ (fun () -> assert_fusion true ["BSM;EW=2;QCD=1"] [(EW,1)]);
+
+ "BSM;EW=2;QCD=1: EW=1;QCD=1" >::
+ (fun () -> assert_fusion true ["BSM;EW=2;QCD=1"] [(EW,1); (QCD,1)]);
+
+ "BSM;EW=2;QCD=1: EW=2;QCD=1" >::
+ (fun () -> assert_fusion true ["BSM;EW=2;QCD=1"] [(EW,2); (QCD,1)]);
+
+ "BSM;EW=2;QCD=1: EW=1;QCD=2" >::
+ (fun () -> assert_fusion false ["BSM;EW=2;QCD=1"] [(EW,1); (QCD,2)]);
+
+ "BSM;EW=2;QCD=1: BSM=1" >::
+ (fun () -> assert_fusion false ["BSM;EW=2;QCD=1"] [(BSM,1)]);
+
+ "BSM;EW=2;QCD=1: BSM=0" >::
+ (fun () -> assert_fusion true ["BSM;EW=2;QCD=1"] [(BSM,0)]) ]
+
+ let suite_braket =
+ let open M in
+ "braket" >:::
+ [ "BSM;EW=2;QCD=1: QCD=1" >::
+ (fun () -> assert_braket None ["BSM;EW=2;QCD=1"] [(QCD,1)]);
+
+ "BSM;EW=2;QCD=1: EW=1" >::
+ (fun () -> assert_braket None ["BSM;EW=2;QCD=1"] [(EW,1)]);
+
+ "BSM;EW=2;QCD=1: EW=1;QCD=1" >::
+ (fun () -> assert_braket None ["BSM;EW=2;QCD=1"] [(EW,1); (QCD,1)]);
+
+ "BSM;EW=2;QCD=1: EW=2;QCD=1" >::
+ (fun () -> assert_braket (Some [(EW,2); (QCD,1)]) ["BSM;EW=2;QCD=1"] [(EW,2); (QCD,1)]);
+
+ "BSM;EW=2;QCD=1: EW=1;QCD=2" >::
+ (fun () -> assert_braket None ["BSM;EW=2;QCD=1"] [(EW,1); (QCD,2)]);
+
+ "BSM;EW=2;QCD=1: BSM=1" >::
+ (fun () -> assert_braket None ["BSM;EW=2;QCD=1"] [(BSM,1)]);
+
+ "BSM;EW=2;QCD=1: BSM=0" >::
+ (fun () -> assert_braket None ["BSM;EW=2;QCD=1"] [(BSM,0)]);
+
+ "EW={0..}: BSM=0" >::
+ (fun () -> assert_braket (Some [(EW,0)]) ["EW={0..}"] [(BSM,0)]);
+
+ "EW={0..}: EW=1" >::
+ (fun () -> assert_braket (Some [(EW,1)]) ["EW={0..}"] [(EW,1)]);
+
+ "EW={0..}: BSM=1;EW=1" >::
+ (fun () -> assert_braket (Some [(EW,1)]) ["EW={0..}"] [(BSM,1); (EW,1)]) ]
+
+(* \begin{dubious}
+ We should add more unit tests, time permitting.
+ \end{dubious} *)
+
+ let suite =
+ "Orders" >:::
+ [ suite_add;
+ suite_incr;
+ suite_parser;
+ (*[ suite_fusion;] *)
+ suite_braket ]
+
+ end
Index: trunk/omega/src/omega_SM_Majorana.ml
===================================================================
--- trunk/omega/src/omega_SM_Majorana.ml (revision 8899)
+++ trunk/omega/src/omega_SM_Majorana.ml (revision 8900)
@@ -1,26 +1,26 @@
(* omega_SM_Maj.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23_Majorana(Targets.Fortran_Majorana)(Modellib_SM.SM(Modellib_SM.SM_no_anomalous))
+module O = Omega.Mixed23_Majorana(Target_Fortran.Make_Majorana)(Modellib_SM.SM(Modellib_SM.SM_no_anomalous))
let _ = O.main ()
Index: trunk/omega/src/birdtracks.mli
===================================================================
--- trunk/omega/src/birdtracks.mli (revision 0)
+++ trunk/omega/src/birdtracks.mli (revision 8900)
@@ -0,0 +1,150 @@
+(* birdtracks.mli --
+
+ Copyright (C) 2022-2023 by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+ with contributions from
+ Christian Speckner <cnspeckn@googlemail.com>
+
+ 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. *)
+
+(* In this module, we implement birdtracks operations on expressions
+ of [type t] as generally as possible.
+ Module [SU3] (cf.~chapter~\ref{sec:su3}), will provide the group
+ specific constructors for [type t] in the special
+ case $\mathrm{SU}(N_C)$ or $\mathrm{SU}(3)$. *)
+
+(* \thocwmodulesection{Types} *)
+
+(* If there are no $\epsilon$s or $\bar\epsilon$s, a term is simply
+ a list of arrows with a coefficient that is a polynomial,
+ allowing negative powers, in $N_C$. The the type of arrows
+ is not fixed, because [Arrow] has both [free] arrows without
+ summation indices and [factor] arrows that contain summation
+ indices. *)
+type 'a aterm = { coeff : Algebra.Laurent.t; arrows : 'a list }
+
+(* If there are $\epsilon$s, we add them \ldots *)
+type ('a, 'e) eterm = 'a aterm * 'e NEList.t
+
+(* \ldots{} and the same for $\bar\epsilon$s. *)
+type ('a, 'b) bterm = 'a aterm * 'b NEList.t
+
+(* Assuming that $\epsilon$-$\bar\epsilon$-pairs are always
+ reduced as soon as possible, these three alternatives
+ are exhaustive. *)
+type ('a, 'e, 'b) term =
+ | Arrows of 'a aterm
+ | Epsilons of ('a, 'e) eterm
+ | Epsilon_Bars of ('a, 'b) bterm
+
+(* In the public interface, we deal only with [free] indices, without
+ summation indices. *)
+type free = (Arrow.free, Arrow.free_eps, Arrow.free_eps_bar) term
+
+(* An expression is just a sum of terms. *)
+type t = free list
+
+(* \thocwmodulesection{Functions} *)
+
+(* Strip out redundancies. *)
+val canonicalize : t -> t
+
+(* Substitute a specific value for $N_C$. Mainly for debugging. *)
+val with_nc : int -> t -> t
+
+(* Debugging, logging, etc. *)
+val to_string : t -> string
+val to_string_raw : t -> string
+
+(* Extract the number if the birdtrack contains no arrows, $\epsilon$s or $\bar\epsilon$s. *)
+val number : t -> Algebra.Laurent.t option
+
+(* Test for trivial color flows that correspond to unity. *)
+val is_unit : t -> bool
+
+(* Test for vanishing coefficients. *)
+val is_null : t -> bool
+
+(* Purely numeric factors, implemented as Laurent polynomials
+ (cf.~[Algebra.Laurent] in~$N_C$ with complex rational
+ coefficients and without arrows. *)
+val const : Algebra.Laurent.t -> t
+val null : t (* $0$ *)
+val one : t (* $1$ *)
+val two : t (* $2$ *)
+val minus : t (* $-1$ *)
+val int : int -> t (* $n$ *)
+val fraction : int -> t (* $1/n$ *)
+val nc : t (* $N_C$ *)
+val over_nc : t (* $1/N_C$ *)
+val imag : t (* $\ii$ *)
+
+(* Shorthand: $\{(c_i,p_i)\}_i\to \sum_i c_i (N_C)^{p_i}$*)
+val ints : (int * int) list -> t
+
+val scale : Algebra.Laurent.c -> t -> t
+
+val sum : t list -> t
+val diff : t -> t -> t
+val times : t -> t -> t
+val multiply : t list -> t
+
+(* For convenience, here are infix versions of the above operations. *)
+module Infix : sig
+ val ( +++ ) : t -> t -> t
+ val ( --- ) : t -> t -> t
+ val ( *** ) : t -> t -> t
+end
+
+(* We can compute the $f_{abc}$ and $d_{abc}$ invariant tensors
+ from the generators of an arbitrary representation:
+ \begin{subequations}
+ \begin{align}
+ f_{a_1a_2a_3} &=
+ - \ii \tr\left(T_{a_1}\left\lbrack T_{a_2},T_{a_3}\right\rbrack_-\right)
+ = - \ii \tr\left(T_{a_1}T_{a_2}T_{a_3}\right)
+ + \ii \tr\left(T_{a_1}T_{a_3}T_{a_2}\right) \\
+ d_{a_1a_2a_3} &=
+ \tr\left(T_{a_1}\left\lbrack T_{a_2},T_{a_3}\right\rbrack_+\right)
+ = \tr\left(T_{a_1}T_{a_2}T_{a_3}\right)
+ + \tr\left(T_{a_1}T_{a_3}T_{a_2}\right)\,
+ \end{align}
+ \end{subequations}
+ assuming the normalization $ \tr(T_aT_b) = \delta_{ab}$.
+
+ NB: this uses the summation indices $-1$, $-2$ and $-3$. Therefore
+ it \emph{must not} appear unevaluated more than once in a product! *)
+val f_of_rep : (int -> int -> int -> t) -> int -> int -> int -> t
+val d_of_rep : (int -> int -> int -> t) -> int -> int -> int -> t
+
+(* Rename the indices of endpoints in a birdtrack. This is required
+ by our application in [Colorize.It] to match the permutations
+ of lines at a vertex. *)
+val relocate : (int -> int) -> t -> t
+
+(* Revert the direction of all lines in a birdtrack. *)
+val rev : t -> t
+
+(* Pretty printer for the toplevel. *)
+val pp : Format.formatter -> t -> unit
+
+(* Support for unit tests. *)
+val equal : t -> t -> unit
+val assert_zero_vertex : t -> unit
+
+module Test : sig val suite : OUnit.test val suite_long : OUnit.test end
Index: trunk/omega/src/fusion.ml
===================================================================
--- trunk/omega/src/fusion.ml (revision 8899)
+++ trunk/omega/src/fusion.ml (revision 8900)
@@ -1,3587 +1,3527 @@
(* fusion.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
Marco Sekulla <marco.sekulla@kit.edu>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-(* Avoid refering to [Pervasives.compare], because [Pervasives] will
- become [Stdlib.Pervasives] in O'Caml 4.07 and [Stdlib] in O'Caml 4.08. *)
-let pcompare = compare
+module IMap = Map.Make(Int)
module type T =
sig
val options : Options.t
val vintage : bool
type wf
val conjugate : wf -> wf
type flavor
+ type flavor_all_orders
type flavor_sans_color
val flavor : wf -> flavor
+ val flavor_all_orders : wf -> flavor_all_orders
val flavor_sans_color : wf -> flavor_sans_color
type p
val momentum : wf -> p
val momentum_list : wf -> int list
- val wf_tag : wf -> string option
type constant
type coupling
type rhs
type 'a children
val sign : rhs -> int
val coupling : rhs -> constant Coupling.t
- val coupling_tag : rhs -> string option
- type exclusions
- val no_exclusions : exclusions
val children : rhs -> wf list
type fusion
val lhs : fusion -> wf
val rhs : fusion -> rhs list
type braket
val bra : braket -> wf
val ket : braket -> rhs list
type amplitude
type amplitude_sans_color
type selectors
- val amplitudes : bool -> exclusions -> selectors ->
+ type slicings
+ val amplitudes : bool -> selectors -> slicings option ->
flavor_sans_color list -> flavor_sans_color list -> amplitude list
- val amplitude_sans_color : bool -> exclusions -> selectors ->
+ val amplitudes_all_orders : bool -> selectors ->
+ flavor_sans_color list -> flavor_sans_color list -> amplitude list
+ val amplitude_sans_color : bool -> selectors ->
flavor_sans_color list -> flavor_sans_color list -> amplitude_sans_color
val dependencies : amplitude -> wf -> (wf, coupling) Tree2.t
val incoming : amplitude -> flavor list
val outgoing : amplitude -> flavor list
val externals : amplitude -> wf list
val variables : amplitude -> wf list
val fusions : amplitude -> fusion list
- val brakets : amplitude -> braket list
- val on_shell : amplitude -> (wf -> bool)
- val is_gauss : amplitude -> (wf -> bool)
+ type 'a slices
+ val brakets : amplitude -> braket list slices
+ val on_shell : amplitude -> wf -> bool
+ val is_gauss : amplitude -> wf -> bool
val constraints : amplitude -> string option
+ val slicings : amplitude -> string list
val symmetry : amplitude -> int
val allowed : amplitude -> bool
-(*i
- val initialize_cache : string -> unit
- val set_cache_name : string -> unit
-i*)
val check_charges : unit -> flavor_sans_color list list
val count_fusions : amplitude -> int
val count_propagators : amplitude -> int
val count_diagrams : amplitude -> int
val forest : wf -> amplitude -> ((wf * coupling option, wf) Tree.t) list
val poles : amplitude -> wf list list
val s_channel : amplitude -> wf list
val tower_to_dot : out_channel -> amplitude -> unit
val amplitude_to_dot : out_channel -> amplitude -> unit
val phase_space_channels : out_channel -> amplitude_sans_color -> unit
val phase_space_channels_flipped : out_channel -> amplitude_sans_color -> unit
end
module type Maker =
functor (P : Momentum.T) -> functor (M : Model.T) ->
T with type p = P.t
- and type flavor = Colorize.It(M).flavor
+ and type flavor = Orders.Slice(Colorize.It(M)).flavor
+ and type flavor_all_orders = Colorize.It(M).flavor
and type flavor_sans_color = M.flavor
and type constant = M.constant
and type selectors = Cascade.Make(M)(P).selectors
+ and type slicings = Orders.Conditions(Colorize.It(M)).t
+ and type 'a slices = (Orders.Slice(Colorize.It(M)).orders * 'a) list
(* \thocwmodulesection{Fermi Statistics} *)
module type Stat =
sig
(* This will be [Model.T.flavor]. *)
type flavor
(* A record of the fermion lines in the 1POW. *)
type stat
(* Vertices with an odd number of fermion fields. *)
exception Impossible
(* External lines. *)
val stat : flavor -> int -> stat
(* [stat_fuse (Some flines) slist f] combines the fermion lines
in the elements of [slist] according to the connections listed
in [flines].
On the other hand, [stat_fuse None slist f] corresponds to
the legacy mode with \emph{at most} two fermions.
The resulting flavor [f] of the 1POW can be ignored for models
with only Dirac fermions, except for debugging, since
the direction of the arrows is unambiguous.
However, in the case of Majorana fermions and/or fermion number
violating interactions, the flavor [f] must be used. *)
val stat_fuse :
Coupling.fermion_lines option -> stat list -> flavor -> stat
(* Analogous to [stat_fuse], but for the finalizing keystone
instead of the 1POW. *)
val stat_keystone :
Coupling.fermion_lines option -> stat list -> flavor -> stat
(* Compute the sign corresponding to the fermion lines in
a 1POW or keystone. *)
val stat_sign : stat -> int
(* Debugging and consistency checks \ldots *)
val stat_to_string : stat -> string
val equal : stat -> stat -> bool
val saturated : stat -> bool
end
module type Stat_Maker = functor (M : Model.T) ->
Stat with type flavor = M.flavor
(* \thocwmodulesection{Dirac Fermions} *)
let dirac_log silent logging = logging
let dirac_log silent logging = silent
exception Majorana
module Stat_Dirac (M : Model.T) : (Stat with type flavor = M.flavor) =
struct
type flavor = M.flavor
(* \begin{equation}
\gamma_\mu\psi(1)\,G^{\mu\nu}\,\bar\psi(2)\gamma_\nu\psi(3)
- \gamma_\mu\psi(3)\,G^{\mu\nu}\,\bar\psi(2)\gamma_\nu\psi(1)
\end{equation} *)
+ (* The endpoints are [int option] instead of plain [int], so that
+ we can use [None] for open ends in [stat_sign] below.
+ \begin{dubious}
+ We could do one level of unboxing as a performance hack by using
+ [0] or [-1] for open ends. Then we just need to enforce that all
+ line numbers are strictly positive.
+ \end{dubious} *)
+ type line = int option * int option
+
+ let line_to_string = function
+ | Some i, Some j -> Printf.sprintf "%d>%d" i j
+ | Some i, None -> Printf.sprintf "%d>*" i
+ | None, Some j -> Printf.sprintf "*>%d" j
+ | None, None -> "*>*"
+
type stat =
- | Fermion of int * (int option * int option) list
- | AntiFermion of int * (int option * int option) list
- | Boson of (int option * int option) list
+ | Fermion of int * line list
+ | AntiFermion of int * line list
+ | Boson of line list
let lines_to_string lines =
- ThoList.to_string
- (function
- | Some i, Some j -> Printf.sprintf "%d>%d" i j
- | Some i, None -> Printf.sprintf "%d>*" i
- | None, Some j -> Printf.sprintf "*>%d" j
- | None, None -> "*>*")
- lines
+ ThoList.to_string line_to_string lines
let stat_to_string = function
| Boson lines -> Printf.sprintf "Boson %s" (lines_to_string lines)
| Fermion (p, lines) ->
Printf.sprintf "Fermion (%d, %s)" p (lines_to_string lines)
| AntiFermion (p, lines) ->
Printf.sprintf "AntiFermion (%d, %s)" p (lines_to_string lines)
let equal s1 s2 =
match s1, s2 with
| Boson l1, Boson l2 ->
List.sort compare l1 = List.sort compare l2
| Fermion (p1, l1), Fermion (p2, l2)
| AntiFermion (p1, l1), AntiFermion (p2, l2) ->
p1 = p2 && List.sort compare l1 = List.sort compare l2
| _ -> false
let saturated = function
| Boson _ -> true
| _ -> false
let stat f p =
match M.fermion f with
| 0 -> Boson []
| 1 -> Fermion (p, [])
| -1 -> AntiFermion (p, [])
| 2 -> raise Majorana
| _ -> invalid_arg "Fusion.Stat_Dirac: invalid fermion number"
exception Impossible
let stat_fuse_pair_legacy f s1 s2 =
match s1, s2 with
| Boson l1, Boson l2 -> Boson (l1 @ l2)
| Boson l1, Fermion (p, l2) -> Fermion (p, l1 @ l2)
| Boson l1, AntiFermion (p, l2) -> AntiFermion (p, l1 @ l2)
| Fermion (p, l1), Boson l2 -> Fermion (p, l1 @ l2)
| AntiFermion (p, l1), Boson l2 -> AntiFermion (p, l1 @ l2)
| AntiFermion (pbar, l1), Fermion (p, l2) ->
Boson ((Some pbar, Some p) :: l1 @ l2)
| Fermion (p, l1), AntiFermion (pbar, l2) ->
Boson ((Some pbar, Some p) :: l1 @ l2)
| Fermion _, Fermion _ | AntiFermion _, AntiFermion _ ->
raise Impossible
let stat_fuse_legacy s1 s23__n f =
List.fold_right (stat_fuse_pair_legacy f) s23__n s1
let stat_fuse_legacy_logging s1 s23__n f =
let s = stat_fuse_legacy s1 s23__n f in
Printf.eprintf
"stat_fuse_legacy: %s <- %s -> %s\n"
(M.flavor_to_string f)
(ThoList.to_string stat_to_string (s1 :: s23__n))
(stat_to_string s);
s
let stat_fuse_legacy =
dirac_log stat_fuse_legacy stat_fuse_legacy_logging
- module IMap = Map.Make (struct type t = int let compare = compare end)
-
type partial =
{ stat : stat (* the [stat] accumulated so far *);
fermions : int IMap.t (* a map from the indices in the vertex to open fermion lines *);
antifermions : int IMap.t (* a map from the indices in the vertex to open antifermion lines *);
n : int (* the number of incoming propagators *) }
let partial_to_string p =
Printf.sprintf
"{ fermions=%s, antifermions=%s, state=%s, #=%d }"
(ThoList.to_string
(fun (i, f) -> Printf.sprintf "%d@%d" f i)
(IMap.bindings p.fermions))
(ThoList.to_string
(fun (i, f) -> Printf.sprintf "%d@%d" f i)
(IMap.bindings p.antifermions))
(stat_to_string p.stat)
p.n
let add_lines l = function
| Boson l' -> Boson (List.rev_append l l')
| Fermion (n, l') -> Fermion (n, List.rev_append l l')
| AntiFermion (n, l') -> AntiFermion (n, List.rev_append l l')
let partial_of_slist slist =
List.fold_left
(fun acc s ->
let n = succ acc.n in
match s with
| Boson l ->
{ acc with
stat = add_lines l acc.stat;
n }
| Fermion (p, l) ->
{ acc with
fermions = IMap.add n p acc.fermions;
stat = add_lines l acc.stat;
n }
| AntiFermion (p, l) ->
{ acc with
antifermions = IMap.add n p acc.antifermions;
stat = add_lines l acc.stat;
n } )
{ stat = Boson [];
fermions = IMap.empty;
antifermions = IMap.empty;
n = 0 }
slist
- let find_opt p map =
- try Some (IMap.find p map) with Not_found -> None
-
let match_fermion_line p (i, j) =
if i <= p.n && j <= p.n then
- match find_opt i p.fermions, find_opt j p.antifermions with
+ match IMap.find_opt i p.fermions, IMap.find_opt j p.antifermions with
| (Some _ as f), (Some _ as fbar) ->
{ p with
stat = add_lines [fbar, f] p.stat;
fermions = IMap.remove i p.fermions;
antifermions = IMap.remove j p.antifermions }
| _ ->
invalid_arg "match_fermion_line: mismatched boson"
else if i <= p.n then
- match find_opt i p.fermions, p.stat with
+ match IMap.find_opt i p.fermions, p.stat with
| Some f, Boson l ->
{ p with
stat = Fermion (f, l);
fermions = IMap.remove i p.fermions }
| _ ->
invalid_arg "match_fermion_line: mismatched fermion"
else if j <= p.n then
- match find_opt j p.antifermions, p.stat with
+ match IMap.find_opt j p.antifermions, p.stat with
| Some fbar, Boson l ->
{ p with
stat = AntiFermion (fbar, l);
antifermions = IMap.remove j p.antifermions }
| _ ->
invalid_arg "match_fermion_line: mismatched antifermion"
else
failwith "match_fermion_line: impossible"
let match_fermion_line_logging p (i, j) =
Printf.eprintf
"match_fermion_line %s (%d, %d)"
(partial_to_string p) i j;
let p' = match_fermion_line p (i, j) in
Printf.eprintf " >> %s\n" (partial_to_string p');
p'
let match_fermion_line =
dirac_log match_fermion_line match_fermion_line_logging
let match_fermion_lines flines s1 s23__n =
let p = partial_of_slist (s1 :: s23__n) in
List.fold_left match_fermion_line p flines
let stat_fuse_new flines s1 s23__n f =
(match_fermion_lines flines s1 s23__n).stat
let stat_fuse_new_checking flines s1 s23__n f =
let stat = stat_fuse_new flines s1 s23__n f in
if List.length flines < 2 then
begin
let legacy = stat_fuse_legacy s1 s23__n f in
if not (equal stat legacy) then
failwith
(Printf.sprintf
"Fusion.Stat_Dirac.stat_fuse_new: %s <> %s!"
(stat_to_string stat)
(stat_to_string legacy))
end;
stat
let stat_fuse_new_logging flines s1 s23__n f =
Printf.eprintf
"stat_fuse_new: connecting fermion lines %s in %s <- %s\n"
(UFO_Lorentz.fermion_lines_to_string flines)
(M.flavor_to_string f)
(ThoList.to_string stat_to_string (s1 :: s23__n));
stat_fuse_new_checking flines s1 s23__n f
let stat_fuse_new =
dirac_log stat_fuse_new stat_fuse_new_logging
let stat_fuse flines_opt slist f =
match slist with
| [] -> invalid_arg "Fusion.Stat_Dirac.stat_fuse: empty"
| s1 :: s23__n ->
begin match flines_opt with
| Some flines -> stat_fuse_new flines s1 s23__n f
| None -> stat_fuse_legacy s1 s23__n f
end
let stat_fuse_logging flines_opt slist f =
Printf.eprintf
"stat_fuse: %s <- %s\n"
(M.flavor_to_string f)
(ThoList.to_string stat_to_string slist);
stat_fuse flines_opt slist f
let stat_fuse =
dirac_log stat_fuse stat_fuse_logging
let stat_keystone_legacy s1 s23__n f =
let s2 = List.hd s23__n
and s34__n = List.tl s23__n in
stat_fuse_legacy s1 [stat_fuse_legacy s2 s34__n (M.conjugate f)] f
let stat_keystone_legacy_logging s1 s23__n f =
let s = stat_keystone_legacy s1 s23__n f in
Printf.eprintf
"stat_keystone_legacy: %s (%s) %s -> %s\n"
(stat_to_string s1)
(M.flavor_to_string f)
(ThoList.to_string stat_to_string s23__n)
(stat_to_string s);
s
let stat_keystone_legacy =
dirac_log stat_keystone_legacy stat_keystone_legacy_logging
let stat_keystone flines_opt slist f =
match slist with
| [] -> invalid_arg "Fusion.Stat_Dirac.stat_keystone: empty"
| [s] -> invalid_arg "Fusion.Stat_Dirac.stat_keystone: singleton"
| s1 :: (s2 :: s34__n as s23__n) ->
begin match flines_opt with
| None -> stat_keystone_legacy s1 s23__n f
| Some flines ->
(* The fermion line indices in [flines] must match
the lines on one side of the keystone. *)
let stat =
stat_fuse_legacy s1 [stat_fuse_new flines s2 s34__n f] f in
if saturated stat then
stat
else
failwith
(Printf.sprintf
"Fusion.Stat_Dirac.stat_keystone: incomplete %s!"
(stat_to_string stat))
end
let stat_keystone_logging flines_opt slist f =
let s = stat_keystone flines_opt slist f in
Printf.eprintf
"stat_keystone: %s (%s) %s -> %s\n"
(stat_to_string (List.hd slist))
(M.flavor_to_string f)
(ThoList.to_string stat_to_string (List.tl slist))
(stat_to_string s);
s
let stat_keystone =
dirac_log stat_keystone stat_keystone_logging
(* \begin{figure}
\begin{displaymath}
\parbox{26\unitlength}{%
\begin{fmfgraph*}(25,15)
\fmfstraight
\fmfleft{f}
\fmfright{f1,f2,f3}
\fmflabel{$\psi(1)$}{f1}
\fmflabel{$\bar\psi(2)$}{f2}
\fmflabel{$\psi(3)$}{f3}
\fmflabel{$0$}{f}
\fmf{fermion}{f1,v1,f}
\fmffreeze
\fmf{fermion,tension=0.5}{f3,v2,f2}
\fmf{photon}{v1,v2}
\fmfdot{v1,v2}
\end{fmfgraph*}}
\qquad\qquad-\qquad
\parbox{26\unitlength}{%
\begin{fmfgraph*}(25,15)
\fmfstraight
\fmfleft{f}
\fmfright{f1,f2,f3}
\fmflabel{$\psi(1)$}{f1}
\fmflabel{$\bar\psi(2)$}{f2}
\fmflabel{$\psi(3)$}{f3}
\fmflabel{$0$}{f}
\fmf{fermion}{f3,v1,f}
\fmffreeze
\fmf{fermion,tension=0.5}{f1,v2,f2}
\fmf{photon}{v1,v2}
\fmfdot{v1,v2}
\end{fmfgraph*}}
\end{displaymath}
\caption{\label{fig:stat_fuse} Relative sign from Fermi statistics.}
\end{figure} *)
(* \begin{equation}
\epsilon \left(\left\{ (0,1), (2,3) \right\}\right)
= - \epsilon \left(\left\{ (0,3), (2,1) \right\}\right)
\end{equation} *)
let permutation lines =
let fout, fin = List.split lines in
let eps_in, _ = Combinatorics.sort_signed fin
and eps_out, _ = Combinatorics.sort_signed fout in
(eps_in * eps_out)
(* \begin{dubious}
This comparing of permutations of fermion lines is a bit tedious
and takes a macroscopic fraction of time. However, it's less than
20\,\%, so we don't focus on improving on it yet.
\end{dubious} *)
let stat_sign = function
| Boson lines -> permutation lines
| Fermion (p, lines) -> permutation ((None, Some p) :: lines)
| AntiFermion (pbar, lines) -> permutation ((Some pbar, None) :: lines)
end
-(* \thocwmodulesection{Tags} *)
+(* \thocwmodulesection{Amplitudes: Monochrome, Colored and Sliced} *)
+
+(* Computing the colored amplitudes from the uncolored amplitudes by
+ adding color flows is the same algorithm as computing the uncolored
+ amplitudes from the topology by adding flavors. The algorithm for
+ adding powers of coupling constants is again almost identical,
+ with only a small twist (see the type ['a slices] below).
+ Therefore we define a common module that we can instantiate thrice:
+ once without color, once with and once with powers coupling constants
+ on top. *)
-module type Tags =
+(* In the future, we might want to have [Coupling] among the functor
+ arguments. However, for the moment, [Coupling] is assumed to be
+ comprehensive. *)
+
+module type Amplitude =
sig
- type wf
- type coupling
+
+ (* An off-shell wavefunction is uniquely characterized by a [flavor]
+ (which will contain the physical flavor and might contain
+ color flows and coupling order powers) and a momentum *)
+ type flavor
+ type p
+ type wf = { flavor : flavor; momentum : p }
+
+ (* Conjugate the flavor, keeping the momentum. *)
+ val conjugate : wf -> wf
+
+ (* Extract flavor and momentum from a wave function. [momentum_list] is
+ a convenience function that composes [momentum] and [Momentum.to_ints]. *)
+ val flavor : wf -> flavor
+ val momentum : wf -> p
+ val momentum_list : wf -> int list
+
+ (* An ordering that guarantees that wavefunctions will be
+ ordered according to \emph{increasing} [Momentum().rank]
+ of their momenta. For tree level amplitudes, this can be
+ used to get the correct order of evaluation. *)
+ val order_wf : wf -> wf -> int
+
+ (* [external_wfs rank] constructs a list of wavefunctions from pairs
+ of [flavor]s and indices of external momenta, using
+ [rank] in the representation of momenta. *)
+ val external_wfs : int -> (flavor * int) list -> wf list
+
+ (* The couplings are model dependent, of course and we also must keep
+ track of a sign for Fermi statistics. The value of [sign] must be
+ either~$+1$ or~$-1$. *)
+ type constant
+ type coupling = { sign : int; coupling : constant Coupling.t }
+
+ (* The incoming wavefunctions (a.\,k.\,a.~[children]) in a fusion
+ can be represented by a [list] or a [Tuple] and we . *)
type 'a children
- val null_wf : wf
- val null_coupling : coupling
- val fuse : coupling -> wf children -> wf
- val wf_to_string : wf -> string option
- val coupling_to_string : coupling -> string option
- end
-
-module type Tagger =
- functor (PT : Tuple.Poly) -> Tags with type 'a children = 'a PT.t
-
-module type Tagged_Maker =
- functor (Tagger : Tagger) ->
- functor (P : Momentum.T) -> functor (M : Model.T) ->
- T with type p = P.t
- and type flavor = Colorize.It(M).flavor
- and type flavor_sans_color = M.flavor
- and type constant = M.constant
+ type rhs = coupling * wf children
+ val sign : rhs -> int
+ val coupling : rhs -> constant Coupling.t
+ val children : rhs -> wf list
-(* No tags is one option for good tags \ldots *)
+ (* In a [fusion], we can have more than one term contribute on the
+ right hand side. *)
+ type fusion = wf * rhs list
+ val lhs : fusion -> wf
+ val rhs : fusion -> rhs list
+
+ (* In a [braket], we can have more than one term contribute on the
+ [ket], if we factor common [bra]s. *)
+ type braket = wf * rhs list
+ val bra : braket -> wf
+ val ket : braket -> rhs list
+
+ (* The small twist alluded to above is that in the case of counting powers
+ coupling constants there will be different sets of [braket]s that
+ correspond to different powers of coupling constants.
+
+ Therefore, we wrap the [braket list] as [braket list Slicer.t] that
+ can be implented in a functor argument either trivially as [braket list] in
+ the module [Unsliced] or as a [(orders * braket list) list], as in the
+ module [By_Orders] below.
+
+ Note that slicing a list of whole amplitudes instead of the [braket list]
+ would lead to unnecessary duplication of [fusion]s. *)
+
+ type 'a slices
+ val unsliced : 'a -> 'a slices
+
+ (* That's the big bad DAG that implents the recursive construction
+ of off-shell wave functions. *)
+ module D : DAG.T with type node = wf and type edge = coupling and type children = wf children
+
+ (* Return the list of all unique wavefunctions appearing in
+ list of [braket]s on the left and right hand sides. *)
+ val wavefunctions : braket list -> wf list
+
+ (* That's the type that holds the result of our computations. *)
+ type t =
+ { fusions : fusion list;
+ brakets : braket list slices;
+ on_shell : (wf -> bool);
+ is_gauss : (wf -> bool);
+ constraints : string option;
+ slicings : string list;
+ incoming : flavor list;
+ outgoing : flavor list;
+ externals : wf list;
+ symmetry : int;
+ dependencies : (wf -> (wf, coupling) Tree2.t);
+ fusion_tower : D.t;
+ fusion_dag : D.t }
+
+ (* The following accessor functions are redundant, since the type [t] is not abstract,
+ but they are convenient, nevertheless. *)
+
+ (* The [flavor]s of the incoming and outgoing particles. *)
+ val incoming : t -> flavor list
+ val outgoing : t -> flavor list
+
+ (* The on-shell wave functions for the external particles in the crossed
+ amplitude with all particles incoming.
+ The outgoing flavors have been replaced by their charge conjugates.
+ The [Target] must declare variables for them and initialize these from
+ the momenta. *)
+ val externals : t -> wf list
+
+ (* All off-shell wave functions. The [Target] must declare variables for them. *)
+ val variables : t -> wf list
+
+ (* All fusions. The [Target] uses them to recursively compute the off-shell wavefunctions. *)
+ val fusions : t -> fusion list
+
+ (* All slices of brakets. The [Target] evaluates each braket and adds the results
+ for each slice to obtain the corresponding scattering amplitude. *)
+ val brakets : t -> braket list slices
+
+ (* Test if the user requested to replace the propagator for the off-shell
+ wavefunction by an on-shell condition or a gaussian. *)
+ val on_shell : t -> wf -> bool
+ val is_gauss : t -> wf -> bool
+
+ (* Human readable description of the constraints of type [Cascades().selectors]
+ that have been applied to the amplitude. *)
+ val constraints : t -> string option
+
+ (* Human readable description of the requested slicings of type [Orders.Conditions.t] *)
+ val slicings : t -> string list
+
+ (* Size of the permutation symmetry group for identical outgoing patricles. *)
+ val symmetry : t -> int
+
+ (* The DAG that will be transformed by colorization and slicing. *)
+ val fusion_dag : t -> D.t
+
+ (* This is used for diagnostics. *)
+ val dependencies : t -> wf -> (wf, coupling) Tree2.t
-module No_Tags (PT : Tuple.Poly) =
- struct
- type wf = unit
- type coupling = unit
- type 'a children = 'a PT.t
- let null_wf = ()
- let null_coupling = ()
- let fuse () _ = ()
- let wf_to_string () = None
- let coupling_to_string () = None
end
(* \begin{dubious}
- Here's a simple additive tag that can grow into something useful
- for loop calculations.
+ Investigate if we can optimize also the unsliced amplitudes by
+ keeping only one [DAG.t] and slice the brakets.
\end{dubious} *)
-module Loop_Tags (PT : Tuple.Poly) =
+module type Slicer =
+ sig
+ type 'a t
+ val all : 'a -> 'a t
+ end
+
+module Unsliced =
struct
- type wf = int
- type coupling = int
- type 'a children = 'a PT.t
- let null_wf = 0
- let null_coupling = 0
- let fuse c wfs = PT.fold_left (+) c wfs
- let wf_to_string n = Some (string_of_int n)
- let coupling_to_string n = Some (string_of_int n)
+ type 'a t = 'a
+ let all a = a
end
-module Order_Tags (PT : Tuple.Poly) =
+module Amplitude (PT : Tuple.Poly) (P : Momentum.T) (M : Model.T) (S : Slicer) : Amplitude
+ with type p = P.t
+ and type flavor = M.flavor
+ and type constant = M.constant
+ and type 'a children = 'a PT.t
+ and type 'a slices = 'a S.t =
struct
- type wf = int
- type coupling = int
+
+ type flavor = M.flavor
+ type p = P.t
+
+ type wf = { flavor : flavor; momentum : p }
+
+ let flavor wf = wf.flavor
+ let conjugate wf = { wf with flavor = M.conjugate wf.flavor }
+ let momentum wf = wf.momentum
+ let momentum_list wf = P.to_ints wf.momentum
+
+ let external_wfs rank particles =
+ List.map
+ (fun (f, p) ->
+ { flavor = f;
+ momentum = P.singleton rank p })
+ particles
+
+ (* Order wavefunctions so that the external come first, then the pairs, etc.
+ Also put possible Goldstone bosons \emph{before} their gauge bosons. *)
+
+ let lorentz_ordering f =
+ match M.lorentz f with
+ | Coupling.Scalar -> 0
+ | Coupling.Spinor -> 1
+ | Coupling.ConjSpinor -> 2
+ | Coupling.Majorana -> 3
+ | Coupling.Vector -> 4
+ | Coupling.Massive_Vector -> 5
+ | Coupling.Tensor_2 -> 6
+ | Coupling.Tensor_1 -> 7
+ | Coupling.Vectorspinor -> 8
+ | Coupling.BRS Coupling.Scalar -> 9
+ | Coupling.BRS Coupling.Spinor -> 10
+ | Coupling.BRS Coupling.ConjSpinor -> 11
+ | Coupling.BRS Coupling.Majorana -> 12
+ | Coupling.BRS Coupling.Vector -> 13
+ | Coupling.BRS Coupling.Massive_Vector -> 14
+ | Coupling.BRS Coupling.Tensor_2 -> 15
+ | Coupling.BRS Coupling.Tensor_1 -> 16
+ | Coupling.BRS Coupling.Vectorspinor -> 17
+ | Coupling.BRS _ -> invalid_arg "Fusion.lorentz_ordering: not needed"
+ | Coupling.Maj_Ghost -> 18
+(*i | Coupling.Ward_Vector -> 19 i*)
+
+ let order_flavor f1 f2 =
+ let c = compare (lorentz_ordering f1) (lorentz_ordering f2) in
+ if c <> 0 then
+ c
+ else
+ compare f1 f2
+
+ (* Note that [Momentum().compare] guarantees that wavefunctions will be
+ ordered according to \emph{increasing} [Momentum().rank] of their
+ momenta. *)
+
+ let order_wf wf1 wf2 =
+ let c = P.compare wf1.momentum wf2.momentum in
+ if c <> 0 then
+ c
+ else
+ order_flavor wf1.flavor wf2.flavor
+
+ (* This \emph{must} be a pair matching the [edge * node children] pairs of
+ [DAG.Forest]! *)
+
type 'a children = 'a PT.t
- let null_wf = 0
- let null_coupling = 0
- let fuse c wfs = PT.fold_left (+) c wfs
- let wf_to_string n = Some (string_of_int n)
- let coupling_to_string n = Some (string_of_int n)
+ type constant = M.constant
+ type coupling = { sign : int; coupling : constant Coupling.t }
+ type rhs = coupling * wf children
+ let sign (c, _) = c.sign
+ let coupling (c, _) = c.coupling
+ let children (_, wfs) = PT.to_list wfs
+
+ type fusion = wf * rhs list
+ let lhs (l, _) = l
+ let rhs (_, r) = r
+
+ type braket = wf * rhs list
+ let bra (b, _) = b
+ let ket (_, k) = k
+
+ module WF = struct type t = wf let compare = order_wf end
+ module CPL = struct type t = coupling let compare = compare end
+ module D = DAG.Make(DAG.Forest(PT)(WF)(CPL))
+
+ module WFSet = Set.Make(WF)
+
+ let wavefunctions brakets =
+ WFSet.elements
+ (List.fold_left
+ (fun set (wf1, wf23) ->
+ WFSet.add wf1 (List.fold_left
+ (fun set' (_, wfs) ->
+ PT.fold_right WFSet.add wfs set')
+ set wf23))
+ WFSet.empty brakets)
+
+ type 'a slices = 'a S.t
+ let unsliced a = S.all a
+
+ type t =
+ { fusions : fusion list;
+ brakets : braket list slices;
+ on_shell : (wf -> bool);
+ is_gauss : (wf -> bool);
+ constraints : string option;
+ slicings : string list;
+ incoming : flavor list;
+ outgoing : flavor list;
+ externals : wf list;
+ symmetry : int;
+ dependencies : (wf -> (wf, coupling) Tree2.t);
+ fusion_tower : D.t;
+ fusion_dag : D.t }
+
+ let incoming a = a.incoming
+ let outgoing a = a.outgoing
+ let externals a = a.externals
+ let fusions a = a.fusions
+ let brakets a = a.brakets
+ let symmetry a = a.symmetry
+ let on_shell a = a.on_shell
+ let is_gauss a = a.is_gauss
+ let constraints a = a.constraints
+ let slicings a = a.slicings
+ let variables a = List.map lhs a.fusions
+ let dependencies a = a.dependencies
+ let fusion_dag a = a.fusion_dag
+
end
-
-(* \thocwmodulesection{[Tagged], the [Fusion.Make] Functor} *)
-module Tagged (Tagger : Tagger) (PT : Tuple.Poly)
+(* \thocwmodulesection{The [Fusion.Make] Functor} *)
+
+module Make (PT : Tuple.Poly)
(Stat : Stat_Maker) (T : Topology.T with type 'a children = 'a PT.t)
(P : Momentum.T) (M : Model.T) =
struct
let vintage = false
- type cache_mode = Cache_Use | Cache_Ignore | Cache_Overwrite
- let cache_option = ref Cache_Ignore
- type qcd_order =
- | QCD_order of int
- type ew_order =
- | EW_order of int
- let qcd_order = ref (QCD_order 99)
- let ew_order = ref (EW_order 99)
-
let options = Options.create
- [
-(*i
- "ignore-cache", Arg.Unit (fun () -> cache_option := Cache_Ignore),
- " ignore cached model tables (default)";
- "use-cache", Arg.Unit (fun () -> cache_option := Cache_Use),
- " use cached model tables";
- "overwrite-cache", Arg.Unit (fun () -> cache_option := Cache_Overwrite),
- " overwrite cached model tables";
-i*)
- "qcd", Arg.Int (fun n -> qcd_order := QCD_order n),
- " set QCD order n [>= 0, default = 99] (ignored)";
- "ew", Arg.Int (fun n -> ew_order := EW_order n),
- " set QCD order n [>=0, default = 99] (ignored)"]
-
- exception Negative_QCD_order
- exception Negative_EW_order
- exception Vanishing_couplings
- exception Negative_QCD_EW_orders
-
- let int_orders =
- match !qcd_order, !ew_order with
- | QCD_order n, EW_order n' when n < 0 && n' >= 0 ->
- raise Negative_QCD_order
- | QCD_order n, EW_order n' when n >= 0 && n' < 0 ->
- raise Negative_EW_order
- | QCD_order n, EW_order n' when n < 0 && n' < 0 ->
- raise Negative_QCD_EW_orders
- | QCD_order n, EW_order n' -> (n, n')
-
- open Coupling
+ [ ]
module S = Stat(M)
type stat = S.stat
let stat = S.stat
let stat_sign = S.stat_sign
(* \begin{dubious}
This will do \emph{something} for 4-, 6-, \ldots fermion vertices,
but not necessarily the right thing \ldots
\end{dubious} *)
(* \begin{dubious}
This is copied from [Colorize] and should be factored!
\end{dubious} *)
(* \begin{dubious}
In the long run, it will probably be beneficial to apply
the permutations in [Modeltools.add_vertexn]!
\end{dubious} *)
module PosMap =
Partial.Make (struct type t = int let compare = compare end)
let partial_map_undoing_permutation l l' =
let module P = Permutation.Default in
let p = P.of_list (List.map pred l') in
PosMap.of_lists l (P.list p l)
let partial_map_undoing_fuse fuse =
partial_map_undoing_permutation
(ThoList.range 1 (List.length fuse))
fuse
let undo_permutation_of_fuse fuse =
PosMap.apply_with_fallback
(fun _ -> invalid_arg "permutation_of_fuse")
(partial_map_undoing_fuse fuse)
let fermion_lines = function
| Coupling.V3 _ | Coupling.V4 _ -> None
| Coupling.Vn (Coupling.UFO (_, _, _, fl, _), fuse, _) ->
Some (UFO_Lorentz.map_fermion_lines (undo_permutation_of_fuse fuse) fl)
type constant = M.constant
(* \thocwmodulesubsection{Wave Functions} *)
-(* \begin{dubious}
- The code below is not yet functional. Too often, we assign to
- [Tags.null_wf] instead of calling [Tags.fuse].
- \end{dubious} *)
-
-(* We will need two types of amplitudes: with color and without color. Since
- we can build them using the same types with only [flavor] replaced, it pays
- to use a functor to set up the scaffolding. *)
-
- module Tags = Tagger(PT)
-
-(* In the future, we might want to have [Coupling] among the functor
- arguments. However, for the moment, [Coupling] is assumed to be
- comprehensive. *)
-
- module type Tagged_Coupling =
- sig
- type sign = int
- type t =
- { sign : sign;
- coupling : constant Coupling.t;
- coupling_tag : Tags.coupling }
- val sign : t -> sign
- val coupling : t -> constant Coupling.t
- val coupling_tag : t -> string option
- end
-
- module Tagged_Coupling : Tagged_Coupling =
- struct
- type sign = int
- type t =
- { sign : sign;
- coupling : constant Coupling.t;
- coupling_tag : Tags.coupling }
- let sign c = c.sign
- let coupling c = c.coupling
- let coupling_tag_raw c = c.coupling_tag
- let coupling_tag rhs = Tags.coupling_to_string (coupling_tag_raw rhs)
- end
-
-(* \thocwmodulesubsection{Amplitudes: Monochrome and Colored} *)
-
- module type Amplitude =
- sig
-
- module Tags : Tags
-
- type flavor
- type p
-
- type wf =
- { flavor : flavor;
- momentum : p;
- wf_tag : Tags.wf }
-
- val flavor : wf -> flavor
- val conjugate : wf -> wf
- val momentum : wf -> p
- val momentum_list : wf -> int list
- val wf_tag : wf -> string option
- val wf_tag_raw : wf -> Tags.wf
- val order_wf : wf -> wf -> int
- val external_wfs : int -> (flavor * int) list -> wf list
-
- type 'a children
- type coupling = Tagged_Coupling.t
- type rhs = coupling * wf children
- val sign : rhs -> int
- val coupling : rhs -> constant Coupling.t
- val coupling_tag : rhs -> string option
- type exclusions
- val no_exclusions : exclusions
-
- val children : rhs -> wf list
-
- type fusion = wf * rhs list
- val lhs : fusion -> wf
- val rhs : fusion -> rhs list
-
- type braket = wf * rhs list
- val bra : braket -> wf
- val ket : braket -> rhs list
-
- module D :
- DAG.T with type node = wf and type edge = coupling and type children = wf children
-
- val wavefunctions : braket list -> wf list
-
- type amplitude =
- { fusions : fusion list;
- brakets : braket list;
- on_shell : (wf -> bool);
- is_gauss : (wf -> bool);
- constraints : string option;
- incoming : flavor list;
- outgoing : flavor list;
- externals : wf list;
- symmetry : int;
- dependencies : (wf -> (wf, coupling) Tree2.t);
- fusion_tower : D.t;
- fusion_dag : D.t }
-
- val incoming : amplitude -> flavor list
- val outgoing : amplitude -> flavor list
- val externals : amplitude -> wf list
- val variables : amplitude -> wf list
- val fusions : amplitude -> fusion list
- val brakets : amplitude -> braket list
- val on_shell : amplitude -> (wf -> bool)
- val is_gauss : amplitude -> (wf -> bool)
- val constraints : amplitude -> string option
- val symmetry : amplitude -> int
- val dependencies : amplitude -> wf -> (wf, coupling) Tree2.t
- val fusion_dag : amplitude -> D.t
-
- end
-
- module Amplitude (PT : Tuple.Poly) (P : Momentum.T) (M : Model.T) :
- Amplitude
- with type p = P.t
- and type flavor = M.flavor
- and type 'a children = 'a PT.t
- and module Tags = Tags =
- struct
-
- type flavor = M.flavor
- type p = P.t
-
- module Tags = Tags
-
- type wf =
- { flavor : flavor;
- momentum : p;
- wf_tag : Tags.wf }
-
- let flavor wf = wf.flavor
- let conjugate wf = { wf with flavor = M.conjugate wf.flavor }
- let momentum wf = wf.momentum
- let momentum_list wf = P.to_ints wf.momentum
- let wf_tag wf = Tags.wf_to_string wf.wf_tag
- let wf_tag_raw wf = wf.wf_tag
-
- let external_wfs rank particles =
- List.map
- (fun (f, p) ->
- { flavor = f;
- momentum = P.singleton rank p;
- wf_tag = Tags.null_wf })
- particles
-
-(* Order wavefunctions so that the external come first, then the pairs, etc.
- Also put possible Goldstone bosons \emph{before} their gauge bosons. *)
-
- let lorentz_ordering f =
- match M.lorentz f with
- | Coupling.Scalar -> 0
- | Coupling.Spinor -> 1
- | Coupling.ConjSpinor -> 2
- | Coupling.Majorana -> 3
- | Coupling.Vector -> 4
- | Coupling.Massive_Vector -> 5
- | Coupling.Tensor_2 -> 6
- | Coupling.Tensor_1 -> 7
- | Coupling.Vectorspinor -> 8
- | Coupling.BRS Coupling.Scalar -> 9
- | Coupling.BRS Coupling.Spinor -> 10
- | Coupling.BRS Coupling.ConjSpinor -> 11
- | Coupling.BRS Coupling.Majorana -> 12
- | Coupling.BRS Coupling.Vector -> 13
- | Coupling.BRS Coupling.Massive_Vector -> 14
- | Coupling.BRS Coupling.Tensor_2 -> 15
- | Coupling.BRS Coupling.Tensor_1 -> 16
- | Coupling.BRS Coupling.Vectorspinor -> 17
- | Coupling.BRS _ -> invalid_arg "Fusion.lorentz_ordering: not needed"
- | Coupling.Maj_Ghost -> 18
- (*i | Coupling.Ward_Vector -> 19 i*)
-
- let order_flavor f1 f2 =
- let c = compare (lorentz_ordering f1) (lorentz_ordering f2) in
- if c <> 0 then
- c
- else
- compare f1 f2
-
-(* Note that [Momentum().compare] guarantees that wavefunctions will be
- ordered according to \emph{increasing} [Momentum().rank] of their
- momenta. *)
-
- let order_wf wf1 wf2 =
- let c = P.compare wf1.momentum wf2.momentum in
- if c <> 0 then
- c
- else
- let c = order_flavor wf1.flavor wf2.flavor in
- if c <> 0 then
- c
- else
- compare wf1.wf_tag wf2.wf_tag
-
-(* This \emph{must} be a pair matching the [edge * node children] pairs of
- [DAG.Forest]! *)
-
- type coupling = Tagged_Coupling.t
- type 'a children = 'a PT.t
- type rhs = coupling * wf children
- let sign (c, _) = Tagged_Coupling.sign c
- let coupling (c, _) = Tagged_Coupling.coupling c
- let coupling_tag (c, _) = Tagged_Coupling.coupling_tag c
- type exclusions =
- { x_flavors : flavor list;
- x_couplings : coupling list }
- let no_exclusions = { x_flavors = []; x_couplings = [] }
- let children (_, wfs) = PT.to_list wfs
-
- type fusion = wf * rhs list
- let lhs (l, _) = l
- let rhs (_, r) = r
-
- type braket = wf * rhs list
- let bra (b, _) = b
- let ket (_, k) = k
-
- module D = DAG.Make
- (DAG.Forest(PT)
- (struct type t = wf let compare = order_wf end)
- (struct type t = coupling let compare = compare end))
-
- module WFSet =
- Set.Make (struct type t = wf let compare = order_wf end)
-
- let wavefunctions brakets =
- WFSet.elements (List.fold_left (fun set (wf1, wf23) ->
- WFSet.add wf1 (List.fold_left (fun set' (_, wfs) ->
- PT.fold_right WFSet.add wfs set') set wf23)) WFSet.empty brakets)
-
- type amplitude =
- { fusions : fusion list;
- brakets : braket list;
- on_shell : (wf -> bool);
- is_gauss : (wf -> bool);
- constraints : string option;
- incoming : flavor list;
- outgoing : flavor list;
- externals : wf list;
- symmetry : int;
- dependencies : (wf -> (wf, coupling) Tree2.t);
- fusion_tower : D.t;
- fusion_dag : D.t }
-
- let incoming a = a.incoming
- let outgoing a = a.outgoing
- let externals a = a.externals
- let fusions a = a.fusions
- let brakets a = a.brakets
- let symmetry a = a.symmetry
- let on_shell a = a.on_shell
- let is_gauss a = a.is_gauss
- let constraints a = a.constraints
- let variables a = List.map lhs a.fusions
- let dependencies a = a.dependencies
- let fusion_dag a = a.fusion_dag
-
- end
-
- module A = Amplitude(PT)(P)(M)
+ module A = Amplitude(PT)(P)(M)(Unsliced)
(* Operator insertions can be fused only if they are external. *)
let is_source wf =
match M.propagator wf.A.flavor with
| Only_Insertion -> P.rank wf.A.momentum = 1
| _ -> true
(* [is_goldstone_of g v] is [true] if and only if [g] is the Goldstone boson
corresponding to the gauge particle [v]. *)
let is_goldstone_of g v =
match M.goldstone v with
| None -> false
| Some (g', _) -> g = g'
(* \begin{dubious}
In the end, [PT.to_list] should become redudant!
\end{dubious} *)
let fuse_rhs rhs = M.fuse (PT.to_list rhs)
(* \thocwmodulesubsection{Vertices} *)
(* Compute the set of all vertices in the model from the allowed
fusions and the set of all flavors:
\begin{dubious}
One could think of using [M.vertices] instead of [M.fuse2],
[M.fuse3] and [M.fuse] \ldots
\end{dubious} *)
module VSet = Map.Make(struct type t = A.flavor let compare = compare end)
let add_vertices f rhs m =
VSet.add f (try rhs :: VSet.find f m with Not_found -> [rhs]) m
let collect_vertices rhs =
List.fold_right (fun (f1, c) -> add_vertices (M.conjugate f1) (c, rhs))
(fuse_rhs rhs)
(* The set of all vertices with common left fields factored. *)
(* I used to think that constant initializers are a good idea to allow
compile time optimizations. The down side turned out to be that the
constant initializers will be evaluated \emph{every time} the functor
is applied. \emph{Relying on the fact that the functor will be
called only once is not a good idea!} *)
type vertices = (A.flavor * (constant Coupling.t * A.flavor PT.t) list) list
(* \begin{dubious}
This is \emph{very} inefficient for [max_degree > 6]. Find a better
approach that avoids precomputing the huge lookup table!
\end{dubious}
\begin{dubious}
I should revive the above Idea to use [M.vertices] instead directly,
instead of rebuilding it from [M.fuse2],
[M.fuse3] and [M.fuse]!
\end{dubious} *)
let vertices_nocache max_degree flavors : vertices =
VSet.fold (fun f rhs v -> (f, rhs) :: v)
(PT.power_fold
~truncate:(pred max_degree)
collect_vertices flavors VSet.empty) []
(* Performance hack: *)
type vertex_table =
((A.flavor * A.flavor * A.flavor) * constant Coupling.vertex3 * constant) list
* ((A.flavor * A.flavor * A.flavor * A.flavor)
* constant Coupling.vertex4 * constant) list
* (A.flavor list * constant Coupling.vertexn * constant) list
-(*i
- module VCache =
- Cache.Make (struct type t = vertex_table end) (struct type t = vertices end)
-
- let vertices_cache = ref None
- let hash () = VCache.hash (M.vertices ())
-
-(* \begin{dubious}
- Can we do better than the executable name provided by [Config.cache_prefix]???
- We need a better way to avoid collisions among the caches for different models
- in the same program.
- \end{dubious} *)
-
- let cache_name =
- ref (Config.cache_prefix ^ "." ^ Config.cache_suffix)
-
- let set_cache_name name =
- cache_name := name
-
- let initialize_cache dir =
- Printf.eprintf
- " >>> Initializing vertex table %s. This may take some time ... "
- !cache_name;
- flush stderr;
- VCache.write_dir (hash ()) dir !cache_name
- (vertices_nocache (M.max_degree ()) (M.flavors()));
- Printf.eprintf "done. <<< \n"
-
- let vertices max_degree flavors : vertices =
- match !vertices_cache with
- | None ->
- begin match !cache_option with
- | Cache_Use ->
- begin match VCache.maybe_read (hash ()) !cache_name with
- | VCache.Hit result -> result
- | VCache.Miss ->
- Printf.eprintf
- " >>> Initializing vertex table %s. This may take some time ... "
- !cache_name;
- flush stderr;
- let result = vertices_nocache max_degree flavors in
- VCache.write (hash ()) !cache_name (result);
- vertices_cache := Some result;
- Printf.eprintf "done. <<< \n";
- flush stderr;
- result
- | VCache.Stale file ->
- Printf.eprintf
- " >>> Re-initializing stale vertex table %s in file %s. "
- !cache_name file;
- Printf.eprintf "This may take some time ... ";
- flush stderr;
- let result = vertices_nocache max_degree flavors in
- VCache.write (hash ()) !cache_name (result);
- vertices_cache := Some result;
- Printf.eprintf "done. <<< \n";
- flush stderr;
- result
- end
- | Cache_Overwrite ->
- Printf.eprintf
- " >>> Overwriting vertex table %s. This may take some time ... "
- !cache_name;
- flush stderr;
- let result = vertices_nocache max_degree flavors in
- VCache.write (hash ()) !cache_name (result);
- vertices_cache := Some result;
- Printf.eprintf "done. <<< \n";
- flush stderr;
- result
- | Cache_Ignore ->
- let result = vertices_nocache max_degree flavors in
- vertices_cache := Some result;
- result
- end
- | Some result -> result
-i*)
let vertices = vertices_nocache
let vertices' max_degree flavors =
Printf.eprintf ">>> vertices %d ..." max_degree;
flush stderr;
let v = vertices max_degree flavors in
Printf.eprintf " done.\n";
flush stderr;
v
-(* Note that we must perform any filtering of the vertices \emph{after}
- caching, because the restrictions \emph{must not} influence the
- cache (unless we tag the cache with model and restrictions). *)
-
-(*i
- let unpack_constant = function
- | Coupling.V3 (_, _, cs) -> cs
- | Coupling.V4 (_, _, cs) -> cs
- | Coupling.Vn (_, _, cs) -> cs
-
- let coupling_and_flavors_to_string (c, fs) =
- M.constant_symbol (unpack_constant c) ^ "[" ^
- String.concat ", " (List.map M.flavor_to_string (PT.to_list fs)) ^ "]"
-
- let fusions_to_string (f, cfs) =
- M.flavor_to_string f ^ " <- { " ^
- String.concat " | " (List.map coupling_and_flavors_to_string cfs) ^
- " }"
-
- let vertices_to_string vertices =
- String.concat "; " (List.map fusions_to_string vertices)
- i*)
-
let filter_vertices select_vtx vertices =
List.fold_left
(fun acc (f, cfs) ->
let f' = M.conjugate f in
let cfs =
List.filter
(fun (c, fs) -> select_vtx c f' (PT.to_list fs))
cfs
in
match cfs with
| [] -> acc
| cfs -> (f, cfs) :: acc)
[] vertices
-(* \thocwmodulesubsection{Partitions} *)
+(* \thocwmodulesubsection{$K$-Matrix Filtering} *)
(* Vertices that are not crossing invariant need special treatment so
that they're only generated for the correct combinations of momenta.
NB: the [crossing] checks here are a bit redundant, because [CM.fuse] below
will bring the killed vertices back to life and will have to filter once more.
Nevertheless, we keep them here, for the unlikely case that anybody ever wants
to use uncolored amplitudes directly.
NB: the analogous problem does not occur for [select_wf], because this applies
to momenta instead of vertices. *)
(* \begin{dubious}
This approach worked before the colorize, but has become \emph{futile},
because [CM.fuse] will bring the killed vertices back to life. We need
to implement the same checks there again!!!
\end{dubious} *)
(* \begin{dubious}
Using [PT.Mismatched_arity] is not really good style \ldots
Tho's approach doesn't work since he does not catch charge conjugated processes or
crossed processes. Another very strange thing is that O'Mega seems always to run in the
q2 q3 timelike case, but not in the other two. (Property of how the DAG is built?).
For the $ZZZZ$ vertex I add the same vertex again, but interchange 1 and 3 in the
[crossing] vertex
\end{dubious} *)
+ let timelike_sut momenta =
+ let timelike p q = P.Scattering.timelike (P.add p q) in
+ match PT.to_list momenta with
+ | [q1; q2; q3] -> (timelike q1 q2, timelike q2 q3, timelike q1 q3)
+ | _ -> raise PT.Mismatched_arity
+
let kmatrix_cuts c momenta =
+ let open Coupling in
match c with
| V4 (Vector4_K_Matrix_tho (disc, _), fusion, _)
- | V4 (Vector4_K_Matrix_jr (disc, _), fusion, _) ->
- let s12, s23, s13 =
- begin match PT.to_list momenta with
- | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2),
- P.Scattering.timelike (P.add q2 q3),
- P.Scattering.timelike (P.add q1 q3))
- | _ -> raise PT.Mismatched_arity
- end in
- begin match disc, s12, s23, s13, fusion with
- | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214)
- | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421)
- | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) ->
- true
- | 1, true, false, false, (F341|F431|F342|F432)
- | 1, false, true, false, (F134|F143|F234|F243)
- | 1, false, false, true, (F314|F413|F324|F423) ->
- true
- | 2, true, false, false, (F123|F213|F124|F214)
- | 2, false, true, false, (F312|F321|F412|F421)
- | 2, false, false, true, (F132|F231|F142|F241) ->
- true
- | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234)
- | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423)
- | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) ->
- true
- | _ -> false
- end
- | V4 (Vector4_K_Matrix_cf_t0 (disc, _), fusion, _) ->
- let s12, s23, s13 =
- begin match PT.to_list momenta with
- | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2),
- P.Scattering.timelike (P.add q2 q3),
- P.Scattering.timelike (P.add q1 q3))
- | _ -> raise PT.Mismatched_arity
- end in
- begin match disc, s12, s23, s13, fusion with
- | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214)
- | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421)
- | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) ->
- true
- | 1, true, false, false, (F341|F431|F342|F432)
- | 1, false, true, false, (F134|F143|F234|F243)
- | 1, false, false, true, (F314|F413|F324|F423) ->
- true
- | 2, true, false, false, (F123|F213|F124|F214)
- | 2, false, true, false, (F312|F321|F412|F421)
- | 2, false, false, true, (F132|F231|F142|F241) ->
- true
- | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234)
- | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423)
- | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) ->
- true
- | _ -> false
- end
- | V4 (Vector4_K_Matrix_cf_t1 (disc, _), fusion, _) ->
- let s12, s23, s13 =
- begin match PT.to_list momenta with
- | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2),
- P.Scattering.timelike (P.add q2 q3),
- P.Scattering.timelike (P.add q1 q3))
- | _ -> raise PT.Mismatched_arity
- end in
- begin match disc, s12, s23, s13, fusion with
- | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214)
- | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421)
- | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) ->
- true
- | 1, true, false, false, (F341|F431|F342|F432)
- | 1, false, true, false, (F134|F143|F234|F243)
- | 1, false, false, true, (F314|F413|F324|F423) ->
- true
- | 2, true, false, false, (F123|F213|F124|F214)
- | 2, false, true, false, (F312|F321|F412|F421)
- | 2, false, false, true, (F132|F231|F142|F241) ->
- true
- | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234)
- | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423)
- | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) ->
- true
- | _ -> false
- end
- | V4 (Vector4_K_Matrix_cf_t2 (disc, _), fusion, _) ->
- let s12, s23, s13 =
- begin match PT.to_list momenta with
- | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2),
- P.Scattering.timelike (P.add q2 q3),
- P.Scattering.timelike (P.add q1 q3))
- | _ -> raise PT.Mismatched_arity
- end in
- begin match disc, s12, s23, s13, fusion with
- | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214)
- | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421)
- | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) ->
- true
- | 1, true, false, false, (F341|F431|F342|F432)
- | 1, false, true, false, (F134|F143|F234|F243)
- | 1, false, false, true, (F314|F413|F324|F423) ->
- true
- | 2, true, false, false, (F123|F213|F124|F214)
- | 2, false, true, false, (F312|F321|F412|F421)
- | 2, false, false, true, (F132|F231|F142|F241) ->
- true
- | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234)
- | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423)
- | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) ->
- true
- | _ -> false
- end
- | V4 (Vector4_K_Matrix_cf_t_rsi (disc, _), fusion, _) ->
- let s12, s23, s13 =
- begin match PT.to_list momenta with
- | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2),
- P.Scattering.timelike (P.add q2 q3),
- P.Scattering.timelike (P.add q1 q3))
- | _ -> raise PT.Mismatched_arity
- end in
- begin match disc, s12, s23, s13, fusion with
- | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214)
- | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421)
- | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) ->
- true
- | 1, true, false, false, (F341|F431|F342|F432)
- | 1, false, true, false, (F134|F143|F234|F243)
- | 1, false, false, true, (F314|F413|F324|F423) ->
- true
- | 2, true, false, false, (F123|F213|F124|F214)
- | 2, false, true, false, (F312|F321|F412|F421)
- | 2, false, false, true, (F132|F231|F142|F241) ->
- true
- | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234)
- | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423)
- | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) ->
- true
- | _ -> false
- end
- | V4 (Vector4_K_Matrix_cf_m0 (disc, _), fusion, _) ->
- let s12, s23, s13 =
- begin match PT.to_list momenta with
- | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2),
- P.Scattering.timelike (P.add q2 q3),
- P.Scattering.timelike (P.add q1 q3))
- | _ -> raise PT.Mismatched_arity
- end in
- begin match disc, s12, s23, s13, fusion with
- | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214)
- | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421)
- | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) ->
- true
- | 1, true, false, false, (F341|F431|F342|F432)
- | 1, false, true, false, (F134|F143|F234|F243)
- | 1, false, false, true, (F314|F413|F324|F423) ->
- true
- | 2, true, false, false, (F123|F213|F124|F214)
- | 2, false, true, false, (F312|F321|F412|F421)
- | 2, false, false, true, (F132|F231|F142|F241) ->
- true
- | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234)
- | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423)
- | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) ->
- true
- | _ -> false
- end
- | V4 (Vector4_K_Matrix_cf_m1 (disc, _), fusion, _) ->
- let s12, s23, s13 =
- begin match PT.to_list momenta with
- | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2),
- P.Scattering.timelike (P.add q2 q3),
- P.Scattering.timelike (P.add q1 q3))
- | _ -> raise PT.Mismatched_arity
- end in
- begin match disc, s12, s23, s13, fusion with
- | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214)
- | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421)
- | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) ->
- true
- | 1, true, false, false, (F341|F431|F342|F432)
- | 1, false, true, false, (F134|F143|F234|F243)
- | 1, false, false, true, (F314|F413|F324|F423) ->
- true
- | 2, true, false, false, (F123|F213|F124|F214)
- | 2, false, true, false, (F312|F321|F412|F421)
- | 2, false, false, true, (F132|F231|F142|F241) ->
- true
- | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234)
- | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423)
- | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) ->
- true
- | _ -> false
- end
+ | V4 (Vector4_K_Matrix_jr (disc, _), fusion, _)
+ | V4 (Vector4_K_Matrix_cf_t0 (disc, _), fusion, _)
+ | V4 (Vector4_K_Matrix_cf_t1 (disc, _), fusion, _)
+ | V4 (Vector4_K_Matrix_cf_t2 (disc, _), fusion, _)
+ | V4 (Vector4_K_Matrix_cf_t_rsi (disc, _), fusion, _)
+ | V4 (Vector4_K_Matrix_cf_m0 (disc, _), fusion, _)
+ | V4 (Vector4_K_Matrix_cf_m1 (disc, _), fusion, _)
| V4 (Vector4_K_Matrix_cf_m7 (disc, _), fusion, _) ->
- let s12, s23, s13 =
- begin match PT.to_list momenta with
- | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2),
- P.Scattering.timelike (P.add q2 q3),
- P.Scattering.timelike (P.add q1 q3))
- | _ -> raise PT.Mismatched_arity
- end in
+ let s12, s23, s13 = timelike_sut momenta in
begin match disc, s12, s23, s13, fusion with
| 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214)
| 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421)
| 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) ->
true
| 1, true, false, false, (F341|F431|F342|F432)
| 1, false, true, false, (F134|F143|F234|F243)
| 1, false, false, true, (F314|F413|F324|F423) ->
true
| 2, true, false, false, (F123|F213|F124|F214)
| 2, false, true, false, (F312|F321|F412|F421)
| 2, false, false, true, (F132|F231|F142|F241) ->
true
| 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234)
| 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423)
| 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) ->
true
| _ -> false
- end
- | V4 (DScalar2_Vector2_K_Matrix_ms (disc, _), fusion, _) ->
- let s12, s23, s13 =
- begin match PT.to_list momenta with
- | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2),
- P.Scattering.timelike (P.add q2 q3),
- P.Scattering.timelike (P.add q1 q3))
- | _ -> raise PT.Mismatched_arity
- end in
- begin match disc, s12, s23, s13, fusion with
- | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214)
- | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421)
- | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) ->
- true
- | 1, true, false, false, (F341|F432|F123|F214)
- | 1, false, true, false, (F134|F243|F312|F421)
- | 1, false, false, true, (F314|F423|F132|F241) ->
- true
- | 2, true, false, false, (F431|F342|F213|F124)
- | 2, false, true, false, (F143|F234|F321|F412)
- | 2, false, false, true, (F413|F324|F231|F142) ->
- true
- | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234)
- | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423)
- | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) ->
- true
- | 4, true, false, false, (F142|F413|F231|F324)
- | 4, false, true, false, (F214|F341|F123|F432)
- | 4, false, false, true, (F124|F431|F213|F342) ->
- true
- | 5, true, false, false, (F143|F412|F321|F234)
- | 5, false, true, false, (F314|F241|F132|F423)
- | 5, false, false, true, (F134|F421|F312|F243) ->
- true
- | 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423)
- | 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342)
- | 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) ->
- true
- | 7, true, false, false, (F134|F312|F421|F243)
- | 7, false, true, false, (F413|F231|F142|F324)
- | 7, false, false, true, (F143|F321|F412|F432) ->
- true
- | 8, true, false, false, (F132|F314|F241|F423)
- | 8, false, true, false, (F213|F431|F124|F342)
- | 8, false, false, true, (F123|F341|F214|F234) ->
- true
- | _ -> false
end
- | V4 (DScalar2_Vector2_m_0_K_Matrix_cf (disc, _), fusion, _) ->
- let s12, s23, s13 =
- begin match PT.to_list momenta with
- | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2),
- P.Scattering.timelike (P.add q2 q3),
- P.Scattering.timelike (P.add q1 q3))
- | _ -> raise PT.Mismatched_arity
- end in
- begin match disc, s12, s23, s13, fusion with
- | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214)
- | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421)
- | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) ->
- true
- | 1, true, false, false, (F341|F432|F123|F214)
- | 1, false, true, false, (F134|F243|F312|F421)
- | 1, false, false, true, (F314|F423|F132|F241) ->
- true
- | 2, true, false, false, (F431|F342|F213|F124)
- | 2, false, true, false, (F143|F234|F321|F412)
- | 2, false, false, true, (F413|F324|F231|F142) ->
- true
- | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234)
- | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423)
- | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) ->
- true
- | 4, true, false, false, (F142|F413|F231|F324)
- | 4, false, true, false, (F214|F341|F123|F432)
- | 4, false, false, true, (F124|F431|F213|F342) ->
- true
- | 5, true, false, false, (F143|F412|F321|F234)
- | 5, false, true, false, (F314|F241|F132|F423)
- | 5, false, false, true, (F134|F421|F312|F243) ->
- true
- | 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423)
- | 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342)
- | 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) ->
- true
- | 7, true, false, false, (F134|F312|F421|F243)
- | 7, false, true, false, (F413|F231|F142|F324)
- | 7, false, false, true, (F143|F321|F412|F432) ->
- true
- | 8, true, false, false, (F132|F314|F241|F423)
- | 8, false, true, false, (F213|F431|F124|F342)
- | 8, false, false, true, (F123|F341|F214|F234) ->
- true
- | _ -> false
- end
- | V4 (DScalar2_Vector2_m_1_K_Matrix_cf (disc, _), fusion, _) ->
- let s12, s23, s13 =
- begin match PT.to_list momenta with
- | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2),
- P.Scattering.timelike (P.add q2 q3),
- P.Scattering.timelike (P.add q1 q3))
- | _ -> raise PT.Mismatched_arity
- end in
- begin match disc, s12, s23, s13, fusion with
- | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214)
- | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421)
- | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) ->
- true
- | 1, true, false, false, (F341|F432|F123|F214)
- | 1, false, true, false, (F134|F243|F312|F421)
- | 1, false, false, true, (F314|F423|F132|F241) ->
- true
- | 2, true, false, false, (F431|F342|F213|F124)
- | 2, false, true, false, (F143|F234|F321|F412)
- | 2, false, false, true, (F413|F324|F231|F142) ->
- true
- | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234)
- | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423)
- | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) ->
- true
- | 4, true, false, false, (F142|F413|F231|F324)
- | 4, false, true, false, (F214|F341|F123|F432)
- | 4, false, false, true, (F124|F431|F213|F342) ->
- true
- | 5, true, false, false, (F143|F412|F321|F234)
- | 5, false, true, false, (F314|F241|F132|F423)
- | 5, false, false, true, (F134|F421|F312|F243) ->
- true
- | 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423)
- | 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342)
- | 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) ->
- true
- | 7, true, false, false, (F134|F312|F421|F243)
- | 7, false, true, false, (F413|F231|F142|F324)
- | 7, false, false, true, (F143|F321|F412|F432) ->
- true
- | 8, true, false, false, (F132|F314|F241|F423)
- | 8, false, true, false, (F213|F431|F124|F342)
- | 8, false, false, true, (F123|F341|F214|F234) ->
- true
- | _ -> false
- end
+
+ | V4 (DScalar2_Vector2_K_Matrix_ms (disc, _), fusion, _)
+ | V4 (DScalar2_Vector2_m_0_K_Matrix_cf (disc, _), fusion, _)
+ | V4 (DScalar2_Vector2_m_1_K_Matrix_cf (disc, _), fusion, _)
| V4 (DScalar2_Vector2_m_7_K_Matrix_cf (disc, _), fusion, _) ->
- let s12, s23, s13 =
- begin match PT.to_list momenta with
- | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2),
- P.Scattering.timelike (P.add q2 q3),
- P.Scattering.timelike (P.add q1 q3))
- | _ -> raise PT.Mismatched_arity
- end in
+ let s12, s23, s13 = timelike_sut momenta in
begin match disc, s12, s23, s13, fusion with
| 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214)
| 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421)
| 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) ->
true
| 1, true, false, false, (F341|F432|F123|F214)
| 1, false, true, false, (F134|F243|F312|F421)
| 1, false, false, true, (F314|F423|F132|F241) ->
true
| 2, true, false, false, (F431|F342|F213|F124)
| 2, false, true, false, (F143|F234|F321|F412)
| 2, false, false, true, (F413|F324|F231|F142) ->
true
| 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234)
| 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423)
| 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) ->
true
| 4, true, false, false, (F142|F413|F231|F324)
| 4, false, true, false, (F214|F341|F123|F432)
| 4, false, false, true, (F124|F431|F213|F342) ->
true
| 5, true, false, false, (F143|F412|F321|F234)
| 5, false, true, false, (F314|F241|F132|F423)
| 5, false, false, true, (F134|F421|F312|F243) ->
true
| 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423)
| 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342)
| 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) ->
true
| 7, true, false, false, (F134|F312|F421|F243)
| 7, false, true, false, (F413|F231|F142|F324)
| 7, false, false, true, (F143|F321|F412|F432) ->
true
| 8, true, false, false, (F132|F314|F241|F423)
| 8, false, true, false, (F213|F431|F124|F342)
| 8, false, false, true, (F123|F341|F214|F234) ->
true
| _ -> false
- end
+ end
+
+(* \begin{dubious}
+ Are the missing cases [1] and [2] for [disc] an oversight
+ here?
+ \end{dubious} *)
| V4 (DScalar4_K_Matrix_ms (disc, _), fusion, _) ->
- let s12, s23, s13 =
- begin match PT.to_list momenta with
- | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2),
- P.Scattering.timelike (P.add q2 q3),
- P.Scattering.timelike (P.add q1 q3))
- | _ -> raise PT.Mismatched_arity
- end in
+ let s12, s23, s13 = timelike_sut momenta in
begin match disc, s12, s23, s13, fusion with
| 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214)
| 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421)
| 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) ->
true
| 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234)
| 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423)
| 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) ->
true
| 4, true, false, false, (F142|F413|F231|F324)
| 4, false, true, false, (F214|F341|F123|F432)
| 4, false, false, true, (F124|F431|F213|F342) ->
true
| 5, true, false, false, (F143|F412|F321|F234)
| 5, false, true, false, (F314|F241|F132|F423)
| 5, false, false, true, (F134|F421|F312|F243) ->
true
| 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423)
| 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342)
| 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) ->
true
| 7, true, false, false, (F134|F312|F421|F243)
| 7, false, true, false, (F413|F231|F142|F324)
| 7, false, false, true, (F143|F321|F412|F432) ->
true
| 8, true, false, false, (F132|F314|F241|F423)
| 8, false, true, false, (F213|F431|F124|F342)
| 8, false, false, true, (F123|F341|F214|F234) ->
true
| _ -> false
end
- | _ -> true
-
-
-(* Counting QCD and EW orders. *)
-
- let qcd_ew_check orders =
- if fst (orders) <= fst (int_orders) &&
- snd (orders) <= snd (int_orders) then
- true
- else
- false
+ | _ -> true
(* Match a set of flavors to a set of momenta. Form the direct product for
the lists of momenta two and three with the list of couplings and flavors
two and three. *)
let flavor_keystone select_p dim (f1, f23) (p1, p23) =
({ A.flavor = f1;
- A.momentum = P.of_ints dim p1;
- A.wf_tag = A.Tags.null_wf },
+ A.momentum = P.of_ints dim p1 },
Product.fold2 (fun (c, f) p acc ->
try
let p' = PT.map (P.of_ints dim) p in
if select_p (P.of_ints dim p1) (PT.to_list p') && kmatrix_cuts c p' then
(c, PT.map2 (fun f'' p'' -> { A.flavor = f'';
- A.momentum = p'';
- A.wf_tag = A.Tags.null_wf }) f p') :: acc
+ A.momentum = p'' }) f p') :: acc
else
acc
with
| PT.Mismatched_arity -> acc) f23 p23 [])
-(*i
- let cnt = ref 0
-
- let gc_stat () =
- let minor, promoted, major = Gc.counters () in
- Printf.sprintf "(%12.0f, %12.0f, %12.0f)" minor promoted major
-
- let flavor_keystone select_p n (f1, f23) (p1, p23) =
- incr cnt;
- Gc.set { (Gc.get()) with Gc.space_overhead = 20 };
- Printf.eprintf "%6d@%8.1f: %s\n" !cnt (Sys.time ()) (gc_stat ());
- flush stderr;
- flavor_keystone select_p n (f1, f23) (p1, p23)
-i*)
-
(* Produce all possible combinations of vertices (flavor keystones)
and momenta by forming the direct product. The semantically equivalent
[Product.list2 (flavor_keystone select_wf n) vertices keystones] with
\emph{subsequent} filtering would be a \emph{very bad} idea, because
a potentially huge intermediate list is built for large models.
E.\,g.~for the MSSM this would lead to non-termination by thrashing
for $2\to4$ processes on most PCs. *)
let flavor_keystones filter select_p dim vertices keystones =
Product.fold2 (fun v k acc ->
filter (flavor_keystone select_p dim v k) acc) vertices keystones []
(* Flatten the nested lists of vertices into a list of attached lines. *)
let flatten_keystones t =
ThoList.flatmap (fun (p1, p23) ->
p1 :: (ThoList.flatmap (fun (_, rhs) -> PT.to_list rhs) p23)) t
(* \thocwmodulesubsection{Subtrees} *)
(* Fuse a tuple of wavefunctions, keeping track of Fermi statistics.
Record only the the sign \emph{relative} to the children.
(The type annotation is only for documentation.) *)
let fuse select_wf select_vtx wfss : (A.wf * stat * A.rhs) list =
if PT.for_all (fun (wf, _) -> is_source wf) wfss then
try
let wfs, ss = PT.split wfss in
let flavors = PT.map A.flavor wfs
- and momenta = PT.map A.momentum wfs
-(*i and wf_tags = PT.map A.wf_tag_raw wfs i*) in
+ and momenta = PT.map A.momentum wfs in
let p = PT.fold_left_internal P.add momenta in
-(*i let wft = PT.fold_left Tags.fuse wf_tags in i*)
List.fold_left
(fun acc (f, c) ->
if select_wf f p (PT.to_list momenta)
&& select_vtx c f (PT.to_list flavors)
&& kmatrix_cuts c momenta then
- (* [let _ =
- Printf.eprintf
- "Fusion.fuse: %s <- %s\n"
- (M.flavor_to_string f)
- (ThoList.to_string M.flavor_to_string (PT.to_list flavors)) in] *)
let s = S.stat_fuse (fermion_lines c) (PT.to_list ss) f in
- let flip =
- PT.fold_left (fun acc s' -> acc * stat_sign s') (stat_sign s) ss in
+ let flip = PT.fold_left (fun acc s' -> acc * stat_sign s') (stat_sign s) ss in
({ A.flavor = f;
- A.momentum = p;
- A.wf_tag = A.Tags.null_wf }, s,
- ({ Tagged_Coupling.sign = flip;
- Tagged_Coupling.coupling = c;
- Tagged_Coupling.coupling_tag = A.Tags.null_coupling }, wfs)) :: acc
+ A.momentum = p }, s,
+ ({ A.sign = flip;
+ A.coupling = c }, wfs)) :: acc
else
acc)
[] (fuse_rhs flavors)
with
| P.Duplicate _ | S.Impossible -> []
else
[]
+(*i [let _ =
+ Printf.eprintf
+ "Fusion.fuse: %s <- %s\n"
+ (M.flavor_to_string f)
+ (ThoList.to_string M.flavor_to_string (PT.to_list flavors)) in]
+i*)
+
(* \begin{dubious}
Eventually, the pairs of [tower] and [dag] in [fusion_tower']
below could and should be replaced by a graded [DAG]. This will
look like, but currently [tower] containts statistics information
that is missing from [dag]:
\begin{quote}
\verb+Type node = flavor * p is not compatible with type wf * stat+
\end{quote}
This should be easy to fix. However, replacing [type t = wf]
with [type t = wf * stat] is \emph{not} a good idea because the variable
[stat] makes it impossible to test for the existance of a particular
[wf] in a [DAG].
\end{dubious}
\begin{dubious}
In summary, it seems that [(wf * stat) list array * A.D.t] should be
replaced by [(wf -> stat) * A.D.t].
\end{dubious} *)
module GF =
struct
module Nodes =
struct
type t = A.wf
module G = struct type t = int let compare = compare end
let compare = A.order_wf
let rank wf = P.rank wf.A.momentum
end
module Edges = struct type t = A.coupling let compare = compare end
module F = DAG.Forest(PT)(Nodes)(Edges)
type node = Nodes.t
type edge = F.edge
type children = F.children
type t = F.t
let compare = F.compare
let for_all = F.for_all
let fold = F.fold
end
module D' = DAG.Graded(GF)
let tower_of_dag dag =
let _, max_rank = D'.min_max_rank dag in
Array.init max_rank (fun n -> D'.ranked n dag)
(* The function [fusion_tower']
recursively builds the tower of all fusions from bottom up to a chosen
level. The argument [tower] is an array of lists, where the $i$-th sublist
(counting from 0) represents all off shell wave functions depending on
$i+1$~momenta and their Fermistatistics.
\begin{equation}
\begin{aligned}
\Bigl\lbrack
& \{ \phi_1(p_1), \phi_2(p_2), \phi_3(p_3), \ldots \}, \\
& \{ \phi_{12}(p_1+p_2), \phi'_{12}(p_1+p_2), \ldots,
\phi_{13}(p_1+p_3), \ldots, \phi_{23}(p_2+p_3), \ldots \}, \\
& \ldots \\
& \{ \phi_{1\cdots n}(p_1+\cdots+p_n),
\phi'_{1\cdots n}(p_1+\cdots+p_n), \ldots \} \Bigr\rbrack
\end{aligned}
\end{equation}
The argument [dag] is a DAG representing all the fusions calculated so far.
NB: The outer array in [tower] is always very short, so we could also
have accessed a list with [List.nth]. Appending of new members at the
end brings no loss of performance. NB: the array is supposed to be
immutable. *)
(* The towers must be sorted so that the combinatorical functions can
make consistent selections.
\begin{dubious}
Intuitively, this seems to be correct. However, one could have
expected that no element appears twice and that this ordering is
not necessary \ldots
\end{dubious} *)
let grow select_wf select_vtx tower =
let rank = succ (Array.length tower) in
- List.sort pcompare
+ List.sort Stdlib.compare
(PT.graded_sym_power_fold rank
(fun wfs acc -> fuse select_wf select_vtx wfs @ acc) tower [])
let add_offspring dag (wf, _, rhs) =
A.D.add_offspring wf rhs dag
let filter_offspring fusions =
List.map (fun (wf, s, _) -> (wf, s)) fusions
let rec fusion_tower' n_max select_wf select_vtx tower dag : (A.wf * stat) list array * A.D.t =
if Array.length tower >= n_max then
(tower, dag)
else
let tower' = grow select_wf select_vtx tower in
fusion_tower' n_max select_wf select_vtx
(Array.append tower [|filter_offspring tower'|])
(List.fold_left add_offspring dag tower')
(* Discard the tower and return a map from wave functions to Fermistatistics
together with the DAG. *)
let make_external_dag wfs =
List.fold_left (fun m (wf, _) -> A.D.add_node wf m) A.D.empty wfs
let mixed_fold_left f acc lists =
Array.fold_left (List.fold_left f) acc lists
- module Stat_Map =
- Map.Make (struct type t = A.wf let compare = A.order_wf end)
+ module WF = struct type t = A.wf let compare = A.order_wf end
+ module FWMap = Map.Make(WF)
let fusion_tower height select_wf select_vtx wfs : (A.wf -> stat) * A.D.t =
let tower, dag =
fusion_tower' height select_wf select_vtx [|wfs|] (make_external_dag wfs) in
let stats = mixed_fold_left
- (fun m (wf, s) -> Stat_Map.add wf s m) Stat_Map.empty tower in
- ((fun wf -> Stat_Map.find wf stats), dag)
+ (fun m (wf, s) -> FWMap.add wf s m) FWMap.empty tower in
+ ((fun wf -> FWMap.find wf stats), dag)
(* Calculate the minimal tower of fusions that suffices for calculating
the amplitude. *)
let minimal_fusion_tower n select_wf select_vtx wfs : (A.wf -> stat) * A.D.t =
fusion_tower (T.max_subtree n) select_wf select_vtx wfs
(* Calculate the complete tower of fusions. It is much larger than required,
but it allows a complete set of gauge checks. *)
let complete_fusion_tower select_wf select_vtx wfs : (A.wf -> stat) * A.D.t =
fusion_tower (List.length wfs - 1) select_wf select_vtx wfs
(* \begin{dubious}
There is a natural product of two DAGs using [fuse]. Can this be
used in a replacement for [fusion_tower]? The hard part is to avoid
double counting, of course. A straight forward solution
could do a diagonal sum (in order to reject flipped offspring representing
the same fusion) and rely on the uniqueness in [DAG] otherwise.
However, this will (probably) slow down the procedure significanty,
because most fusions (including Fermi signs!) will be calculated before
being rejected by [DAG().add_offspring].
\end{dubious} *)
(* Add to [dag] all Goldstone bosons defined in [tower] that correspond
to gauge bosons in [dag]. This is only required for checking
Slavnov-Taylor identities in unitarity gauge. Currently, it is not used,
because we use the complete tower for gauge checking. *)
let harvest_goldstones tower dag =
A.D.fold_nodes (fun wf dag' ->
match M.goldstone wf.A.flavor with
| Some (g, _) ->
let wf' = { wf with A.flavor = g } in
if A.D.is_node wf' tower then begin
A.D.harvest tower wf' dag'
end else begin
dag'
end
| None -> dag') dag dag
(* Calculate the sign from Fermi statistics that is not already included
in the children. *)
let strip_fermion_lines = function
| (Coupling.V3 _ | Coupling.V4 _ as v) -> v
| Coupling.Vn (Coupling.UFO (c, l, s, fl, col), f, x) ->
Coupling.Vn (Coupling.UFO (c, l, s, [], col), f, x)
let num_fermion_lines_v3 = function
- | FBF _ | PBP _ | BBB _ | GBG _ -> 1
+ | Coupling.FBF _ | Coupling.PBP _ | Coupling.BBB _ | Coupling.GBG _ -> 1
| _ -> 0
let num_fermion_lines = function
| Coupling.Vn (Coupling.UFO (c, l, s, fl, col), f, x) -> List.length fl
| Coupling.V3 (v3, _, _) -> num_fermion_lines_v3 v3
| Coupling.V4 _ -> 0
let stat_keystone v stats wf1 wfs =
let wf1' = stats wf1
and wfs' = PT.map stats wfs in
let f = A.flavor wf1 in
let slist = wf1' :: PT.to_list wfs' in
let stat = S.stat_keystone (fermion_lines v) slist f in
(* We can compare with the legacy implementation only if there
are no fermion line ambiguities possible, i.\,e.~for
at most one line. *)
if num_fermion_lines v < 2 then
begin
let legacy = S.stat_keystone None slist f in
if not (S.equal stat legacy) then
failwith
(Printf.sprintf
"Fusion.stat_keystone: %s <> %s!"
(S.stat_to_string legacy)
(S.stat_to_string stat));
if not (S.saturated legacy) then
failwith
(Printf.sprintf
"Fusion.stat_keystone: legacy incomplete: %s!"
(S.stat_to_string legacy))
end;
if not (S.saturated stat) then
failwith
(Printf.sprintf
"Fusion.stat_keystone: incomplete: %s!"
(S.stat_to_string stat));
stat_sign stat
* PT.fold_left (fun acc wf -> acc * stat_sign wf) (stat_sign wf1') wfs'
let stat_keystone_logging v stats wf1 wfs =
let sign = stat_keystone v stats wf1 wfs in
Printf.eprintf
"Fusion.stat_keystone: %s * %s -> %d\n"
(M.flavor_to_string (A.flavor wf1))
(ThoList.to_string
(fun wf -> M.flavor_to_string (A.flavor wf))
(PT.to_list wfs))
sign;
sign
(* Test all members of a list of wave functions are defined by the DAG
simultaneously: *)
let test_rhs dag (_, wfs) =
PT.for_all (fun wf -> is_source wf && A.D.is_node wf dag) wfs
(* Add the keystone [(wf1,pairs)] to [acc] only if it is present in [dag]
and calculate the statistical factor depending on [stats]
\emph{en passant}: *)
let filter_keystone stats dag (wf1, pairs) acc =
if is_source wf1 && A.D.is_node wf1 dag then
match List.filter (test_rhs dag) pairs with
| [] -> acc
| pairs' -> (wf1, List.map (fun (c, wfs) ->
- ({ Tagged_Coupling.sign = stat_keystone c stats wf1 wfs;
- Tagged_Coupling.coupling = c;
- Tagged_Coupling.coupling_tag = A.Tags.null_coupling },
+ ({ A.sign = stat_keystone c stats wf1 wfs;
+ A.coupling = c },
wfs)) pairs') :: acc
else
acc
(* \begin{figure}
\begin{center}
\thocwincludegraphics{width=\textwidth}{bhabha0}\\
\hfil\\
\thocwincludegraphics{width=\textwidth}{bhabha}
\end{center}
\caption{\label{fig:bhabha}
The DAGs for Bhabha scattering before and after weeding out unused
nodes. The blatant asymmetry of these DAGs is caused by our
prescription for removing doubling counting for an even number
of external lines.}
\end{figure}
\begin{figure}
\begin{center}
\thocwincludegraphics{width=\textwidth}{epemudbarmunumubar0}\\
\hfil\\
\thocwincludegraphics{width=\textwidth}{epemudbarmunumubar}
\end{center}
\caption{\label{fig:epemudbarmunumubar}
The DAGs for $e^+e^-\to u\bar d \mu^-\bar\nu_\mu$ before and after
weeding out unused nodes.}
\end{figure}
\begin{figure}
\begin{center}
\thocwincludegraphics{width=\textwidth}{epemudbardubar0}\\
\hfil\\
\thocwincludegraphics{width=\textwidth}{epemudbardubar}
\end{center}
\caption{\label{fig:epemudbardubar}
The DAGs for $e^+e^-\to u\bar d d\bar u$ before and after weeding
out unused nodes.}
\end{figure} *)
(* \thocwmodulesubsection{Amplitudes} *)
module C = Cascade.Make(M)(P)
type selectors = C.selectors
+ type slicings = Orders.Conditions(Colorize.It(M)).t
let external_wfs n particles =
List.map (fun (f, p) ->
({ A.flavor = f;
- A.momentum = P.singleton n p;
- A.wf_tag = A.Tags.null_wf },
+ A.momentum = P.singleton n p },
stat f p)) particles
(* \thocwmodulesubsection{Main Function} *)
- module WFMap = Map.Make (struct type t = A.wf let compare = compare end)
-
-(* [map_amplitude_wfs f a] applies the function [f : wf -> wf] to all
- wavefunctions appearing in the amplitude [a]. *)
- let map_amplitude_wfs f a =
- let map_rhs (c, wfs) = (c, PT.map f wfs) in
- let map_braket (wf, rhs) = (f wf, List.map map_rhs rhs)
- and map_fusion (lhs, rhs) = (f lhs, List.map map_rhs rhs) in
- let map_dag = A.D.map f (fun node rhs -> map_rhs rhs) in
- let tower = map_dag a.A.fusion_tower
- and dag = map_dag a.A.fusion_dag in
- let dependencies_map =
- A.D.fold (fun wf _ -> WFMap.add wf (A.D.dependencies dag wf)) dag WFMap.empty in
- { A.fusions = List.map map_fusion a.A.fusions;
- A.brakets = List.map map_braket a.A.brakets;
- A.on_shell = a.A.on_shell;
- A.is_gauss = a.A.is_gauss;
- A.constraints = a.A.constraints;
- A.incoming = a.A.incoming;
- A.outgoing = a.A.outgoing;
- A.externals = List.map f a.A.externals;
- A.symmetry = a.A.symmetry;
- A.dependencies = (fun wf -> WFMap.find wf dependencies_map);
- A.fusion_tower = tower;
- A.fusion_dag = dag }
-
-(*i
-(* \begin{dubious}
- Just a silly little test:
- \end{dubious} *)
-
- let hack_amplitude =
- map_amplitude_wfs (fun wf -> { wf with momentum = P.split 2 16 wf.momentum })
-i*)
+ module WFMap = Map.Make(WF)
(* This is the main function that constructs the amplitude for sets
of incoming and outgoing particles and returns the results in
conveniently packaged pieces. *)
let amplitude goldstones selectors fin fout =
(* Set up external lines and match flavors with numbered momenta. *)
let f = fin @ List.map M.conjugate fout in
let nin, nout = List.length fin, List.length fout in
let n = nin + nout in
let externals = List.combine f (ThoList.range 1 n) in
let wfs = external_wfs n externals in
let select_p = C.select_p selectors in
let select_wf =
match fin with
| [_] -> C.select_wf selectors P.Decay.timelike
| _ -> C.select_wf selectors P.Scattering.timelike in
let select_vtx = C.select_vtx selectors in
(* Build the full fusion tower (including nodes that are never
needed in the amplitude). *)
let stats, tower =
-
if goldstones then
complete_fusion_tower select_wf select_vtx wfs
else
minimal_fusion_tower n select_wf select_vtx wfs in
(* Find all vertices for which \emph{all} off shell wavefunctions
are defined by the tower. *)
-
let brakets =
flavor_keystones (filter_keystone stats tower) select_p n
(filter_vertices select_vtx
(vertices (min n (M.max_degree ())) (M.flavors ())))
(T.keystones (ThoList.range 1 n)) in
(* Remove the part of the DAG that is never needed in the amplitude. *)
let dag =
if goldstones then
tower
else
A.D.harvest_list tower (A.wavefunctions brakets) in
(* Remove the leaf nodes of the DAG, corresponding to external lines. *)
let fusions =
List.filter (function (_, []) -> false | _ -> true) (A.D.lists dag) in
(* Calculate the symmetry factor for identical particles in the
final state. *)
let symmetry =
Combinatorics.symmetry fout in
let dependencies_map =
A.D.fold (fun wf _ -> WFMap.add wf (A.D.dependencies dag wf)) dag WFMap.empty in
(* Finally: package the results: *)
{ A.fusions = fusions;
A.brakets = brakets;
A.on_shell = (fun wf -> C.on_shell selectors (A.flavor wf) wf.A.momentum);
A.is_gauss = (fun wf -> C.is_gauss selectors (A.flavor wf) wf.A.momentum);
A.constraints = C.description selectors;
+ A.slicings = [];
A.incoming = fin;
A.outgoing = fout;
A.externals = List.map fst wfs;
A.symmetry = symmetry;
A.dependencies = (fun wf -> WFMap.find wf dependencies_map);
A.fusion_tower = tower;
A.fusion_dag = dag }
(* \thocwmodulesubsection{Color} *)
module CM = Colorize.It(M)
- module CA = Amplitude(PT)(P)(CM)
+ module CA = Amplitude(PT)(P)(CM)(Unsliced)
let colorize_wf flavor wf =
{ CA.flavor = flavor;
- CA.momentum = wf.A.momentum;
- CA.wf_tag = wf.A.wf_tag }
+ CA.momentum = wf.A.momentum }
let uncolorize_wf wf =
{ A.flavor = CM.flavor_sans_color wf.CA.flavor;
- A.momentum = wf.CA.momentum;
- A.wf_tag = wf.CA.wf_tag }
+ A.momentum = wf.CA.momentum }
-(* \begin{dubious}
- At the end of the day, I shall want to have some sort of
- \textit{fibered DAG} as abstract data type, with a projection
- of colored nodes to their uncolored counterparts.
- \end{dubious} *)
+(* At the end of the day, I shall want to have some sort of
+ \textit{fibered DAG} as abstract data type, with a projection
+ of colored nodes to their uncolored counterparts. *)
module CWFBundle = Bundle.Make
(struct
type elt = CA.wf
let compare_elt = compare
type base = A.wf
let compare_base = compare
- let pi wf =
- { A.flavor = CM.flavor_sans_color wf.CA.flavor;
- A.momentum = wf.CA.momentum;
- A.wf_tag = wf.CA.wf_tag }
+ let pi = uncolorize_wf
end)
-(* \begin{dubious}
- For now, we can live with simple aggregation:
- \end{dubious} *)
-
+(* For now, we can live with simple aggregation: *)
type fibered_dag = { dag : CA.D.t; bundle : CWFBundle.t }
-(* Not yet(?) needed: [module CS = Stat (CM)] *)
+(* O'Caml is perfectly able to infer the types of the following
+ functions by itself, but it helps our understanding to spell
+ them out explicitely and to introduce type abbreviations. *)
+
+(* The function [f:wf_colorizer] takes a leaf wavefunction from the uncolored
+ [DAG] and a [fibered_dag] and returns a colored node together with
+ an updated bundle. *)
+
+ type wf_colorizer = A.wf -> fibered_dag -> CA.wf * CWFBundle.t
+
+(* [colorize_sterile_nodes] applies this function and adds the
+ colored wavefunction to the colored [DAG]. Below, closures build
+ from [colorize_sterile_nodes] will be passed to [A.D.fold_nodes]
+ to lay the foundation for the colorized [DAG]. *)
- let colorize_sterile_nodes dag f wf fibered_dag =
+ let colorize_sterile_nodes : A.D.t -> wf_colorizer -> A.wf -> fibered_dag -> fibered_dag =
+ fun dag f wf fibered_dag ->
if A.D.is_sterile wf dag then
let wf', wf_bundle' = f wf fibered_dag in
{ dag = CA.D.add_node wf' fibered_dag.dag;
bundle = wf_bundle' }
else
fibered_dag
- let colorize_nodes f wf rhs fibered_dag =
+(* The function [f : node_colorizer] takes a fusion from the uncolored
+ [DAG] and a [fibered_dag] and returns a list of colored
+ fusions etc.~together with an updated bundle. *)
+
+ type colored_fusion = CA.D.node * (CA.D.edge * CA.D.children)
+ type node_colorizer =
+ A.D.node -> A.D.edge * A.D.children -> fibered_dag -> colored_fusion list * CWFBundle.t
+
+(* The colored fusions are added to the colored [DAG]. Below,
+ closures build from [colorize_nodes] will be passed to [A.D.fold]
+ to complete the construction of the colorized [DAG]. *)
+
+ let colorize_nodes : node_colorizer -> A.wf -> A.rhs -> fibered_dag -> fibered_dag =
+ fun f wf rhs fibered_dag ->
let wf_rhs_list', wf_bundle' = f wf rhs fibered_dag in
let dag' =
List.fold_right
(fun (wf', rhs') -> CA.D.add_offspring wf' rhs')
wf_rhs_list' fibered_dag.dag in
{ dag = dag';
bundle = wf_bundle' }
-(* O'Caml (correctly) infers the type
- [val colorize_dag : (D.node -> D.edge * D.children -> fibered_dag ->
- (CA.D.node * (CA.D.edge * CA.D.children)) list * CWFBundle.t) ->
- (D.node -> fibered_dag -> CA.D.node * CWFBundle.t) ->
- D.t -> CWFBundle.t -> fibered_dag]. *)
+(* Build a colorized [DAG] as a [fibered_dag] from an uncolored [DAG]
+ growing the [wf_bundle]. In our applications, the initial [wf_bundle]
+ will contain the colorized external wavefunctions. *)
- let colorize_dag f_node f_ext dag wf_bundle =
+ let colorize_dag : node_colorizer -> wf_colorizer -> A.D.t -> CWFBundle.t -> fibered_dag =
+ fun f_node f_ext dag wf_bundle ->
A.D.fold (colorize_nodes f_node) dag
(A.D.fold_nodes (colorize_sterile_nodes dag f_ext) dag
{ dag = CA.D.empty; bundle = wf_bundle })
- let colorize_external wf fibered_dag =
- match CWFBundle.inv_pi wf fibered_dag.bundle with
+(* This is only a consistency check, verifying that the fiber
+ of the [fibered_dag] that projects to [wf] contains one and
+ only one element. *)
+
+ let colorize_external : wf_colorizer =
+ fun wf fibered_dag ->
+ match CWFBundle.inv_pi fibered_dag.bundle wf with
| [c_wf] -> (c_wf, fibered_dag.bundle)
| [] -> failwith "colorize_external: not found"
| _ -> failwith "colorize_external: not unique"
- let fuse_c_wf rhs =
+(* Take the wavefunctions in the [rhs] and compute all colored fusions
+ according to the colored Feynman rules. Keep only the flavors that
+ match [wf] without colors and apply the
+ [kmatrix_cuts] filter if necessary. While this ist color
+ independent, it must be done again, because [CM.fuse] will
+ reintroduce all couplings that might have been filtered out
+ before. *)
+
+ let fuse_c_wf : A.wf -> CA.wf CA.children -> (CM.flavor * CM.constant Coupling.t) list =
+ fun wf rhs ->
let momenta = PT.map (fun wf -> wf.CA.momentum) rhs in
List.filter
- (fun (_, c) -> kmatrix_cuts c momenta)
+ (fun (f, c) ->
+ CM.flavor_sans_color f = wf.A.flavor && kmatrix_cuts c momenta)
(CM.fuse (List.map (fun wf -> wf.CA.flavor) (PT.to_list rhs)))
+ let fuse_c_wf_logging wf rhs =
+ let fusion = fuse_c_wf wf rhs in
+ Printf.eprintf
+ "fuse_c_wf %s(%s) %s => %s\n"
+ (M.flavor_to_string wf.A.flavor)
+ (ThoList.to_string string_of_int (P.to_ints wf.A.momentum))
+ (ThoList.to_string
+ (fun wf ->
+ Printf.sprintf "%s(%s)"
+ (CM.flavor_to_string wf.CA.flavor)
+ (ThoList.to_string string_of_int (P.to_ints wf.CA.momentum)))
+ (PT.to_list rhs))
+ (ThoList.to_string (fun (f, _) -> CM.flavor_to_string f) fusion);
+ fusion
+
+(*i
+ let fuse_c_wf = fuse_c_wf_logging
+i*)
+
let colorize_coupling c coupling =
- { coupling with Tagged_Coupling.coupling = c }
+ { CA.sign = coupling.A.sign;
+ CA.coupling = c }
+
+(* Look up all colored versions of the [children] in the [fibered_dag]. *)
- let colorize_fusion wf (coupling, children) fibered_dag =
- let match_flavor (f, _) = (CM.flavor_sans_color f = A.flavor wf)
- and find_colored wf' = CWFBundle.inv_pi wf' fibered_dag.bundle in
+ let find_colored fibered_dag wf =
+ CWFBundle.inv_pi fibered_dag.bundle wf
+
+(* All combinations of colored versions of the [children]. *)
+
+ let colored_children_list fibered_dag children =
+ PT.product (PT.map (find_colored fibered_dag) children)
+
+(* [colorize_fusion wf rhs fibered_dag] uses all colored
+ versions of the wave functions on the [rhs] in the [fibered_dag]
+ and returns all fusions (according to [fuse_c_wf]) with matching
+ flavor together
+ with the updated [fibered_dag], including the new colored wave
+ functions. *)
+
+ let match_flavor f' (f, _) =
+ CM.flavor_sans_color f = f'
+
+ let colorize_fusion : node_colorizer =
+ fun wf (coupling, children) fibered_dag ->
+ let fuse colored_children = fuse_c_wf wf colored_children
+ and colorize colored_children (f, c) =
+ (colorize_wf f wf, (colorize_coupling c coupling, colored_children)) in
let fusions =
ThoList.flatmap
- (fun c_children ->
- List.map
- (fun (f, c) ->
- (colorize_wf f wf, (colorize_coupling c coupling, c_children)))
- (List.filter match_flavor (fuse_c_wf c_children)))
- (PT.product (PT.map find_colored children)) in
+ (fun colored_children ->
+ List.map (colorize colored_children) (fuse colored_children))
+ (colored_children_list fibered_dag children) in
let bundle =
- List.fold_right
- (fun (c_wf, _) -> CWFBundle.add c_wf)
- fusions fibered_dag.bundle in
+ List.fold_left
+ (fun acc (c_wf, _) -> CWFBundle.add acc c_wf)
+ fibered_dag.bundle fusions in
(fusions, bundle)
- let colorize_braket1 (wf, (coupling, children)) fibered_dag =
- let find_colored wf' = CWFBundle.inv_pi wf' fibered_dag.bundle in
+ (* Since each [PArray.Alist.t] has a unique representation,
+ we can write [CM.conjugate bra.CA.flavor = f] instead of
+ [CM.flavor_equal (CM.conjugate bra.CA.flavor) f] again. *)
+
+ (* Note that we must only keep the bras and kets with matching
+ colors. *)
+
+ (* \begin{dubious}
+ TODO: avoid building intermediate lists that must be factorized
+ again using the approach for coupling orders slicing below.
+ \end{dubious} *)
+
+ let colorize_braket1 fibered_dag wf (coupling, children) =
Product.fold2
(fun bra ket acc ->
+ let bra_bar = uncolorize_wf (CA.conjugate bra) in
List.fold_left
(fun brakets (f, c) ->
if CM.conjugate bra.CA.flavor = f then
(bra, (colorize_coupling c coupling, ket)) :: brakets
else
brakets)
- acc (fuse_c_wf ket))
- (find_colored wf) (PT.product (PT.map find_colored children)) []
-
- module CWFMap =
- Map.Make (struct type t = CA.wf let compare = CA.order_wf end)
+ acc (fuse_c_wf bra_bar ket))
+ (find_colored fibered_dag wf) (PT.product (PT.map (find_colored fibered_dag) children)) []
- module CKetSet =
- Set.Make (struct type t = CA.rhs let compare = compare end)
-
- (* Find a set of kets in [map] that belong to [bra].
- Return the empty set, if nothing is found. *)
-
- let lookup_ketset bra map =
- try CWFMap.find bra map with Not_found -> CKetSet.empty
-
- (* Return the set of kets belonging to [bra] in [map],
- augmented by [ket]. *)
-
- let addto_ketset bra ket map =
- CKetSet.add ket (lookup_ketset bra map)
-
- (* Augment or update [map] with a new [(bra, ket)] relation. *)
+(*i
+ if CM.conjugate bra.CA.flavor = f then
+ Printf.eprintf
+ "< %s | %s >\n"
+ (CM.flavor_to_string bra.CA.flavor)
+ (CM.flavor_to_string f);
+i*)
- let addto_ketset_map map (bra, ket) =
- CWFMap.add bra (addto_ketset bra ket map) map
+ module CWF = struct type t = CA.wf let compare = CA.order_wf end
+ module CRHS = struct type t = CA.rhs let compare = compare end
+ module CWFSet = Set.Make(CWF)
+ module CWFMap = Map.Make(CWF)
+ module CRHSMap = ThoMap.Buckets(CWF)(CRHS)
- (* Take a list of [(bra, ket)] pairs and group the [ket]s
+ (* [CRHSMap.factorize] takes a list of [(bra, ket)] pairs and groups the [ket]s
according to [bra]. This is very similar to
[ThoList.factorize] on page~\pageref{ThoList.factorize},
but the latter keeps duplicate copies, while we keep
only one, with equality determined by [CA.order_wf]. *)
- (* \begin{dubious}
- Isn't [Bundle]~\ref{Bundle} the correct framework for this?
- \end{dubious} *)
+ let colorize_braket fibered_dag (wf, rhs_list) =
+ CRHSMap.factorize_batches (List.map (colorize_braket1 fibered_dag wf) rhs_list)
- let factorize_brakets brakets =
- CWFMap.fold
- (fun bra ket acc -> (bra, CKetSet.elements ket) :: acc)
- (List.fold_left addto_ketset_map CWFMap.empty brakets)
- []
-
- let colorize_braket (wf, rhs_list) fibered_dag =
- factorize_brakets
- (ThoList.flatmap
- (fun rhs -> (colorize_braket1 (wf, rhs) fibered_dag))
- rhs_list)
+ (* [colorize_amplitude a fin fout] takes an amplitude [a] for
+ uncolored particles and colored incoming particles [fin] and
+ outgoing particles [fout] and returns the corresponding
+ colored amplitude. *)
let colorize_amplitude a fin fout =
let f = fin @ List.map CM.conjugate fout in
let nin, nout = List.length fin, List.length fout in
let n = nin + nout in
let externals = List.combine f (ThoList.range 1 n) in
let external_wfs = CA.external_wfs n externals in
let wf_bundle = CWFBundle.of_list external_wfs in
-
- let fibered_dag =
- colorize_dag
- colorize_fusion colorize_external a.A.fusion_dag wf_bundle in
-
- let brakets =
- ThoList.flatmap
- (fun braket -> colorize_braket braket fibered_dag)
- a.A.brakets in
-
+ let fibered_dag = colorize_dag colorize_fusion colorize_external a.A.fusion_dag wf_bundle in
+ let brakets = ThoList.flatmap (colorize_braket fibered_dag) a.A.brakets in
let dag = CA.D.harvest_list fibered_dag.dag (CA.wavefunctions brakets) in
-
- let fusions =
- List.filter (function (_, []) -> false | _ -> true) (CA.D.lists dag) in
-
+ let fusions = List.filter (function (_, []) -> false | _ -> true) (CA.D.lists dag) in
let dependencies_map =
- CA.D.fold
- (fun wf _ -> CWFMap.add wf (CA.D.dependencies dag wf))
- dag CWFMap.empty in
-
+ CA.D.fold (fun wf _ -> CWFMap.add wf (CA.D.dependencies dag wf)) dag CWFMap.empty in
{ CA.fusions = fusions;
CA.brakets = brakets;
CA.constraints = a.A.constraints;
+ CA.slicings = a.A.slicings;
CA.incoming = fin;
CA.outgoing = fout;
CA.externals = external_wfs;
CA.fusion_dag = dag;
CA.fusion_tower = dag;
CA.symmetry = a.A.symmetry;
CA.on_shell = (fun wf -> a.A.on_shell (uncolorize_wf wf));
CA.is_gauss = (fun wf -> a.A.is_gauss (uncolorize_wf wf));
CA.dependencies = (fun wf -> CWFMap.find wf dependencies_map) }
- let allowed amplitude =
- match amplitude.CA.brakets with
- | [] -> false
- | _ -> true
-
let colorize_amplitudes a =
List.fold_left
(fun amps (fin, fout) ->
let amp = colorize_amplitude a fin fout in
- if allowed amp then
- amp :: amps
- else
- amps)
+ match amp.CA.brakets with
+ | [] -> amps
+ | _ -> amp :: amps)
[] (CM.amplitude a.A.incoming a.A.outgoing)
- let amplitudes goldstones exclusions selectors fin fout =
+ let amplitudes_unsliced goldstones selectors fin fout =
colorize_amplitudes (amplitude goldstones selectors fin fout)
- let amplitude_sans_color goldstones exclusions selectors fin fout =
+ let amplitude_sans_color goldstones selectors fin fout =
amplitude goldstones selectors fin fout
- type flavor = CA.flavor
+(* \thocwmodulesubsection{Coupling Order Slicing} *)
+
+(* The following is structurally rather similar to the application of
+ [Colorize.It()] above. Unfortunately, there are enough differences
+ that will make a unification rather complicated. *)
+
+(* Unfortunately, the O'Caml type checker insists on
+ [Orders.Conditions(Colorize.It(M))] here and everywhere. The more
+ concise and superficially equivalent [Orders.Conditions(CM)] will
+ lead to type errors down the road, when the [Fusion.Make] functor is
+ applied. The problem appears to be that [CM] is not available in
+ the type constraints for the functors. *)
+
+(* The prefix [SC] to these and the following modules should be read as
+ ``sliced-colorized'' or ``colorized and sliced'': *)
+
+ module COC = Orders.Conditions(Colorize.It(M))
+ module SCM = Orders.Slice(Colorize.It(M))
+
+ module By_Orders =
+ struct
+ type orders = SCM.orders
+ type 'a t = (orders * 'a) list
+ let all a = [([], a)]
+ end
+
+ module SCA = Amplitude(PT)(P)(SCM)(By_Orders)
+ type 'a slices = 'a SCA.slices
+ type amplitude = SCA.t
+
+ let slice_wf flavor wf =
+ { SCA.flavor = flavor;
+ SCA.momentum = wf.CA.momentum }
+
+ let unslice_wf wf =
+ { CA.flavor = SCM.flavor_all_orders wf.SCA.flavor;
+ CA.momentum = wf.SCA.momentum }
+
+ module SCWF = struct type t = SCA.wf let compare = SCA.order_wf end
+ module SCWFSet = Set.Make(SCWF)
+
+ module SCWFBundle = Bundle.Make
+ (struct
+ type elt = SCA.wf
+ let compare_elt = compare
+ type base = CA.wf
+ let compare_base = compare
+ let pi = unslice_wf
+ end)
+
+ let allowed amplitude =
+ match amplitude.SCA.brakets with
+ | [] -> false
+ | _ -> true
+
+ type flavor = SCA.flavor
+ type flavor_all_orders = CA.flavor
type flavor_sans_color = A.flavor
type p = A.p
- type wf = CA.wf
- let conjugate = CA.conjugate
- let flavor = CA.flavor
- let flavor_sans_color wf = CM.flavor_sans_color (CA.flavor wf)
- let momentum = CA.momentum
- let momentum_list = CA.momentum_list
- let wf_tag = CA.wf_tag
-
- type coupling = CA.coupling
-
- let sign = CA.sign
- let coupling = CA.coupling
- let coupling_tag = CA.coupling_tag
- type exclusions = CA.exclusions
- let no_exclusions = CA.no_exclusions
-
- type 'a children = 'a CA.children
- type rhs = CA.rhs
- let children = CA.children
-
- type fusion = CA.fusion
- let lhs = CA.lhs
- let rhs = CA.rhs
-
- type braket = CA.braket
- let bra = CA.bra
- let ket = CA.ket
-
- type amplitude = CA.amplitude
- type amplitude_sans_color = A.amplitude
- let incoming = CA.incoming
- let outgoing = CA.outgoing
- let externals = CA.externals
- let fusions = CA.fusions
- let brakets = CA.brakets
- let symmetry = CA.symmetry
- let on_shell = CA.on_shell
- let is_gauss = CA.is_gauss
- let constraints = CA.constraints
+ type wf = SCA.wf
+ let conjugate = SCA.conjugate
+ let flavor = SCA.flavor
+ let flavor_sans_color wf = CM.flavor_sans_color (SCM.flavor_all_orders (SCA.flavor wf))
+ let momentum = SCA.momentum
+ let momentum_list = SCA.momentum_list
+
+ type coupling = SCA.coupling
+
+ let sign = SCA.sign
+ let coupling = SCA.coupling
+
+ type 'a children = 'a SCA.children
+ type rhs = SCA.rhs
+ let children = SCA.children
+
+ type fusion = SCA.fusion
+ let lhs = SCA.lhs
+ let rhs = SCA.rhs
+
+ type braket = SCA.braket
+ let bra = SCA.bra
+ let ket = SCA.ket
+
+ type amplitude_sans_color = A.t
+
+(* \thocwmodulesubsection{Accessor Functions} *)
+
+ let incoming = SCA.incoming
+ let outgoing = SCA.outgoing
+ let externals = SCA.externals
+ let fusions = SCA.fusions
+ let brakets = SCA.brakets
+ let symmetry = SCA.symmetry
+ let on_shell = SCA.on_shell
+ let is_gauss = SCA.is_gauss
+ let constraints = SCA.constraints
+ let slicings = SCA.slicings
let variables a = List.map lhs (fusions a)
- let dependencies = CA.dependencies
+ let dependencies = SCA.dependencies
+
+
+ let flavor_all_orders wf = SCM.flavor_all_orders (SCA.flavor wf)
+
+ type sliced_fibered_dag =
+ { sliced_dag : SCA.D.t; sliced_bundle : SCWFBundle.t }
+
+ type wf_slicer = CA.wf -> sliced_fibered_dag -> SCA.wf * SCWFBundle.t
+
+ let slice_sterile_nodes : CA.D.t -> wf_slicer -> CA.D.node -> sliced_fibered_dag -> sliced_fibered_dag =
+ fun dag f wf fibered_dag ->
+ if CA.D.is_sterile wf dag then
+ let wf', wf_bundle' = f wf fibered_dag in
+ { sliced_dag = SCA.D.add_node wf' fibered_dag.sliced_dag;
+ sliced_bundle = wf_bundle' }
+ else
+ fibered_dag
+
+ type sliced_fusion = SCA.wf * SCA.rhs
+ type node_slicer = CA.wf -> CA.rhs -> sliced_fibered_dag -> sliced_fusion list * SCWFBundle.t
+
+ let slice_nodes : node_slicer -> CA.wf -> CA.rhs -> sliced_fibered_dag -> sliced_fibered_dag =
+ fun f wf rhs fibered_dag ->
+ let wf_rhs_list', wf_bundle' = f wf rhs fibered_dag in
+ let dag' =
+ List.fold_right
+ (fun (wf', rhs') -> SCA.D.add_offspring wf' rhs')
+ wf_rhs_list' fibered_dag.sliced_dag in
+ { sliced_dag = dag';
+ sliced_bundle = wf_bundle' }
+
+ let slice_dag : node_slicer -> wf_slicer -> CA.D.t -> SCWFBundle.t -> sliced_fibered_dag =
+ fun f_node f_ext dag wf_bundle ->
+ CA.D.fold (slice_nodes f_node) dag
+ (CA.D.fold_nodes (slice_sterile_nodes dag f_ext) dag
+ { sliced_dag = SCA.D.empty; sliced_bundle = wf_bundle })
+
+ let slice_external : wf_slicer =
+ fun wf fibered_dag ->
+ match SCWFBundle.inv_pi fibered_dag.sliced_bundle wf with
+ | [c_wf] -> (c_wf, fibered_dag.sliced_bundle)
+ | [] -> failwith "slice_external: not found"
+ | _ -> failwith "slice_external: not unique"
+
+ let coupling_orders = function
+ | Coupling.V3 (_, _, c) | Coupling.V4 (_, _, c) | Coupling.Vn (_, _, c) ->
+ CM.coupling_orders c
+
+ let coupling_orders_to_string co =
+ "{" ^
+ String.concat ","
+ (List.map (fun (o, n) -> CM.coupling_order_to_string o ^ ":" ^ string_of_int n) co) ^ "}"
+
+ (* \begin{dubious}
+ Ideally, one would want to test for the allowed coupling constants with [COC.constant]
+ early inside of [SCM.fuse]. However, this requires a more general signature
+ than [fuse] in [Model.T]. Let's see if this is worth the effort.
+ \end{dubious} *)
+
+ let fuse_s_wf : COC.t -> CA.wf -> SCA.wf SCA.children -> (SCM.flavor * SCM.constant Coupling.t) list =
+ fun slicings wf rhs ->
+ let momenta = PT.map (fun wf -> wf.SCA.momentum) rhs in
+ List.filter
+ (fun (f, c) ->
+ SCM.flavor_all_orders f = wf.CA.flavor
+ && COC.constant slicings (coupling_orders c)
+ && COC.fusion slicings (SCM.orders f)
+ && kmatrix_cuts c momenta)
+ (SCM.fuse (List.map (fun wf -> wf.SCA.flavor) (PT.to_list rhs)))
+
+ let slice_coupling c coupling =
+ { SCA.sign = coupling.CA.sign;
+ SCA.coupling = c }
+
+(* Look up all versions of the [children] in the [fibered_dag]. *)
+
+ let find_sliced fibered_dag wf =
+ SCWFBundle.inv_pi fibered_dag.sliced_bundle wf
+
+(* All combinations of the [children] with different coupling orders. *)
+
+ let sliced_children_list fibered_dag children =
+ PT.product (PT.map (find_sliced fibered_dag) children)
+
+ let slice_fusion : COC.t -> node_slicer =
+ fun slicings wf (coupling, children) fibered_dag ->
+ let fuse sliced_children = fuse_s_wf slicings wf sliced_children
+ and slice sliced_children (f, c) =
+ (slice_wf f wf, (slice_coupling c coupling, sliced_children)) in
+ let fusions =
+ ThoList.flatmap
+ (fun sliced_children ->
+ List.map (slice sliced_children) (fuse sliced_children))
+ (sliced_children_list fibered_dag children) in
+ let bundle =
+ List.fold_left
+ (fun acc (s_wf, _) -> SCWFBundle.add acc s_wf)
+ fibered_dag.sliced_bundle fusions in
+ (fusions, bundle)
+
+ (* When producing all combinations of coupling orders, bras and kets,
+ we need to group them by common coupling orders and by common bras.
+ This is most straightforwardly (and asymptotically efficiently) done
+ by constructing a map from coupling orders to maps from bras to sets
+ of kets. *)
+
+ (* For this we need to order the sets of coupling orders, bras
+ (wave functions) and kets (right hand sides) *)
+ module CO = struct type t = SCM.orders let compare = compare end
+ module SCBra = struct type t = SCA.wf let compare = SCA.order_wf end
+ module SCKet = struct type t = SCA.rhs let compare = compare end
+
+ (* in order to define maps from coupling orders and from bras *)
+ module COMap = Map.Make(CO)
+ module SCBraMap = Map.Make(SCBra)
+
+ (* as well a buckets for kets, indexed by bras: *)
+ module SCKetBuckets = ThoMap.Buckets(SCBra)(SCKet)
+ type comap = SCKetBuckets.t COMap.t
+
+ let comap_to_lists : comap -> (SCM.orders * SCA.braket list) list =
+ fun comap ->
+ List.rev (COMap.fold (fun orders brakets acc -> (orders, SCKetBuckets.to_lists brakets) :: acc) comap [])
+
+ (* Add [ket] to the set indexed by [bra] in the map from bras to sets of kets
+ indexed by [orders] in [omap]. Initialize the inner map if it doesn't exist yet. *)
+ let addto_orders_map : comap -> SCM.orders -> SCA.wf -> SCA.rhs -> comap =
+ fun omap orders bra ket ->
+ let bra_ket_map =
+ match COMap.find_opt orders omap with
+ | None -> SCKetBuckets.empty
+ | Some bkmap -> bkmap in
+ COMap.add orders (SCKetBuckets.add bra ket bra_ket_map) omap
+
+ let _find_sliced fibered_dag wf =
+ let wf_list = find_sliced fibered_dag wf in
+ Printf.eprintf "find_sliced %s -> %s\n"
+ (CM.flavor_to_string (CA.flavor wf))
+ (ThoList.to_string
+ (fun wf -> SCM.flavor_to_string (SCA.flavor wf))
+ wf_list);
+ wf_list
+
+ (* Take a left hand side and a right hand side, construct all allowed
+ combinations of coupling orders and add them to our collection. *)
+(*i
+ let to_string ol =
+ ThoList.to_string (fun (co, n) -> SCM.coupling_order_to_string co ^ ":" ^ string_of_int n) ol
+i*)
+ let slice_braket1 : COC.t -> sliced_fibered_dag -> CA.wf -> CA.rhs -> comap -> comap =
+ fun conditions fibered_dag wf (coupling, children) comap ->
+ Product.fold2
+ (fun bra children comap ->
+ let bra_bar = unslice_wf (SCA.conjugate bra) in
+ List.fold_left
+ (fun comap (f, c) ->
+ let orders = SCM.add_orders (SCM.orders bra.SCA.flavor) (SCM.orders f) in
+ match COC.braket conditions orders with
+ | Some orders -> addto_orders_map comap orders bra (slice_coupling c coupling, children)
+ | None -> comap)
+ comap (fuse_s_wf conditions bra_bar children))
+ (find_sliced fibered_dag wf) (PT.product (PT.map (find_sliced fibered_dag) children)) comap
+
+ let slice_braket : COC.t -> sliced_fibered_dag -> CA.braket -> comap -> comap =
+ fun slicings fibered_dag (wf, rhs_list) comap ->
+ List.fold_right (slice_braket1 slicings fibered_dag wf) rhs_list comap
+
+ let slice_brakets : COC.t -> sliced_fibered_dag -> CA.braket list -> (SCM.orders * SCA.braket list) list =
+ fun slicings fibered_dag brakets ->
+ comap_to_lists (List.fold_right (slice_braket slicings fibered_dag) brakets COMap.empty)
+
+ let slice_amplitude slicings a =
+ let trivial = List.map (fun co -> (co, 0)) (COC.exclusive_fusion slicings) in
+ let fin, fout = SCM.amplitude trivial a.CA.incoming a.CA.outgoing in
+ let f = fin @ List.map SCM.conjugate fout in
+ let nin, nout = List.length fin, List.length fout in
+ let n = nin + nout in
+ let externals = List.combine f (ThoList.range 1 n) in
+ let external_wfs = SCA.external_wfs n externals in
+ let wf_bundle = SCWFBundle.of_list external_wfs in
+ let fibered_dag = slice_dag (slice_fusion slicings) slice_external a.CA.fusion_dag wf_bundle in
+ let sliced_brakets = slice_brakets slicings fibered_dag a.CA.brakets in
+ let brakets = ThoList.flatmap snd sliced_brakets in
+ let dag = SCA.D.harvest_list fibered_dag.sliced_dag (SCA.wavefunctions brakets) in
+ let fusions = List.filter (function (_, []) -> false | _ -> true) (SCA.D.lists dag) in
+ let dependencies_map =
+ SCA.D.fold (fun wf _ -> SCBraMap.add wf (SCA.D.dependencies dag wf)) dag SCBraMap.empty in
+ { SCA.fusions = fusions;
+ SCA.brakets = sliced_brakets;
+ SCA.constraints = a.CA.constraints;
+ SCA.slicings = COC.to_strings slicings;
+ SCA.incoming = fin;
+ SCA.outgoing = fout;
+ SCA.externals = external_wfs;
+ SCA.fusion_dag = dag;
+ SCA.fusion_tower = dag;
+ SCA.symmetry = a.CA.symmetry;
+ SCA.on_shell = (fun wf -> a.CA.on_shell (unslice_wf wf));
+ SCA.is_gauss = (fun wf -> a.CA.is_gauss (unslice_wf wf));
+ SCA.dependencies = (fun wf -> SCBraMap.find wf dependencies_map) }
+
+ let slice_amplitudes slicings amplitudes =
+ List.map (slice_amplitude slicings) amplitudes
+
+ (* For the benefit of [Targets], we also copy the amplitudes to
+ equivalent sliced amplitudes with empty coupling orders. This
+ way, we can use the same output routines for the sliced and
+ unsliced amplitudes. *)
+
+ (* [lift_amplitude] is equivalent to [slice_amplitude Orders.Condition.trivial],
+ but it can shortcut [SCM.fuse], since all fusions and brakets are known. *)
+
+ let lift_wf wf =
+ slice_wf (SCM.trivial wf.CA.flavor) wf
+
+ let lift_coupling coupling =
+ { SCA.sign = coupling.CA.sign;
+ SCA.coupling = coupling.CA.coupling }
+
+ let lift_external : wf_slicer =
+ fun wf fibered_dag ->
+ (lift_wf wf, fibered_dag.sliced_bundle)
+
+ let lift_fusion : node_slicer =
+ fun wf (coupling, children) fibered_dag ->
+ let wf = lift_wf wf
+ and coupling = lift_coupling coupling
+ and children = PT.map lift_wf children in
+ let sliced_bundle = SCWFBundle.add fibered_dag.sliced_bundle wf in
+ ( [ (wf, (coupling, children)) ], sliced_bundle )
+
+ let lift_dag : CA.D.t -> SCWFBundle.t -> sliced_fibered_dag =
+ fun dag wf_bundle ->
+ slice_dag lift_fusion lift_external dag wf_bundle
+
+ let lift_braket : CA.braket -> SCA.braket =
+ fun (wf, rhs) ->
+ let wf = lift_wf wf
+ and rhs =
+ List.map
+ (fun (coupling, children) -> (lift_coupling coupling, PT.map lift_wf children))
+ rhs in
+ (wf, rhs)
+
+ let lift_amplitude a =
+ let fin = List.map SCM.trivial a.CA.incoming
+ and fout = List.map SCM.trivial a.CA.outgoing in
+ let f = fin @ List.map SCM.conjugate fout in
+ let nin, nout = List.length fin, List.length fout in
+ let n = nin + nout in
+ let externals = List.combine f (ThoList.range 1 n) in
+ let external_wfs = SCA.external_wfs n externals in
+ let wf_bundle = SCWFBundle.of_list external_wfs in
+ let fibered_dag = lift_dag a.CA.fusion_dag wf_bundle in
+ let brakets = List.map lift_braket a.CA.brakets in
+ let dag = SCA.D.harvest_list fibered_dag.sliced_dag (SCA.wavefunctions brakets) in
+ let fusions = List.filter (function (_, []) -> false | _ -> true) (SCA.D.lists dag) in
+ let dependencies_map =
+ SCA.D.fold (fun wf _ -> SCBraMap.add wf (SCA.D.dependencies dag wf)) dag SCBraMap.empty in
+ { SCA.fusions = fusions;
+ SCA.brakets = SCA.unsliced brakets;
+ SCA.constraints = a.CA.constraints;
+ SCA.slicings = [];
+ SCA.incoming = fin;
+ SCA.outgoing = fout;
+ SCA.externals = external_wfs;
+ SCA.fusion_dag = dag;
+ SCA.fusion_tower = dag;
+ SCA.symmetry = a.CA.symmetry;
+ SCA.on_shell = (fun wf -> a.CA.on_shell (unslice_wf wf));
+ SCA.is_gauss = (fun wf -> a.CA.is_gauss (unslice_wf wf));
+ SCA.dependencies = (fun wf -> SCBraMap.find wf dependencies_map) }
+
+ let lift_amplitudes amplitudes =
+ List.map lift_amplitude amplitudes
+
+ let amplitudes goldstones selectors slicings fin fout =
+ let a = amplitudes_unsliced goldstones selectors fin fout in
+ match slicings with
+ | None -> lift_amplitudes a
+ | Some slicings -> slice_amplitudes slicings a
+
+ let amplitudes_all_orders goldstones selectors fin fout =
+ lift_amplitudes (amplitudes_unsliced goldstones selectors fin fout)
+
+ let children_to_string children =
+ "(" ^
+ String.concat "*"
+ (List.map (fun wf -> SCM.flavor_to_string (SCA.flavor wf)) children) ^ ")"
+
+ let dump_sliced_amplitudes slicings sliced =
+ List.iter
+ (fun amplitude ->
+ Printf.eprintf "amplitude %s -> %s\n"
+ (String.concat " " (List.map SCM.flavor_to_string amplitude.SCA.incoming))
+ (String.concat " " (List.map SCM.flavor_to_string amplitude.SCA.outgoing));
+ List.iter
+ (fun (orders, brakets) ->
+ Printf.eprintf " order %s\n" (coupling_orders_to_string orders);
+ List.iter
+ (fun braket ->
+ Printf.eprintf
+ " braket (%s, [%s])\n"
+ (SCM.flavor_to_string (SCA.flavor (SCA.bra braket)))
+ (String.concat ";"
+ (List.map
+ (fun ket ->
+ coupling_orders_to_string (coupling_orders (SCA.coupling ket)) ^
+ children_to_string (SCA.children ket))
+ (SCA.ket braket))))
+ brakets)
+ amplitude.brakets)
+ sliced
+
+(*i
+ let amplitudes goldstones exclusions selectors slicings fin fout =
+ let a = amplitudes goldstones exclusions selectors None fin fout in
+ match slicings with
+ | None -> a
+ | Some slicings ->
+ dump_sliced_amplitudes (lift_amplitudes a);
+ begin match COC.to_strings slicings with
+ | [] -> ()
+ | slicings ->
+ Printf.eprintf "!!!!!!!!!!!!!!!!!!!!!!!!!!\n";
+ Printf.eprintf "! coupling orders selected\n";
+ List.iter (Printf.eprintf "! %s\n") slicings;
+ Printf.eprintf "!!!!!!!!!!!!!!!!!!!!!!!!!!\n"
+ end;
+ let sliced = slice_amplitudes slicings a in
+ dump_sliced_amplitudes sliced;
+ a
+i*)
+
+ let _amplitudes goldstones selectors slicings fin fout =
+ let a = amplitudes goldstones selectors slicings fin fout in
+ match slicings with
+ | None -> a
+ | Some slicings ->
+ dump_sliced_amplitudes slicings a;
+ begin match COC.to_strings slicings with
+ | [] -> ()
+ | slicings ->
+ Printf.eprintf "!!!!!!!!!!!!!!!!!!!!!!!!!!\n";
+ Printf.eprintf "! coupling orders selected\n";
+ List.iter (Printf.eprintf "! %s\n") slicings;
+ Printf.eprintf "!!!!!!!!!!!!!!!!!!!!!!!!!!\n"
+ end;
+ a
(* \thocwmodulesubsection{Checking Conservation Laws} *)
let check_charges () =
let vlist3, vlist4, vlistn = M.vertices () in
List.filter
(fun flist -> not (M.Ch.is_null (M.Ch.sum (List.map M.charges flist))))
(List.map (fun ((f1, f2, f3), _, _) -> [f1; f2; f3]) vlist3
@ List.map (fun ((f1, f2, f3, f4), _, _) -> [f1; f2; f3; f4]) vlist4
@ List.map (fun (flist, _, _) -> flist) vlistn)
(* \thocwmodulesubsection{Diagnostics} *)
+ let all_brakets a =
+ ThoList.flatmap snd a.SCA.brakets
+
let count_propagators a =
- List.length a.CA.fusions
+ List.length a.SCA.fusions
let count_fusions a =
- List.fold_left (fun n (_, a) -> n + List.length a) 0 a.CA.fusions
- + List.fold_left (fun n (_, t) -> n + List.length t) 0 a.CA.brakets
- + List.length a.CA.brakets
+ let brakets = all_brakets a in
+ List.fold_left (fun n (_, a) -> n + List.length a) 0 a.SCA.fusions
+ + List.fold_left (fun n (_, t) -> n + List.length t) 0 brakets
+ + List.length brakets
(* \begin{dubious}
This brute force approach blows up for more than ten particles.
Find a smarter algorithm.
\end{dubious} *)
let count_diagrams a =
List.fold_left (fun n (wf1, wf23) ->
- n + CA.D.count_trees wf1 a.CA.fusion_dag *
+ n + SCA.D.count_trees wf1 a.SCA.fusion_dag *
(List.fold_left (fun n' (_, wfs) ->
n' + PT.fold_left (fun n'' wf ->
- n'' * CA.D.count_trees wf a.CA.fusion_dag) 1 wfs) 0 wf23))
- 0 a.CA.brakets
+ n'' * SCA.D.count_trees wf a.SCA.fusion_dag) 1 wfs) 0 wf23))
+ 0 (all_brakets a)
exception Impossible
let forest' a =
- let below wf = CA.D.forest_memoized wf a.CA.fusion_dag in
+ let below wf = SCA.D.forest_memoized wf a.SCA.fusion_dag in
ThoList.flatmap
(fun (bra, ket) ->
(Product.list2 (fun bra' ket' -> bra' :: ket')
(below bra)
(ThoList.flatmap
(fun (_, wfs) ->
Product.list (fun w -> w) (PT.to_list (PT.map below wfs)))
ket)))
- a.CA.brakets
+ (all_brakets a)
let cross wf =
- { CA.flavor = CM.conjugate wf.CA.flavor;
- CA.momentum = P.neg wf.CA.momentum;
- CA.wf_tag = wf.CA.wf_tag }
+ { SCA.flavor = SCM.conjugate wf.SCA.flavor;
+ SCA.momentum = P.neg wf.SCA.momentum }
let fuse_trees wf ts =
Tree.fuse (fun (wf', e) -> (cross wf', e))
wf (fun t -> List.mem wf (Tree.leafs t)) ts
let forest wf a =
List.map (fuse_trees wf) (forest' a)
(*i
(* \begin{dubious}
The following duplication should be replaced by polymorphism
or a functor.
\end{dubious} *)
let forest_uncolored' a =
let below wf = A.D.forest_memoized wf a.A.fusion_dag in
ThoList.flatmap
(fun (bra, ket) ->
(Product.list2 (fun bra' ket' -> bra' :: ket')
(below bra)
(ThoList.flatmap
(fun (_, wfs) ->
Product.list (fun w -> w) (PT.to_list (PT.map below wfs)))
ket)))
a.A.brakets
let cross_uncolored wf =
{ A.flavor = M.conjugate wf.A.flavor;
- A.momentum = P.neg wf.A.momentum;
- A.wf_tag = wf.A.wf_tag }
+ A.momentum = P.neg wf.A.momentum }
let fuse_trees_uncolored wf ts =
Tree.fuse (fun (wf', e) -> (cross_uncolored wf', e))
wf (fun t -> List.mem wf (Tree.leafs t)) ts
let forest_sans_color wf a =
List.map (fuse_trees_uncolored wf) (forest_uncolored' a)
i*)
+(* \begin{dubious}
+ There's a lot of redundancy here. This is not harmful, but very
+ confusing and should be cleaned up.
+ \end{dubious} *)
+
let poles_beneath wf dag =
- CA.D.eval_memoized (fun wf' -> [[]])
+ SCA.D.eval_memoized (fun wf' -> [[]])
(fun wf' _ p -> List.map (fun p' -> wf' :: p') p)
(fun wf1 wf2 ->
Product.fold2 (fun wf' wfs' wfs'' -> (wf' @ wfs') :: wfs'') wf1 wf2 [])
(@) [[]] [[]] wf dag
let poles a =
ThoList.flatmap (fun (wf1, wf23) ->
- let poles_wf1 = poles_beneath wf1 a.CA.fusion_dag in
+ let poles_wf1 = poles_beneath wf1 a.SCA.fusion_dag in
(ThoList.flatmap (fun (_, wfs) ->
Product.list List.flatten
(PT.to_list (PT.map (fun wf ->
- poles_wf1 @ poles_beneath wf a.CA.fusion_dag) wfs)))
+ poles_wf1 @ poles_beneath wf a.SCA.fusion_dag) wfs)))
wf23))
- a.CA.brakets
-
- module WFSet =
- Set.Make (struct type t = CA.wf let compare = CA.order_wf end)
+ (all_brakets a)
let s_channel a =
- WFSet.elements
+ SCWFSet.elements
(ThoList.fold_right2
(fun wf wfs ->
- if P.Scattering.timelike wf.CA.momentum then
- WFSet.add wf wfs
+ if P.Scattering.timelike wf.SCA.momentum then
+ SCWFSet.add wf wfs
else
- wfs) (poles a) WFSet.empty)
+ wfs) (poles a) SCWFSet.empty)
(* \begin{dubious}
This should be much faster! Is it correct? Is it faster indeed?
\end{dubious} *)
let poles' a =
- List.map CA.lhs a.CA.fusions
+ List.map SCA.lhs a.SCA.fusions
let s_channel a =
- WFSet.elements
+ SCWFSet.elements
(List.fold_right
(fun wf wfs ->
- if P.Scattering.timelike wf.CA.momentum then
- WFSet.add wf wfs
+ if P.Scattering.timelike wf.SCA.momentum then
+ SCWFSet.add wf wfs
else
- wfs) (poles' a) WFSet.empty)
+ wfs) (poles' a) SCWFSet.empty)
(* \thocwmodulesubsection{Pictures} *)
(* Export the DAG in the \texttt{dot(1)} file format so that we can
draw pretty pictures to impress audiences \ldots *)
let p2s p =
if p >= 0 && p <= 9 then
string_of_int p
else if p <= 36 then
String.make 1 (Char.chr (Char.code 'A' + p - 10))
else
"_"
let variable wf =
- CM.flavor_symbol wf.CA.flavor ^
- String.concat "" (List.map p2s (P.to_ints wf.CA.momentum))
-
- module Int = Map.Make (struct type t = int let compare = compare end)
+ SCM.flavor_symbol wf.SCA.flavor ^
+ "_p" ^ String.concat "" (List.map p2s (P.to_ints wf.SCA.momentum))
let add_to_list i n m =
- Int.add i (n :: try Int.find i m with Not_found -> []) m
+ IMap.add i (n :: try IMap.find i m with Not_found -> []) m
let classify_nodes dag =
- Int.fold (fun i n acc -> (i, n) :: acc)
- (CA.D.fold_nodes (fun wf -> add_to_list (P.rank wf.CA.momentum) wf)
- dag Int.empty) []
+ IMap.fold (fun i n acc -> (i, n) :: acc)
+ (SCA.D.fold_nodes (fun wf -> add_to_list (P.rank wf.SCA.momentum) wf)
+ dag IMap.empty) []
let dag_to_dot ch brakets dag =
Printf.fprintf ch "digraph OMEGA {\n";
- CA.D.iter_nodes (fun wf ->
+ SCA.D.iter_nodes (fun wf ->
Printf.fprintf ch " \"%s\" [ label = \"%s\" ];\n"
(variable wf) (variable wf)) dag;
List.iter (fun (_, wfs) ->
Printf.fprintf ch " { rank = same;";
List.iter (fun n ->
Printf.fprintf ch " \"%s\";" (variable n)) wfs;
Printf.fprintf ch " };\n") (classify_nodes dag);
List.iter (fun n ->
Printf.fprintf ch " \"*\" -> \"%s\";\n" (variable n))
(flatten_keystones brakets);
- CA.D.iter (fun n (_, ns) ->
+ SCA.D.iter (fun n (_, ns) ->
let p = variable n in
PT.iter (fun n' ->
Printf.fprintf ch " \"%s\" -> \"%s\";\n" p (variable n')) ns) dag;
Printf.fprintf ch "}\n"
let tower_to_dot ch a =
- dag_to_dot ch a.CA.brakets a.CA.fusion_tower
+ dag_to_dot ch (all_brakets a) a.SCA.fusion_tower
let amplitude_to_dot ch a =
- dag_to_dot ch a.CA.brakets a.CA.fusion_dag
+ dag_to_dot ch (all_brakets a) a.SCA.fusion_dag
(* \thocwmodulesubsection{Phasespace} *)
let variable wf =
M.flavor_to_string wf.A.flavor ^
"[" ^ String.concat "/" (List.map p2s (P.to_ints wf.A.momentum)) ^ "]"
let below_to_channel transform ch dag wf =
let n2s wf = variable (transform wf)
and e2s c = "" in
Tree2.to_channel ch n2s e2s (A.D.dependencies dag wf)
let bra_to_channel transform ch dag wf =
let tree = A.D.dependencies dag wf in
if Tree2.is_singleton tree then
let n2s wf = variable (transform wf)
and e2s c = "" in
Tree2.to_channel ch n2s e2s tree
else
failwith "Fusion.phase_space_channels: wrong topology!"
let ket_to_channel transform ch dag ket =
Printf.fprintf ch "(";
begin match A.children ket with
| [] -> ()
| [child] -> below_to_channel transform ch dag child
| child :: children ->
below_to_channel transform ch dag child;
List.iter
(fun child ->
Printf.fprintf ch ",";
below_to_channel transform ch dag child)
children
end;
Printf.fprintf ch ")"
let phase_space_braket transform ch (bra, ket) dag =
bra_to_channel transform ch dag bra;
Printf.fprintf ch ": {";
begin match ket with
| [] -> ()
| [ket1] ->
Printf.fprintf ch " ";
ket_to_channel transform ch dag ket1
| ket1 :: kets ->
Printf.fprintf ch " ";
ket_to_channel transform ch dag ket1;
List.iter
(fun k ->
Printf.fprintf ch " \\\n | ";
ket_to_channel transform ch dag k)
kets
end;
Printf.fprintf ch " }\n"
(*i Food for thought:
let braket_to_tree2 dag (bra, ket) =
let bra' = A.D.dependencies dag bra in
if Tree2.is_singleton bra' then
Tree2.cons
[(fst ket, bra, List.map (A.D.dependencies dag) (A.children ket))]
else
failwith "Fusion.phase_space_channels: wrong topology!"
let phase_space_braket transform ch (bra, ket) dag =
let n2s wf = variable (transform wf)
and e2s c = "" in
Printf.fprintf
ch "%s\n" (Tree2.to_string n2s e2s (braket_to_tree2 dag (bra, ket)))
i*)
let phase_space_channels_transformed transform ch a =
List.iter
(fun braket -> phase_space_braket transform ch braket a.A.fusion_dag)
a.A.brakets
let phase_space_channels ch a =
phase_space_channels_transformed (fun wf -> wf) ch a
let exchange_momenta_list p1 p2 p =
List.map
(fun pi ->
if pi = p1 then
p2
else if pi = p2 then
p1
else
pi)
p
let exchange_momenta p1 p2 p =
P.of_ints (P.dim p) (exchange_momenta_list p1 p2 (P.to_ints p))
let flip_momenta wf =
{ wf with A.momentum = exchange_momenta 1 2 wf.A.momentum }
let phase_space_channels_flipped ch a =
phase_space_channels_transformed flip_momenta ch a
end
-module Make = Tagged(No_Tags)
-
module Binary = Make(Tuple.Binary)(Stat_Dirac)(Topology.Binary)
-module Tagged_Binary (T : Tagger) =
- Tagged(T)(Tuple.Binary)(Stat_Dirac)(Topology.Binary)
(* \thocwmodulesection{Fusions with Majorana Fermions} *)
let majorana_log silent logging = logging
let majorana_log silent logging = silent
let force_legacy = true
let force_legacy = false
module Stat_Majorana (M : Model.T) : (Stat with type flavor = M.flavor) =
struct
exception Impossible
type flavor = M.flavor
(* \thocwmodulesubsection{Keeping Track of Fermion Lines} *)
(* JRR's algorithm doesn't use lists of pairs representing
directed arrows as in [Stat_Dirac().stat] above, but a list
of integers denoting the external leg a fermion line connects
to: *)
type stat =
| Fermion of int * int list
| AntiFermion of int * int list
| Boson of int list
| Majorana of int * int list
let sign_of_permutation lines = fst (Combinatorics.sort_signed lines)
let lines_equivalent l1 l2 =
sign_of_permutation l1 = sign_of_permutation l2
let stat_to_string s =
let open Printf in
let l2s = ThoList.to_string string_of_int in
match s with
| Boson lines -> sprintf "B%s" (l2s lines)
| Fermion (p, lines) -> sprintf "F(%d, %s)" p (l2s lines)
| AntiFermion (p, lines) -> sprintf "A(%d, %s)" p (l2s lines)
| Majorana (p, lines) -> sprintf "M(%d, %s)" p (l2s lines)
(* Writing all cases explicitely is tedious, but allows exhaustiveness
checking. *)
let equal s1 s2 =
match s1, s2 with
| Boson l1, Boson l2 ->
lines_equivalent l1 l2
| Majorana (p1, l1), Majorana (p2, l2)
| Fermion (p1, l1), Fermion (p2, l2)
| AntiFermion (p1, l1), AntiFermion (p2, l2) ->
p1 = p2 && lines_equivalent l1 l2
| Boson _, (Fermion _ | AntiFermion _ | Majorana _ )
| (Fermion _ | AntiFermion _ | Majorana _ ), Boson _
| Majorana _, (Fermion _ | AntiFermion _)
| (Fermion _ | AntiFermion _), Majorana _
| Fermion _ , AntiFermion _
| AntiFermion _ , Fermion _ -> false
(* The final amplitude must not be fermionic! *)
let saturated = function
| Boson _ -> true
| Fermion _ | AntiFermion _ | Majorana _ -> false
(* [stat f p] interprets the numeric fermion numbers of flavor [f]
at external leg [p] at creates a leaf: *)
let stat f p =
match M.fermion f with
| 0 -> Boson []
| 1 -> Fermion (p, [])
| -1 -> AntiFermion (p, [])
| 2 -> Majorana (p, [])
| _ -> invalid_arg "Fusion.Stat_Majorana: invalid fermion number"
(* The formalism of~\cite{Denner:Majorana} does not distinguish
spinors from conjugate spinors, it is only important to know in which direction
a fermion line is calculated. So the sign is made by the calculation together
with an aditional one due to the permuation of the pairs of endpoints of
fermion lines in the direction they are calculated. We propose a
``canonical'' direction from the right to the left child at a fusion point
so we only have to keep in mind which external particle hangs at each side.
Therefore we need not to have a list of pairs of conjugate spinors and
spinors but just a list in which the pairs are right-left-right-left
and so on. Unfortunately it is unavoidable to have couplings with clashing
arrows in supersymmetric theories so we need transmutations from fermions
in antifermions and vice versa as well. *)
(* \thocwmodulesubsection{Merge Fermion Lines for Legacy Models with Implied Fermion Connections} *)
(* In the legacy case with at most one fermion line, it was straight
forward to determine the kind of outgoing line from the
corresponding flavor. In the general case, it is not
possible to maintain this constraint, when constructing
the $n$-ary fusion from binary ones. *)
(* We can break up the process into two steps however:
first perform unconstrained fusions pairwise \ldots *)
let stat_fuse_pair_unconstrained s1 s2 =
match s1, s2 with
| Boson l1, Boson l2 -> Boson (l1 @ l2)
| (Majorana (p1, l1) | Fermion (p1, l1) | AntiFermion (p1, l1)),
(Majorana (p2, l2) | Fermion (p2, l2) | AntiFermion (p2, l2)) ->
Boson ([p2; p1] @ l1 @ l2)
| Boson l1, Majorana (p, l2) -> Majorana (p, l1 @ l2)
| Boson l1, Fermion (p, l2) -> Fermion (p, l1 @ l2)
| Boson l1, AntiFermion (p, l2) -> AntiFermion (p, l1 @ l2)
| Majorana (p, l1), Boson l2 -> Majorana (p, l1 @ l2)
| Fermion (p, l1), Boson l2 -> Fermion (p, l1 @ l2)
| AntiFermion (p, l1), Boson l2 -> AntiFermion (p, l1 @ l2)
(* \ldots{} and only apply the constraint to the outgoing leg. *)
let constrain_stat_fusion s f =
match s, M.lorentz f with
| (Majorana (p, l) | Fermion (p, l) | AntiFermion (p, l)),
(Coupling.Majorana | Coupling.Vectorspinor | Coupling.Maj_Ghost) ->
Majorana (p, l)
| (Majorana (p, l) | Fermion (p, l) | AntiFermion (p, l)),
Coupling.Spinor -> Fermion (p, l)
| (Majorana (p, l) | Fermion (p, l) | AntiFermion (p, l)),
Coupling.ConjSpinor -> AntiFermion (p, l)
| (Majorana _ | Fermion _ | AntiFermion _ as s),
(Coupling.Scalar | Coupling.Vector | Coupling.Massive_Vector
| Coupling.Tensor_1 | Coupling.Tensor_2 | Coupling.BRS _) ->
invalid_arg
(Printf.sprintf
"Fusion.stat_fuse_pair_constrained: expected boson, got %s"
(stat_to_string s))
| Boson l as s,
(Coupling.Majorana | Coupling.Vectorspinor | Coupling.Maj_Ghost
| Coupling.Spinor | Coupling.ConjSpinor) ->
invalid_arg
(Printf.sprintf
"Fusion.stat_fuse_pair_constrained: expected fermion, got %s"
(stat_to_string s))
| Boson l,
(Coupling.Scalar | Coupling.Vector | Coupling.Massive_Vector
| Coupling.Tensor_1 | Coupling.Tensor_2 | Coupling.BRS _) ->
Boson l
let stat_fuse_pair_legacy f s1 s2 =
stat_fuse_pair_unconstrained s1 s2
let stat_fuse_pair_legacy_logging f s1 s2 =
let stat = stat_fuse_pair_legacy f s1 s2 in
Printf.eprintf
"stat_fuse_pair_legacy: (%s, %s) -> %s = %s\n"
(stat_to_string s1) (stat_to_string s2) (stat_to_string stat)
(M.flavor_to_string f);
stat
let stat_fuse_pair_legacy =
majorana_log stat_fuse_pair_legacy stat_fuse_pair_legacy_logging
(* Note that we are using [List.fold_left], therefore
we perform the fusions as
$f(f(\ldots(f(s_1,s_2),s_3),\ldots),s_n)$. Had we used
[List.fold_right] instead, we would compute
$f(s_1,f(s_2,\ldots f(s_{n-1},s_n))).$ For our Dirac
algorithm, this makes no difference, but JRR's Majorana
algorithm depends on the order! *)
(* Also not that we \emph{must not} apply [constrain_stat_fusion]
here, because [stat_fuse_legacy] will be used in
[stat_keystone_legacy] again, where we always expect
[Boson _]. *)
let stat_fuse_legacy s1 s23__n f =
List.fold_left (stat_fuse_pair_legacy f) s1 s23__n
(*i
let stat_fuse_legacy' s1 s23__n f =
match List.rev (s1 :: s23__n) with
| s1 :: s23__n -> List.fold_left (stat_fuse_pair_legacy f) s1 s23__n
| [] -> failwith "stat_fuse_legacy: impossible"
let stat_fuse_legacy' s1 s23__n f =
List.fold_right (stat_fuse_pair_legacy f) s23__n s1
i*)
let stat_fuse_legacy_logging s1 s23__n f =
let stat = stat_fuse_legacy s1 s23__n f in
Printf.eprintf
"stat_fuse_legacy: %s -> %s = %s\n"
(ThoList.to_string stat_to_string (s1 :: s23__n))
(stat_to_string stat)
(M.flavor_to_string f);
stat
let stat_fuse_legacy =
majorana_log stat_fuse_legacy stat_fuse_legacy_logging
(* \thocwmodulesubsection{Merge Fermion Lines using Explicit Fermion Connections} *)
- (* We need to match the fermion lines in the incoming propagators
- using the connection information in the vertex. This used to
- be trivial in the old omega, because there was at most one
- fermion line in a vertex. *)
- module IMap = Map.Make (struct type t = int let compare = compare end)
-
- (* From version 4.05 on, this is just [IMap.find_opt]. *)
- let imap_find_opt p map =
- try Some (IMap.find p map) with Not_found -> None
-
(* Partially combined [stat]s of the incoming propagators and keeping
track of the fermion lines, while we're scanning them. *)
type partial =
{ stat : stat (* the [stat] accumulated so far *);
fermions : int IMap.t (* a map from the indices in the vertex to open (anti)fermion lines *);
n : int (* the number of incoming propagators *) }
(* We will
perform two passes:
\begin{enumerate}
\item collect the saturated fermion lines in a [Boson], while
building a map from the indices in the vertex to the open
fermion lines
\item connect the open fermion lines using the [int -> int] map
[fermions].
\end{enumerate} *)
let empty_partial =
{ stat = Boson [];
fermions = IMap.empty;
n = 0 }
(* Only for debugging: *)
let partial_to_string p =
Printf.sprintf
"{ fermions=%s, stat=%s, #=%d }"
(ThoList.to_string
(fun (i, particle) -> Printf.sprintf "%d@%d" particle i)
(IMap.bindings p.fermions))
(stat_to_string p.stat)
p.n
(* Add a list of saturated fermion lines at the top of the list
of lines in a [stat]. *)
let add_lines l = function
| Boson l' -> Boson (l @ l')
| Fermion (n, l') -> Fermion (n, l @ l')
| AntiFermion (n, l') -> AntiFermion (n, l @ l')
| Majorana (n, l') -> Majorana (n, l @ l')
(* Process one line in the first pass: add the saturated fermion lines
to the partial stat [p.stat]
and add a pointer to an open fermion line in case of a fermion. *)
let add_lines_to_partial p stat =
let n = succ p.n in
match stat with
| Boson l ->
{ fermions = p.fermions;
stat = add_lines l p.stat;
n }
| Majorana (f, l) ->
{ fermions = IMap.add n f p.fermions;
stat = add_lines l p.stat;
n }
| Fermion (p, l) ->
invalid_arg
"add_lines_to_partial: unexpected Fermion"
| AntiFermion (p, l) ->
invalid_arg
"add_lines_to_partial: unexpected AntiFermion"
(* Do it for all lines: *)
let partial_of_slist stat_list =
List.fold_left add_lines_to_partial empty_partial stat_list
let partial_of_rev_slist stat_list =
List.fold_left add_lines_to_partial empty_partial (List.rev stat_list)
(* The building blocks for a single step of the second pass:
saturate a fermion line or pass it through. *)
(* The indices [i] and [j] refer to incoming lines: add a saturated
line to [p.stat] and remove the corresponding open lines from
the map. *)
let saturate_fermion_line p i j =
- match imap_find_opt i p.fermions, imap_find_opt j p.fermions with
+ match IMap.find_opt i p.fermions, IMap.find_opt j p.fermions with
| Some f, Some f' ->
{ stat = add_lines [f'; f] p.stat;
fermions = IMap.remove i (IMap.remove j p.fermions);
n = p.n }
| Some _, None ->
invalid_arg "saturate_fermion_line: no open outgoing fermion line"
| None, Some _ ->
invalid_arg "saturate_fermion_line: no open incoming fermion line"
| None, None ->
invalid_arg "saturate_fermion_line: no open fermion lines"
(* The index [i] refers to an incoming line: add the open line
to [p.stat] and remove it from the map. *)
let pass_through_fermion_line p i =
- match imap_find_opt i p.fermions, p.stat with
+ match IMap.find_opt i p.fermions, p.stat with
| Some f, Boson l ->
{ stat = Majorana (f, l);
fermions = IMap.remove i p.fermions;
n = p.n }
| Some _ , (Majorana _ | Fermion _ | AntiFermion _) ->
invalid_arg "pass_through_fermion_line: more than one open line"
| None, _ ->
invalid_arg "pass_through_fermion_line: expected fermion not found"
(* Ignoring the direction of the fermion line reproduces JRR's algorithm. *)
let sort_pair (i, j) =
if i < j then
(i, j)
else
(j, i)
(* The index [p.n + 1] corresponds to the outgoing line: *)
let is_incoming p i =
i <= p.n
let match_fermion_line p (i, j) =
let i, j = sort_pair (i, j) in
if is_incoming p i && is_incoming p j then
saturate_fermion_line p i j
else if is_incoming p i then
pass_through_fermion_line p i
else if is_incoming p j then
pass_through_fermion_line p j
else
failwith "match_fermion_line: both lines outgoing"
let match_fermion_line_logging p (i, j) =
Printf.eprintf
"match_fermion_line %s [%d->%d]"
(partial_to_string p) i j;
let p' = match_fermion_line p (i, j) in
Printf.eprintf " >> %s\n" (partial_to_string p');
p'
let match_fermion_line =
majorana_log match_fermion_line match_fermion_line_logging
(* Combine the passes \ldots *)
let match_fermion_lines flines s1 s23__n =
List.fold_left match_fermion_line (partial_of_slist (s1 :: s23__n)) flines
(* \ldots{} and keep only the [stat]. *)
let stat_fuse_new flines s1 s23__n _ =
(match_fermion_lines flines s1 s23__n).stat
(* If there is at most a single fermion line, we can compare [stat]
against the result of [stat_fuse_legacy] for checking
[stat_fuse_new] (admittedly, this case is rather trivial) \ldots *)
let stat_fuse_new_check stat flines s1 s23__n f =
if List.length flines < 2 then
begin
let legacy = stat_fuse_legacy s1 s23__n f in
if not (equal stat legacy) then
failwith
(Printf.sprintf
"stat_fuse_new: %s <> %s!"
(stat_to_string stat)
(stat_to_string legacy))
end
(* \ldots{} do it, but only when we are writing debugging output. *)
let stat_fuse_new_logging flines s1 s23__n f =
let stat = stat_fuse_new flines s1 s23__n f in
Printf.eprintf
"stat_fuse_new: %s: %s -> %s = %s\n"
(UFO_Lorentz.fermion_lines_to_string flines)
(ThoList.to_string stat_to_string (s1 :: s23__n))
(stat_to_string stat)
(M.flavor_to_string f);
stat_fuse_new_check stat flines s1 s23__n f;
stat
let stat_fuse_new =
majorana_log stat_fuse_new stat_fuse_new_logging
(* Use [stat_fuse_new], whenever fermion connections are
available. NB: [Some []] is \emph{not} the same as [None]! *)
let stat_fuse flines_opt slist f =
match slist with
| [] -> invalid_arg "stat_fuse: empty"
| s1 :: s23__n ->
constrain_stat_fusion
(match flines_opt with
| Some flines -> stat_fuse_new flines s1 s23__n f
| None -> stat_fuse_legacy s1 s23__n f)
f
let stat_fuse_logging flines_opt slist f =
let stat = stat_fuse flines_opt slist f in
Printf.eprintf
"stat_fuse: %s -> %s = %s\n"
(ThoList.to_string stat_to_string slist)
(stat_to_string stat)
(M.flavor_to_string f);
stat
let stat_fuse =
majorana_log stat_fuse stat_fuse_logging
(* \thocwmodulesubsection{Final Step using Implied Fermion Connections} *)
let stat_keystone_legacy s1 s23__n f =
stat_fuse_legacy s1 s23__n f
let stat_keystone_legacy_logging s1 s23__n f =
let s = stat_keystone_legacy s1 s23__n f in
Printf.eprintf
"stat_keystone_legacy: %s (%s) %s -> %s\n"
(stat_to_string s1)
(M.flavor_to_string f)
(ThoList.to_string stat_to_string s23__n)
(stat_to_string s);
s
let stat_keystone_legacy =
majorana_log stat_keystone_legacy stat_keystone_legacy_logging
(* \thocwmodulesubsection{Final Step using Explicit Fermion Connections} *)
let stat_keystone_new flines slist f =
match slist with
| [] -> invalid_arg "stat_keystone: empty"
| [s] -> invalid_arg "stat_keystone: singleton"
| s1 :: s2 :: s34__n ->
let stat =
stat_fuse_pair_unconstrained s1 (stat_fuse_new flines s2 s34__n f) in
if saturated stat then
stat
else
failwith
(Printf.sprintf
"stat_keystone: incomplete %s!"
(stat_to_string stat))
let stat_keystone_new_check stat slist f =
match slist with
| [] -> invalid_arg "stat_keystone_check: empty"
| s1 :: s23__n ->
let legacy = stat_keystone_legacy s1 s23__n f in
if not (equal stat legacy) then
failwith
(Printf.sprintf
"stat_keystone_check: %s <> %s!"
(stat_to_string stat)
(stat_to_string legacy))
let stat_keystone flines_opt slist f =
match flines_opt with
| Some flines -> stat_keystone_new flines slist f
| None ->
begin match slist with
| [] -> invalid_arg "stat_keystone: empty"
| s1 :: s23__n -> stat_keystone_legacy s1 s23__n f
end
let stat_keystone_logging flines_opt slist f =
let stat = stat_keystone flines_opt slist f in
Printf.eprintf
"stat_keystone: %s (%s) %s -> %s\n"
(stat_to_string (List.hd slist))
(M.flavor_to_string f)
(ThoList.to_string stat_to_string (List.tl slist))
(stat_to_string stat);
stat_keystone_new_check stat slist f;
stat
let stat_keystone =
majorana_log stat_keystone stat_keystone_logging
(* Force the legacy version w/o checking against the
new implementation for comparing generated code
against the hard coded models: *)
let stat_fuse flines_opt slist f =
if force_legacy then
stat_fuse_legacy (List.hd slist) (List.tl slist) f
else
stat_fuse flines_opt slist f
let stat_keystone flines_opt slist f =
if force_legacy then
stat_keystone_legacy (List.hd slist) (List.tl slist) f
else
stat_keystone flines_opt slist f
(* \thocwmodulesubsection{Evaluate Signs from Fermion Permuations} *)
let stat_sign = function
| Boson lines -> sign_of_permutation lines
| Fermion (p, lines) -> sign_of_permutation (p :: lines)
| AntiFermion (pbar, lines) -> sign_of_permutation (pbar :: lines)
| Majorana (pm, lines) -> sign_of_permutation (pm :: lines)
let stat_sign_logging stat =
let sign = stat_sign stat in
Printf.eprintf
"stat_sign: %s -> %d\n"
(stat_to_string stat) sign;
sign
let stat_sign =
majorana_log stat_sign stat_sign_logging
end
module Binary_Majorana =
Make(Tuple.Binary)(Stat_Majorana)(Topology.Binary)
module Nary (B: Tuple.Bound) =
Make(Tuple.Nary(B))(Stat_Dirac)(Topology.Nary(B))
module Nary_Majorana (B: Tuple.Bound) =
Make(Tuple.Nary(B))(Stat_Majorana)(Topology.Nary(B))
module Mixed23 =
Make(Tuple.Mixed23)(Stat_Dirac)(Topology.Mixed23)
module Mixed23_Majorana =
Make(Tuple.Mixed23)(Stat_Majorana)(Topology.Mixed23)
module Helac (B: Tuple.Bound) =
Make(Tuple.Nary(B))(Stat_Dirac)(Topology.Helac(B))
module Helac_Majorana (B: Tuple.Bound) =
Make(Tuple.Nary(B))(Stat_Majorana)(Topology.Helac(B))
module B2 = struct let max_arity () = 2 end
module B3 = struct let max_arity () = 3 end
module Helac_Binary = Helac(B2)
module Helac_Binary_Majorana = Helac(B2)
module Helac_Mixed23 = Helac(B3)
module Helac_Mixed23_Majorana = Helac(B3)
(* \thocwmodulesection{Multiple Amplitudes} *)
module type Multi =
sig
exception Mismatch
val options : Options.t
type flavor
type process = flavor list * flavor list
type amplitude
type fusion
type wf
- type exclusions
- val no_exclusions : exclusions
type selectors
+ type slicings
+ type coupling_order
type amplitudes
val amplitudes : bool -> int option ->
- exclusions -> selectors -> process list -> amplitudes
+ selectors -> slicings option -> process list -> amplitudes
val empty : amplitudes
-(*i
- val initialize_cache : string -> unit
- val set_cache_name : string -> unit
-i*)
val flavors : amplitudes -> process list
val vanishing_flavors : amplitudes -> process list
val color_flows : amplitudes -> Color.Flow.t list
+ val coupling_orders : amplitudes -> (coupling_order list * int list list) option
val helicities : amplitudes -> (int list * int list) list
val processes : amplitudes -> amplitude list
val process_table : amplitudes -> amplitude option array array
+ val process_table_new : amplitudes -> amplitude option array array array
val fusions : amplitudes -> (fusion * amplitude) list
val multiplicity : amplitudes -> wf -> int
val dictionary : amplitudes -> amplitude -> wf -> int
val color_factors : amplitudes -> Color.Flow.factor array array
val constraints : amplitudes -> string option
+ val slicings : amplitudes -> string list
end
module type Multi_Maker = functor (Fusion_Maker : Maker) ->
functor (P : Momentum.T) ->
functor (M : Model.T) ->
Multi with type flavor = M.flavor
and type amplitude = Fusion_Maker(P)(M).amplitude
and type fusion = Fusion_Maker(P)(M).fusion
and type wf = Fusion_Maker(P)(M).wf
and type selectors = Fusion_Maker(P)(M).selectors
+ and type slicings = Orders.Conditions(Colorize.It(M)).t
+ and type coupling_order = Orders.Slice(Colorize.It(M)).coupling_order
module Multi (Fusion_Maker : Maker) (P : Momentum.T) (M : Model.T) =
struct
exception Mismatch
type progress_mode =
| Quiet
| Channel of out_channel
| File of string
let progress_option = ref Quiet
module CM = Colorize.It(M)
+ module SCM = Orders.Slice(Colorize.It(M))
module F = Fusion_Maker(P)(M)
module C = Cascade.Make(M)(P)
+ module COC = Orders.Conditions(Colorize.It(M))
+
(* \begin{dubious}
A kludge, at best \ldots
\end{dubious} *)
let options = Options.extend F.options
[ "progress", Arg.Unit (fun () -> progress_option := Channel stderr),
- "report progress to the standard error stream";
+ " report progress to the standard error stream";
"progress_file", Arg.String (fun s -> progress_option := File s),
- "report progress to a file" ]
+ "file write progress report to file" ]
type flavor = M.flavor
type p = F.p
type process = flavor list * flavor list
type amplitude = F.amplitude
type fusion = F.fusion
type wf = F.wf
- type exclusions = F.exclusions
- let no_exclusions = F.no_exclusions
type selectors = F.selectors
+ type slicings = COC.t
+ type coupling_order = SCM.coupling_order
type flavors = flavor list array
type helicities = int list array
type colors = Color.Flow.t array
- type amplitudes' = amplitude array array array
-
type amplitudes =
{ flavors : process list;
vanishing_flavors : process list;
color_flows : Color.Flow.t list;
- helicities : (int list * int list) list;
+ helicities : (int list * int list) list;
+ coupling_orders : (coupling_order list * int list list) option;
processes : amplitude list;
process_table : amplitude option array array;
+ process_table_new : amplitude option array array array;
fusions : (fusion * amplitude) list;
multiplicity : (wf -> int);
dictionary : (amplitude -> wf -> int);
color_factors : Color.Flow.factor array array;
- constraints : string option }
+ constraints : string option;
+ slicings : string list }
let flavors a = a.flavors
let vanishing_flavors a = a.vanishing_flavors
let color_flows a = a.color_flows
let helicities a = a.helicities
+ let coupling_orders a = a.coupling_orders
let processes a = a.processes
let process_table a = a.process_table
+ let process_table_new a = a.process_table_new
let fusions a = a.fusions
let multiplicity a = a.multiplicity
let dictionary a = a.dictionary
let color_factors a = a.color_factors
let constraints a = a.constraints
+ let slicings a = a.slicings
let sans_colors f =
- List.map CM.flavor_sans_color f
+ List.map CM.flavor_sans_color (List.map SCM.flavor_all_orders f)
let colors (fin, fout) =
List.map M.color (fin @ fout)
let process_sans_color a =
(sans_colors (F.incoming a), sans_colors (F.outgoing a))
let color_flow a =
- CM.flow (F.incoming a) (F.outgoing a)
+ SCM.flow (F.incoming a) (F.outgoing a)
let process_to_string fin fout =
String.concat " " (List.map M.flavor_to_string fin)
^ " -> " ^ String.concat " " (List.map M.flavor_to_string fout)
let count_processes colored_processes =
List.length colored_processes
module FMap =
Map.Make (struct type t = process let compare = compare end)
module CMap =
Map.Make (struct type t = Color.Flow.t let compare = compare end)
(* Recently [Product.list] began to guarantee lexicographic order for sorted
arguments. Anyway, we still force a lexicographic order. *)
let rec order_spin_table1 s1 s2 =
match s1, s2 with
| h1 :: t1, h2 :: t2 ->
let c = compare h1 h2 in
if c <> 0 then
c
else
order_spin_table1 t1 t2
| [], [] -> 0
| _ -> invalid_arg "order_spin_table: inconsistent lengths"
let order_spin_table (s1_in, s1_out) (s2_in, s2_out) =
let c = compare s1_in s2_in in
if c <> 0 then
c
else
order_spin_table1 s1_out s2_out
let sort_spin_table table =
List.sort order_spin_table table
let id x = x
let pair x y = (x, y)
(* \begin{dubious}
Improve support for on shell Ward identities: [Coupling.Vector -> [4]] for one
and only one external vector.
\end{dubious} *)
let rec hs_of_lorentz = function
| Coupling.Scalar -> [0]
| Coupling.Spinor | Coupling.ConjSpinor
| Coupling.Majorana | Coupling.Maj_Ghost -> [-1; 1]
| Coupling.Vector -> [-1; 1]
| Coupling.Massive_Vector -> [-1; 0; 1]
| Coupling.Tensor_1 -> [-1; 0; 1]
| Coupling.Vectorspinor -> [-2; -1; 1; 2]
| Coupling.Tensor_2 -> [-2; -1; 0; 1; 2]
| Coupling.BRS f -> hs_of_lorentz f
let hs_of_flavor f =
hs_of_lorentz (M.lorentz f)
let hs_of_flavors (fin, fout) =
(List.map hs_of_flavor fin, List.map hs_of_flavor fout)
let rec unphysical_of_lorentz = function
| Coupling.Vector -> [4]
| Coupling.Massive_Vector -> [4]
| _ -> invalid_arg "unphysical_of_lorentz: not a vector particle"
let unphysical_of_flavor f =
unphysical_of_lorentz (M.lorentz f)
let unphysical_of_flavors1 n f_list =
ThoList.mapi
(fun i f -> if i = n then unphysical_of_flavor f else hs_of_flavor f)
1 f_list
let unphysical_of_flavors n (fin, fout) =
(unphysical_of_flavors1 n fin, unphysical_of_flavors1 (n - List.length fin) fout)
let helicity_table unphysical flavors =
let hs =
begin match unphysical with
| None -> List.map hs_of_flavors flavors
| Some n -> List.map (unphysical_of_flavors n) flavors
end in
if not (ThoList.homogeneous hs) then
invalid_arg "Fusion.helicity_table: not all flavors have the same helicity states!"
else
match hs with
| [] -> []
| (hs_in, hs_out) :: _ ->
sort_spin_table (Product.list2 pair (Product.list id hs_in) (Product.list id hs_out))
module Proc = Process.Make(M)
module WFMap = Map.Make (struct type t = F.wf let compare = compare end)
module WFSet2 =
Set.Make (struct type t = F.wf * (F.wf, F.coupling) Tree2.t let compare = compare end)
module WFMap2 =
Map.Make (struct type t = F.wf * (F.wf, F.coupling) Tree2.t let compare = compare end)
module WFTSet =
Set.Make (struct type t = (F.wf, F.coupling) Tree2.t let compare = compare end)
(* All wavefunctions are unique per amplitude. So we can use per-amplitude
dependency trees without additional \emph{internal} tags to identify identical
wave functions. *)
(* \textbf{NB:} we miss potential optimizations, because we assume all coupling to
be different, while in fact we have horizontal/family symmetries and non abelian
gauge couplings are universal anyway. *)
let disambiguate_fusions amplitudes =
let fusions =
ThoList.flatmap (fun amplitude ->
List.map
(fun fusion -> (fusion, F.dependencies amplitude (F.lhs fusion)))
(F.fusions amplitude))
amplitudes in
let duplicates =
List.fold_left
(fun map (fusion, dependencies) ->
let wf = F.lhs fusion in
let set = try WFMap.find wf map with Not_found -> WFTSet.empty in
WFMap.add wf (WFTSet.add dependencies set) map)
WFMap.empty fusions in
let multiplicity_map =
WFMap.fold (fun wf dependencies acc ->
let cardinal = WFTSet.cardinal dependencies in
if cardinal <= 1 then
acc
else
WFMap.add wf cardinal acc)
duplicates WFMap.empty
and dictionary_map =
WFMap.fold (fun wf dependencies acc ->
let cardinal = WFTSet.cardinal dependencies in
if cardinal <= 1 then
acc
else
snd (WFTSet.fold
(fun dependency (i', acc') ->
(succ i', WFMap2.add (wf, dependency) i' acc'))
dependencies (1, acc)))
duplicates WFMap2.empty in
let multiplicity wf =
WFMap.find wf multiplicity_map
and dictionary amplitude wf =
WFMap2.find (wf, F.dependencies amplitude wf) dictionary_map in
(multiplicity, dictionary)
let eliminate_common_fusions1 seen_wfs amplitude =
List.fold_left
(fun (seen, acc) f ->
let wf = F.lhs f in
let dependencies = F.dependencies amplitude wf in
if WFSet2.mem (wf, dependencies) seen then
(seen, acc)
else
(WFSet2.add (wf, dependencies) seen, (f, amplitude) :: acc))
seen_wfs (F.fusions amplitude)
let eliminate_common_fusions processes =
let _, rev_fusions =
List.fold_left
eliminate_common_fusions1
(WFSet2.empty, []) processes in
List.rev rev_fusions
(*i
let eliminate_common_fusions processes =
ThoList.flatmap
(fun amplitude ->
(List.map (fun f -> (f, amplitude)) (F.fusions amplitude)))
processes
i*)
+ module COPMap = Map.Make(struct type t = int list let compare = ThoList.compare ~cmp:Stdlib.compare end)
+
+ module COBundle = Bundle.Make
+ (struct
+ type elt = (coupling_order * int) list
+ let compare_elt = compare
+ type base = coupling_order list
+ let compare_base = compare
+ let pi = List.map fst
+ end)
+
+ let collect_coupling_orders processes =
+ let bundle =
+ List.fold_right
+ (fun process ->
+ List.fold_right (fun (orders, _) bundle -> COBundle.add bundle orders) (F.brakets process))
+ processes COBundle.empty in
+ match COBundle.fibers bundle with
+ | [] | [([], _)] -> None
+ | [(coupling_orders, orders)] -> Some (coupling_orders, List.map (List.map snd) orders)
+ | _ -> invalid_arg "Fusion.Multi().exclusive_coupling_orders: not unique"
+
(* \thocwmodulesubsection{Calculate All The Amplitudes} *)
- let amplitudes goldstones unphysical exclusions select_wf processes =
+ let amplitudes goldstones unphysical select_wf slicings processes =
(* \begin{dubious}
Eventually, we might want to support inhomogeneous helicities. However,
this makes little physics sense for external particles on the mass shell,
unless we have a model with degenerate massive fermions and bosons.
\end{dubious} *)
if not (ThoList.homogeneous (List.map hs_of_flavors processes)) then
invalid_arg "Fusion.Multi.amplitudes: incompatible helicities";
let unique_uncolored_processes =
Proc.remove_duplicate_final_states (C.partition select_wf) processes in
let progress =
match !progress_option with
| Quiet -> Progress.dummy
| Channel oc -> Progress.channel oc (count_processes unique_uncolored_processes)
| File name -> Progress.file name (count_processes unique_uncolored_processes) in
let allowed =
ThoList.flatmap
(fun (fi, fo) ->
Progress.begin_step progress (process_to_string fi fo);
- let amps = F.amplitudes goldstones exclusions select_wf fi fo in
+ let amps = F.amplitudes goldstones select_wf slicings fi fo in
begin match amps with
| [] -> Progress.end_step progress "forbidden"
| _ -> Progress.end_step progress "allowed"
end;
amps) unique_uncolored_processes in
Progress.summary progress "all processes done";
let color_flows =
ThoList.uniq (List.sort compare (List.map color_flow allowed))
and flavors =
ThoList.uniq (List.sort compare (List.map process_sans_color allowed)) in
let vanishing_flavors =
Proc.diff processes flavors in
let helicities =
helicity_table unphysical flavors in
+ let allowed_coupling_orders =
+ collect_coupling_orders allowed in
+
let f_index =
fst (List.fold_left
(fun (m, i) f -> (FMap.add f i m, succ i))
(FMap.empty, 0) flavors)
and c_index =
fst (List.fold_left
(fun (m, i) c -> (CMap.add c i m, succ i))
- (CMap.empty, 0) color_flows) in
+ (CMap.empty, 0) color_flows)
+ and co_index =
+ match allowed_coupling_orders with
+ | None -> COPMap.empty
+ | Some (_, powers) ->
+ fst (List.fold_left
+ (fun (m, i) c -> (COPMap.add c i m, succ i))
+ (COPMap.empty, 0) powers) in
let table =
Array.make_matrix (List.length flavors) (List.length color_flows) None in
List.iter
(fun a ->
let f = FMap.find (process_sans_color a) f_index
and c = CMap.find (color_flow a) c_index in
table.(f).(c) <- Some (a))
allowed;
- let cf_array = Array.of_list color_flows in
- let ncf = Array.length cf_array in
- let color_factor_table = Array.make_matrix ncf ncf Color.Flow.zero in
-
- for i = 0 to pred ncf do
- for j = 0 to i do
- color_factor_table.(i).(j) <-
- Color.Flow.factor cf_array.(i) cf_array.(j);
- color_factor_table.(j).(i) <-
- color_factor_table.(i).(j)
- done
- done;
+ let table_new =
+ ThoArray.rank3 1 (List.length flavors) (List.length color_flows) None in
+ List.iter
+ (fun a ->
+ let co = 0
+ and f = FMap.find (process_sans_color a) f_index
+ and c = CMap.find (color_flow a) c_index in
+ table_new.(co).(f).(c) <- Some (a))
+ allowed;
+
+ let color_factor_table = Color.Flow.factor_table color_flows in
let fusions = eliminate_common_fusions allowed
and multiplicity, dictionary = disambiguate_fusions allowed in
+ let slicings =
+ match slicings with
+ | None -> []
+ | Some slicings -> COC.to_strings slicings in
+
{ flavors = flavors;
vanishing_flavors = vanishing_flavors;
color_flows = color_flows;
helicities = helicities;
+ coupling_orders = allowed_coupling_orders;
processes = allowed;
process_table = table;
+ process_table_new = table_new;
fusions = fusions;
multiplicity = multiplicity;
dictionary = dictionary;
color_factors = color_factor_table;
- constraints = C.description select_wf }
-
-(*i
- let initialize_cache = F.initialize_cache
- let set_cache_name = F.set_cache_name
-i*)
+ constraints = C.description select_wf;
+ slicings = slicings }
let empty =
{ flavors = [];
vanishing_flavors = [];
color_flows = [];
helicities = [];
+ coupling_orders = None;
processes = [];
process_table = Array.make_matrix 0 0 None;
+ process_table_new = ThoArray.rank3 0 0 0 None;
fusions = [];
multiplicity = (fun _ -> 1);
dictionary = (fun _ _ -> 1);
color_factors = Array.make_matrix 0 0 Color.Flow.zero;
- constraints = None }
+ constraints = None;
+ slicings = [] }
end
Index: trunk/omega/src/omega_THDM.ml
===================================================================
--- trunk/omega/src/omega_THDM.ml (revision 8899)
+++ trunk/omega/src/omega_THDM.ml (revision 8900)
@@ -1,36 +1,27 @@
(* omega_THDM.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
cf. main AUTHORS file
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.Fortran)
- (Modellib_BSM.TwoHiggsDoublet(Modellib_BSM.THDM))
+module O = Omega.Mixed23(Target_Fortran.Make)(Modellib_BSM.TwoHiggsDoublet(Modellib_BSM.THDM))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/omega_SM_Higgs_CKM_VM.ml
===================================================================
--- trunk/omega/src/omega_SM_Higgs_CKM_VM.ml (revision 8899)
+++ trunk/omega/src/omega_SM_Higgs_CKM_VM.ml (revision 8900)
@@ -1,35 +1,26 @@
(* omega_SM_Higgs_CKM_VM.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
cf. main AUTHORS file
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.VM)
- (Modellib_SM.SM(Modellib_SM.SM_Higgs_CKM))
+module O = Omega.Mixed23(Target_VM.Make)(Modellib_SM.SM(Modellib_SM.SM_Higgs_CKM))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/omega_GravTest.ml
===================================================================
--- trunk/omega/src/omega_GravTest.ml (revision 8899)
+++ trunk/omega/src/omega_GravTest.ml (revision 8900)
@@ -1,26 +1,26 @@
(* omega_GravTest.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23_Majorana_vintage(Targets.Fortran_Majorana)(Modellib_BSM.GravTest(Modellib_BSM.BSM_bsm))
+module O = Omega.Mixed23_Majorana_vintage(Target_Fortran.Make_Majorana)(Modellib_BSM.GravTest(Modellib_BSM.BSM_bsm))
let _ = O.main ()
Index: trunk/omega/src/UFO_syntax.mli
===================================================================
--- trunk/omega/src/UFO_syntax.mli (revision 8899)
+++ trunk/omega/src/UFO_syntax.mli (revision 8900)
@@ -1,66 +1,67 @@
(* vertex_syntax.mli --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
(* \thocwmodulesection{Abstract Syntax} *)
exception Syntax_Error of string * Lexing.position * Lexing.position
type name = string list
type string_atom =
| Macro of name
| Literal of string
type value =
| Name of name
| Integer of int
| Float of float
| Fraction of int * int
| String of string
| String_Expr of string_atom list
| Empty_List
| Name_List of name list
| Integer_List of int list
| String_List of string list
+ | Young_Tableau of int Young.tableau
| Order_Dictionary of (string * int) list
| Coupling_Dictionary of (int * int * name) list
| Decay_Dictionary of (name list * string) list
type attrib =
{ a_name : string;
a_value : value }
type declaration =
{ name : string;
kind : name;
attribs : attrib list }
type t = declaration list
(* A macro expansion is encoded as a special [declaration], with
[kind = "$"] and a single attribute. There should not never
be the risk of a name clash. *)
val macro : string -> value -> declaration
val to_strings : t -> string list
Index: trunk/omega/src/model.mli
===================================================================
--- trunk/omega/src/model.mli (revision 8899)
+++ trunk/omega/src/model.mli (revision 8900)
@@ -1,288 +1,322 @@
(* model.mli --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
(* \thocwmodulesection{General Quantum Field Theories} *)
module type T =
sig
(* [flavor] abstractly encodes all quantum numbers. *)
type flavor
(* [Color.t] encodes the ($\textrm{SU}(N)$) color representation. *)
val color : flavor -> Color.t
val nc : unit -> int
(* The set of conserved charges. *)
module Ch : Charges.T
val charges : flavor -> Ch.t
(* The PDG particle code for interfacing with Monte Carlos. *)
val pdg : flavor -> int
(* The Lorentz representation of the particle. *)
val lorentz : flavor -> Coupling.lorentz
(* The propagator for the particle, which \emph{can} depend
on a gauge parameter. *)
type gauge
val propagator : flavor -> gauge Coupling.propagator
(* \emph{Not} the symbol for the numerical value, but the
scheme or strategy. *)
val width : flavor -> Coupling.width
(* Charge conjugation, with and without color. *)
val conjugate : flavor -> flavor
(* Returns $1$ for fermions, $-1$ for anti-fermions, $2$ for Majoranas
and $0$ otherwise. *)
val fermion : flavor -> int
(* The Feynman rules. [vertices] and [(fuse2, fuse3, fusen)] are
redundant, of course. However, [vertices] is required for building
functors for models and [vertices] can be recovered from
[(fuse2, fuse3, fusen)] only at great cost. *)
(* \begin{dubious}
Nevertheless: [vertices] is a candidate for removal, b/c we can
build a smarter [Colorize] functor acting on [(fuse2, fuse3, fusen)].
It can support an arbitrary numer of color lines. But we have to test
whether it is efficient enough. And we have to make sure that this
wouldn't break the UFO interface.
\end{dubious} *)
type constant
- (* Later: [type orders] to count orders of couplings *)
-
val max_degree : unit -> int
val vertices : unit ->
((((flavor * flavor * flavor) * constant Coupling.vertex3 * constant) list)
* (((flavor * flavor * flavor * flavor) * constant Coupling.vertex4 * constant) list)
* (((flavor list) * constant Coupling.vertexn * constant) list))
val fuse2 : flavor -> flavor -> (flavor * constant Coupling.t) list
val fuse3 : flavor -> flavor -> flavor -> (flavor * constant Coupling.t) list
val fuse : flavor list -> (flavor * constant Coupling.t) list
- (* Later: [val orders : constant -> orders] counting orders of couplings *)
+(* For counting coupling orders. *)
+ type coupling_order
+ val all_coupling_orders : unit -> coupling_order list
+ val coupling_order_to_string : coupling_order -> string
+ val coupling_orders : constant -> (coupling_order * int) list
(* The list of all known flavors. *)
val flavors : unit -> flavor list
(* The flavors that can appear in incoming or outgoing states, grouped
in a way that is useful for user interfaces. *)
val external_flavors : unit -> (string * flavor list) list
(* The Goldstone bosons corresponding to a gauge field, if any. *)
val goldstone : flavor -> (flavor * constant Coupling.expr) option
(* The dependent parameters. *)
val parameters : unit -> constant Coupling.parameters
(* Translate from and to convenient textual representations of flavors. *)
val flavor_of_string : string -> flavor
val flavor_to_string : flavor -> string
(* \TeX{} and \LaTeX{} *)
val flavor_to_TeX : flavor -> string
(* The following must return unique symbols that are acceptable as
symbols in all programming languages under consideration as targets.
Strings of alphanumeric characters (starting with a letter) should
be safe. Underscores are also usable, but would violate strict
Fortran77. *)
val flavor_symbol : flavor -> string
val gauge_symbol : gauge -> string
val mass_symbol : flavor -> string
val width_symbol : flavor -> string
val constant_symbol : constant -> string
(* Model specific options. *)
val options : Options.t
(* \textit{Not ready for prime time} or other warnings to
be written to the source files for the amplitudes. *)
val caveats : unit -> string list
end
(* In addition to hardcoded models, we can have models that are
initialized at run time. *)
(* \thocwmodulesection{Mutable Quantum Field Theories} *)
module type Mutable =
sig
include T
- val init : unit -> unit
+(* Pass initialization data to the model. Typically,
+ this is the name of a UFO directory and we can specialize
+ [Mutable with type init = string] *)
+ type init
+ val init : init -> unit
+ val write_whizard : out_channel -> unit
(* Export only one big initialization function to discourage
partial initializations. Labels make this usable. *)
val setup :
color:(flavor -> Color.t) ->
nc:(unit -> int) ->
pdg:(flavor -> int) ->
lorentz:(flavor -> Coupling.lorentz) ->
propagator:(flavor -> gauge Coupling.propagator) ->
width:(flavor -> Coupling.width) ->
goldstone:(flavor -> (flavor * constant Coupling.expr) option) ->
conjugate:(flavor -> flavor) ->
fermion:(flavor -> int) ->
vertices:
(unit ->
((((flavor * flavor * flavor) * constant Coupling.vertex3 * constant) list)
* (((flavor * flavor * flavor * flavor) * constant Coupling.vertex4 * constant) list)
* (((flavor list) * constant Coupling.vertexn * constant) list))) ->
flavors:((string * flavor list) list) ->
parameters:(unit -> constant Coupling.parameters) ->
flavor_of_string:(string -> flavor) ->
flavor_to_string:(flavor -> string) ->
flavor_to_TeX:(flavor -> string) ->
flavor_symbol:(flavor -> string) ->
gauge_symbol:(gauge -> string) ->
mass_symbol:(flavor -> string) ->
width_symbol:(flavor -> string) ->
constant_symbol:(constant -> string) ->
+ all_coupling_orders:(unit -> coupling_order list) ->
+ coupling_order_to_string:(coupling_order -> string) ->
+ coupling_orders:(constant -> (coupling_order * int) list) ->
unit
end
(* \thocwmodulesection{Gauge Field Theories} *)
(* The following signatures are used only for model building. The diagrammatics
and numerics is supposed to be completely ignorant about the detail of the
models and expected to rely on the interface [T] exclusively.
\begin{dubious}
In the end, we might have functors [(M : T) -> Gauge], but we will
need to add the quantum numbers to [T].
\end{dubious} *)
module type Gauge =
sig
include T
(* Matter field carry conserved quantum numbers and can be replicated
in generations without changing the gauge sector. *)
type matter_field
(* Gauge bosons proper. *)
type gauge_boson
(* Higgses, Goldstones and all the rest: *)
type other
(* We can query the kind of field *)
type field =
| Matter of matter_field
| Gauge of gauge_boson
| Other of other
val field : flavor -> field
(* and we can build new fields of a given kind: *)
val matter_field : matter_field -> flavor
val gauge_boson : gauge_boson -> flavor
val other : other -> flavor
end
(* \thocwmodulesection{Gauge Field Theories with Broken Gauge Symmetries} *)
(* Both are carefully crafted as subtypes of [Gauge] so that
they can be used in place of [Gauge] and [T] everywhere: *)
module type Broken_Gauge =
sig
include Gauge
type massless
type massive
type goldstone
type kind =
| Massless of massless
| Massive of massive
| Goldstone of goldstone
val kind : gauge_boson -> kind
val massless : massive -> gauge_boson
val massive : massive -> gauge_boson
val goldstone : goldstone -> gauge_boson
end
module type Unitarity_Gauge =
sig
include Gauge
type massless
type massive
type kind =
| Massless of massless
| Massive of massive
val kind : gauge_boson -> kind
val massless : massive -> gauge_boson
val massive : massive -> gauge_boson
end
module type Colorized =
sig
include T
type flavor_sans_color
val flavor_sans_color : flavor -> flavor_sans_color
val conjugate_sans_color : flavor_sans_color -> flavor_sans_color
+(* [amplitude] does \emph{not} compute the amplitude, but
+ returns all possible color combinations for the given flavor.
+ These will be used by the functions in [Fusion]. *)
+
val amplitude : flavor_sans_color list -> flavor_sans_color list ->
(flavor list * flavor list) list
val flow : flavor list -> flavor list -> Color.Flow.t
+ val flavor_equal : flavor -> flavor -> bool
+
end
module type Colorized_Gauge =
sig
include Gauge
type flavor_sans_color
val flavor_sans_color : flavor -> flavor_sans_color
val conjugate_sans_color : flavor_sans_color -> flavor_sans_color
val amplitude : flavor_sans_color list -> flavor_sans_color list ->
(flavor list * flavor list) list
val flow : flavor list -> flavor list -> Color.Flow.t
+ val flavor_equal : flavor -> flavor -> bool
+
end
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
+module type Sliced_by_Orders =
+ sig
+
+ include Colorized
+
+ type flavor_all_orders
+ val flavor_all_orders : flavor -> flavor_all_orders
+ val conjugate_all_orders : flavor_all_orders -> flavor_all_orders
+
+ type orders
+ val orders : flavor -> orders
+ val add_orders : orders -> orders -> orders
+ val incr_orders : orders -> orders -> orders
+ val orders_to_string : orders -> string
+ val orders_symbol : orders -> string
+
+ val trivial : flavor_all_orders -> flavor
+
+ val amplitude : orders -> flavor_all_orders list -> flavor_all_orders list ->
+ flavor list * flavor list
+ val flow : flavor list -> flavor list -> Color.Flow.t
+
+ end
Index: trunk/omega/src/young.mli
===================================================================
--- trunk/omega/src/young.mli (revision 8899)
+++ trunk/omega/src/young.mli (revision 8900)
@@ -1,147 +1,156 @@
(* young.mli --
Copyright (C) 2022- by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
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. *)
(* Caveat: the following are not optimized for large Young diagrams and
tableaux. They are straightforward implementations of the
definitions, since we are unlikely to meet large diagrams.
To make matters worse, native integer arithmetic will overflow
already for diagrams with more than 20 cells.
Since the [Num] library has been removed from the O'Caml
distribution with version 4.06, we can not use it as
a shortcut. Requiring Whizard/O'Mega users to install
[Num] or its successor [Zarith] is probably not worth
the effort. *)
(* \ytableausetup{centertableaux,smalltableaux} *)
(* \thocwmodulesection{Young Diagrams} *)
(* Young diagrams can be represented by a non-increasing list
of positive integers, corresponding to the number of boxes
in each row:
\begin{equation}
\ydiagram{5,4,4,2} \Longleftrightarrow \lbrack 5;4;4;2 \rbrack
\end{equation} *)
type diagram = int list
(* Check that the diagram is valid, i.\,e.~the number of boxes
is non-increasing from top to bottom. *)
val valid_diagram : diagram -> bool
(* Count the number of cells. *)
val num_cells_diagram : diagram -> int
(* Conjugate a diagram:
\begin{equation}
\ydiagram{5,4,4,2} \mapsto \ydiagram{4,4,3,3,1}
\end{equation} *)
val conjugate_diagram : diagram -> diagram
(* The product of all the ``hook lengths'' in the diagram, e.\,g.
\begin{equation}
\ydiagram{5,4,4,2}
\mapsto \ytableaushort{87541,6532,5421,21}
\mapsto 8 \cdot 7 \cdot 6 \cdot 5^3 \cdot 4^2 \cdot 3 \cdot 2^3
= 16128000
\end{equation}
where the intermediate step is only for illustration and does not
represent a Young tableau! *)
val hook_lengths_product : diagram -> int
(* Number of standard tableaux corresponding to the diagram.
Also, the dimension of the representation of~$S_n$ described
by this diagram
\begin{equation}
d = \frac{n!}{\prod_{i=1}^n h_i}
\end{equation}
with~$n$ the number of cells and~$h_i$ the hook length of
the $i$th cell. *)
val num_standard_tableaux : diagram -> int
(* Normalization of the projector on the representation of $\mathrm{GL(N)}$
described by the diagram
\begin{equation}
\alpha = \frac{\prod_{R} |R|!\prod_{C} |C|!}{\prod_{i=1}^n h_i}
\end{equation}
with~$|R|$ and~$|C|$ the lengths of the row~$R$ and column~$C$,
respectively. Returned as a pair of numerator and denominator,
because it is not guaranteed to be integer. *)
val normalization : diagram -> int * int
(* \thocwmodulesection{Young Tableaux} *)
(* There is an obvious representation as a list of lists:
\begin{equation}
\ytableaushort{023,14}
\Longleftrightarrow
\lbrack \lbrack 0; 2; 3 \rbrack;
\lbrack 1; 4 \rbrack \rbrack
\end{equation} *)
type 'a tableau = 'a list list
(* Ignoring the contents of the cells of a Young tableau produces
a unique corresponding Young diagram.
\begin{equation}
\ytableaushort{023,14}
\mapsto \ydiagram{3,2}
\end{equation} *)
val diagram_of_tableau : 'a tableau -> diagram
(* The number of columns must be non-increasing. Obviously,
[valid_tableau] is the composition of [diagram_of_tableau]
and [valid_diagram].*)
val valid_tableau : 'a tableau -> bool
(* A tableau is called \textit{semistandard}, iff the entries
- don't increase along rows and strictly increase along columns.
+ don't decrease along rows and strictly increase along columns.
Therefore, the conjugate of a semistandard tableau is \emph{not}
necessarily semistandard. *)
val semistandard_tableau : 'a tableau -> bool
(* A tableau is called \textit{standard}, iff it is semistandard
and the entries are an uninterrupted sequence of natural numbers.
If the optional [offset] is specified, it must match the smallest
of these numbers. Some authors expect [offset=1], but we want
to be able to start from 0 as well.
The conjugate of a standard tableau is again a standard tableau. *)
val standard_tableau : ?offset:int -> int tableau -> bool
(* The contents of the cells and their number. *)
val cells_tableau : 'a tableau -> 'a list
val num_cells_tableau : 'a tableau -> int
(* Conjugate a Young tableau
\begin{equation}
\ytableaushort{023,14}
\mapsto \ytableaushort{01,24,3}
\end{equation} *)
val conjugate_tableau : 'a tableau -> 'a tableau
+(* Transform the contents cell-by-cell. *)
+val map: ('a -> 'b) -> 'a tableau -> 'b tableau
+
+(* Debugging and diagnostics. *)
+val tableau_to_string : ('a -> string) -> 'a tableau -> string
+
+(* Toplevel *)
+val pp : Format.formatter -> int tableau -> unit
+
(* \thocwmodulesection{Unit Tests} *)
module type Test =
sig
val suite : OUnit.test
val suite_long : OUnit.test
end
module Test : Test
Index: trunk/omega/src/omega_SYM.ml
===================================================================
--- trunk/omega/src/omega_SYM.ml (revision 8899)
+++ trunk/omega/src/omega_SYM.ml (revision 8900)
@@ -1,334 +1,327 @@
(* omega_SYM.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
module SYM =
struct
open Coupling
let options = Options.empty
let caveats () = []
let nc = 3
type flavor =
| Q of int | SQ of int
| G of int | SG of int
| Phi
let generations = ThoList.range 1 1
let generations_pairs =
List.map
(function [a;b] -> (a, b)
| _ -> failwith "omega_SYM.generations_pairs")
(Product.power 2 generations)
let generations_triples =
List.map
(function [a;b;c] -> (a, b, c)
| _ -> failwith "omega_SYM.generations_triples")
(Product.power 3 generations)
let generations_quadruples =
List.map
(function [a;b;c;d] -> (a, b, c, d)
| _ -> failwith "omega_SYM.generations_quadruples")
(Product.power 4 generations)
let external_flavors () =
[ "Quarks", List.map (fun i -> Q i) generations;
"Anti-Quarks", List.map (fun i -> Q (-i)) generations;
"SQuarks", List.map (fun i -> SQ i) generations;
"Anti-SQuarks", List.map (fun i -> SQ (-i)) generations;
"Gluons", List.map (fun i -> G i) generations;
"SGluons", List.map (fun i -> SG i) generations;
"Other", [Phi]]
let flavors () =
ThoList.flatmap snd (external_flavors ())
type gauge = unit
type constant =
| G_saa of int * int
| G_saaa of int * int * int
| G3 of int * int * int
| I_G3 of int * int * int
| G4 of int * int * int * int
- type orders = unit
- let orders = function
- | _ -> ()
+ type coupling_order = unit
+ let all_coupling_orders () = [()]
+ let coupling_order_to_string () = ""
+ let coupling_orders = function
+ | _ -> failwith "Modellib_SYM.orders: not implemented yet!"
let lorentz = function
| Q i ->
if i > 0 then
Spinor
else if i < 0 then
ConjSpinor
else
invalid_arg "SYM.lorentz (Q 0)"
| SQ _ | Phi -> Scalar
| G _ -> Vector
| SG _ -> Majorana
let color = function
| Q i | SQ i ->
Color.SUN (if i > 0 then nc else if i < 0 then -nc else invalid_arg "SYM.color (Q 0)")
| G _ | SG _ -> Color.AdjSUN nc
| Phi -> Color.Singlet
let nc () = nc
let propagator = function
| Q i ->
if i > 0 then
Prop_Spinor
else if i < 0 then
Prop_ConjSpinor
else
invalid_arg "SYM.lorentz (Q 0)"
| SQ _ | Phi -> Prop_Scalar
| G _ -> Prop_Feynman
| SG _ -> Prop_Majorana
(*i let propagator _ =
Only_Insertion
i*)
let width _ = Timelike
let goldstone _ = None
let conjugate = function
| Q i -> Q (-i)
| SQ i -> SQ (-i)
| (G _ | SG _ | Phi) as p -> p
let fermion = function
| Q i ->
if i > 0 then
1
else if i < 0 then
-1
else
invalid_arg "SYM.fermion (Q 0)"
| SQ _ | G _ | Phi -> 0
| SG _ -> 2
module Ch = Charges.Null
let charges _ = ()
module F = Modeltools.Fusions (struct
type f = flavor
type c = constant
let compare = compare
let conjugate = conjugate
end)
let quark_current =
List.map
(fun (i, j, k) ->
((Q (-i), G j, Q k), FBF (-1, Psibar, V, Psi), G3 (i, j, k)))
generations_triples
let squark_current =
List.map
(fun (i, j, k) ->
((G j, SQ i, SQ (-k)), Vector_Scalar_Scalar 1, G3 (i, j, k)))
generations_triples
let three_gluon =
List.map
(fun (i, j, k) ->
((G i, G j, G k), Gauge_Gauge_Gauge 1, I_G3 (i, j, k)))
generations_triples
let gluon2_phi =
List.map
(fun (i, j) ->
((Phi, G i, G j), Dim5_Scalar_Gauge2 1, G_saa (i, j)))
generations_pairs
let vertices3 =
quark_current @ squark_current @ three_gluon @ gluon2_phi
let gauge4 = Vector4 [(2, C_13_42); (-1, C_12_34); (-1, C_14_23)]
let squark_seagull =
List.map
(fun (i, j, k, l) ->
((SQ i, SQ (-j), G k, G l), Scalar2_Vector2 1, G4 (i, j, k, l)))
generations_quadruples
let four_gluon =
List.map
(fun (i, j, k, l) ->
((G i, G j, G k, G l), gauge4, G4 (i, j, k, l)))
generations_quadruples
(*i
let gluon3_phi =
List.map
(fun (i, j, k) ->
((Phi, G i, G j, G k), Dim6_Scalar_Gauge3 1, G_saaa (i, j, k)))
generations_triples
i*)
(* \begin{dubious}
We need at least a [Dim6_Scalar_Gauge3] vertex to support this.
\end{dubious} *)
let gluon3_phi =
[]
let vertices4 =
squark_seagull @ four_gluon @ gluon3_phi
let vertices () =
(vertices3, vertices4, [])
let table = F.of_vertices (vertices ())
let fuse2 = F.fuse2 table
let fuse3 = F.fuse3 table
let fuse = F.fuse table
let max_degree () = 4
let parameters () = { input = []; derived = []; derived_arrays = [] }
let invalid_flavor s =
invalid_arg ("omega_SYM.flavor_of_string: " ^ s)
let flavor_of_string s =
let l = String.length s in
if l < 2 then
invalid_flavor s
else if l = 2 then
if String.sub s 0 1 = "q" then
Q (int_of_string (String.sub s 1 1))
else if String.sub s 0 1 = "Q" then
Q (- (int_of_string (String.sub s 1 1)))
else if String.sub s 0 1 = "g" then
G (int_of_string (String.sub s 1 1))
else
invalid_flavor s
else if l = 3 then
if s = "phi" then
Phi
else if String.sub s 0 2 = "sq" then
SQ (int_of_string (String.sub s 2 1))
else if String.sub s 0 2 = "sQ" then
SQ (- (int_of_string (String.sub s 2 1)))
else if String.sub s 0 2 = "sg" then
SG (int_of_string (String.sub s 2 1))
else
invalid_flavor s
else
invalid_flavor s
let flavor_to_string = function
| Q i ->
if i > 0 then
"q" ^ string_of_int i
else if i < 0 then
"Q" ^ string_of_int (-i)
else
invalid_arg "SYM.flavor_to_string (Q 0)"
| SQ i ->
if i > 0 then
"sq" ^ string_of_int i
else if i < 0 then
"sQ" ^ string_of_int (-i)
else
invalid_arg "SYM.flavor_to_string (SQ 0)"
| G i -> "g" ^ string_of_int i
| SG i -> "sg" ^ string_of_int i
| Phi -> "phi"
let flavor_to_TeX = function
| Q i ->
if i > 0 then
"q_{" ^ string_of_int i ^ "}"
else if i < 0 then
"{\bar q}_{" ^ string_of_int (-i) ^ "}"
else
invalid_arg "SYM.flavor_to_string (Q 0)"
| SQ i ->
if i > 0 then
"{\tilde q}_{" ^ string_of_int i ^ "}"
else if i < 0 then
"{\bar{\tilde q}}_{" ^ string_of_int (-i) ^ "}"
else
invalid_arg "SYM.flavor_to_string (SQ 0)"
| G i -> "g_{" ^ string_of_int i ^ "}"
| SG i -> "{\tilde g}_{" ^ string_of_int i ^ "}"
| Phi -> "phi"
let flavor_symbol = function
| Q i ->
if i > 0 then
"q" ^ string_of_int i
else if i < 0 then
"qbar" ^ string_of_int (-i)
else
invalid_arg "SYM.flavor_to_string (Q 0)"
| SQ i ->
if i > 0 then
"sq" ^ string_of_int i
else if i < 0 then
"sqbar" ^ string_of_int (-i)
else
invalid_arg "SYM.flavor_to_string (SQ 0)"
| G i -> "g" ^ string_of_int i
| SG i -> "sg" ^ string_of_int i
| Phi -> "phi"
let gauge_symbol () =
failwith "omega_SYM.gauge_symbol: internal error"
let pdg _ = 0
let mass_symbol _ = "0.0_default"
let width_symbol _ = "0.0_default"
let string_of_int_list int_list =
"(" ^ String.concat "," (List.map string_of_int int_list) ^ ")"
let constant_symbol = function
| G_saa (i, j) -> "g_saa" ^ string_of_int_list [i;j]
| G_saaa (i, j, k) -> "g_saaa" ^ string_of_int_list [i;j;k]
| G3 (i, j, k) -> "g3" ^ string_of_int_list [i;j;k]
| I_G3 (i, j, k) -> "ig3" ^ string_of_int_list [i;j;k]
| G4 (i, j, k, l) -> "g4" ^ string_of_int_list [i;j;k;l]
end
-module O = Omega.Mixed23(Targets.Fortran_Majorana)(SYM)
+module O = Omega.Mixed23(Target_Fortran.Make_Majorana)(SYM)
let _ = O.main ()
-
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/fusion_vintage.ml
===================================================================
--- trunk/omega/src/fusion_vintage.ml (revision 8899)
+++ trunk/omega/src/fusion_vintage.ml (revision 8900)
@@ -1,2901 +1,2923 @@
(* fusion_vintage.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
Marco Sekulla <marco.sekulla@kit.edu>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-(* Avoid refering to [Pervasives.compare], because [Pervasives] will
- become [Stdlib.Pervasives] in O'Caml 4.07 and [Stdlib] in O'Caml 4.08. *)
-let pcompare = compare
-
module type T =
sig
val options : Options.t
val vintage : bool
type wf
val conjugate : wf -> wf
type flavor
+ type flavor_all_orders
type flavor_sans_color
val flavor : wf -> flavor
+ val flavor_all_orders : wf -> flavor_all_orders
val flavor_sans_color : wf -> flavor_sans_color
type p
val momentum : wf -> p
val momentum_list : wf -> int list
- val wf_tag : wf -> string option
type constant
type coupling
type rhs
type 'a children
val sign : rhs -> int
val coupling : rhs -> constant Coupling.t
- val coupling_tag : rhs -> string option
- type exclusions
- val no_exclusions : exclusions
val children : rhs -> wf list
type fusion
val lhs : fusion -> wf
val rhs : fusion -> rhs list
type braket
val bra : braket -> wf
val ket : braket -> rhs list
type amplitude
type amplitude_sans_color
type selectors
- val amplitudes : bool -> exclusions -> selectors ->
+ type slicings
+ val amplitudes : bool -> selectors -> slicings option ->
+ flavor_sans_color list -> flavor_sans_color list -> amplitude list
+ val amplitudes_all_orders : bool -> selectors ->
flavor_sans_color list -> flavor_sans_color list -> amplitude list
- val amplitude_sans_color : bool -> exclusions -> selectors ->
+ val amplitude_sans_color : bool -> selectors ->
flavor_sans_color list -> flavor_sans_color list -> amplitude_sans_color
val dependencies : amplitude -> wf -> (wf, coupling) Tree2.t
val incoming : amplitude -> flavor list
val outgoing : amplitude -> flavor list
val externals : amplitude -> wf list
val variables : amplitude -> wf list
val fusions : amplitude -> fusion list
- val brakets : amplitude -> braket list
+ type 'a slices
+ val brakets : amplitude -> braket list slices
val on_shell : amplitude -> (wf -> bool)
val is_gauss : amplitude -> (wf -> bool)
val constraints : amplitude -> string option
+ val slicings : amplitude -> string list
val symmetry : amplitude -> int
val allowed : amplitude -> bool
(*i
val initialize_cache : string -> unit
val set_cache_name : string -> unit
i*)
val check_charges : unit -> flavor_sans_color list list
val count_fusions : amplitude -> int
val count_propagators : amplitude -> int
val count_diagrams : amplitude -> int
val forest : wf -> amplitude -> ((wf * coupling option, wf) Tree.t) list
val poles : amplitude -> wf list list
val s_channel : amplitude -> wf list
val tower_to_dot : out_channel -> amplitude -> unit
val amplitude_to_dot : out_channel -> amplitude -> unit
val phase_space_channels : out_channel -> amplitude_sans_color -> unit
val phase_space_channels_flipped : out_channel -> amplitude_sans_color -> unit
end
module type Maker =
functor (P : Momentum.T) -> functor (M : Model.T) ->
T with type p = P.t
- and type flavor = Colorize.It(M).flavor
+ and type flavor = Orders.Slice(Colorize.It(M)).flavor
+ and type flavor_all_orders = Colorize.It(M).flavor
and type flavor_sans_color = M.flavor
and type constant = M.constant
and type selectors = Cascade.Make(M)(P).selectors
+ and type slicings = Orders.Conditions(Colorize.It(M)).t
+ and type 'a slices = (Orders.Slice(Colorize.It(M)).orders * 'a) list
(* \thocwmodulesection{Fermi Statistics} *)
module type Stat =
sig
type flavor
type stat
exception Impossible
val stat : flavor -> int -> stat
val stat_fuse : stat -> stat -> flavor -> stat
val stat_sign : stat -> int
val stat_to_string : stat -> string
end
module type Stat_Maker = functor (M : Model.T) ->
Stat with type flavor = M.flavor
(* \thocwmodulesection{Dirac Fermions} *)
module Stat_Dirac (M : Model.T) : (Stat with type flavor = M.flavor) =
struct
type flavor = M.flavor
(* \begin{equation}
\gamma_\mu\psi(1)\,G^{\mu\nu}\,\bar\psi(2)\gamma_\nu\psi(3)
- \gamma_\mu\psi(3)\,G^{\mu\nu}\,\bar\psi(2)\gamma_\nu\psi(1)
\end{equation} *)
type stat =
| Fermion of int * (int option * int option) list
| AntiFermion of int * (int option * int option) list
| Boson of (int option * int option) list
let stat f p =
let s = M.fermion f in
if s = 0 then
Boson []
else if s < 0 then
AntiFermion (p, [])
else (* [if s > 0 then] *)
Fermion (p, [])
let lines_to_string lines =
ThoList.to_string
(function
| Some i, Some j -> Printf.sprintf "%d>%d" i j
| Some i, None -> Printf.sprintf "%d>*" i
| None, Some j -> Printf.sprintf "*>%d" j
| None, None -> "*>*")
lines
let stat_to_string = function
| Boson lines -> Printf.sprintf "Boson %s" (lines_to_string lines)
| Fermion (p, lines) ->
Printf.sprintf "Fermion (%d, %s)" p (lines_to_string lines)
| AntiFermion (p, lines) ->
Printf.sprintf "AntiFermion (%d, %s)" p (lines_to_string lines)
exception Impossible
let stat_fuse s1 s2 f =
match s1, s2 with
| Boson l1, Boson l2 -> Boson (l1 @ l2)
| Boson l1, Fermion (p, l2) -> Fermion (p, l1 @ l2)
| Boson l1, AntiFermion (p, l2) -> AntiFermion (p, l1 @ l2)
| Fermion (p, l1), Boson l2 -> Fermion (p, l1 @ l2)
| AntiFermion (p, l1), Boson l2 -> AntiFermion (p, l1 @ l2)
| AntiFermion (pbar, l1), Fermion (p, l2) ->
Boson ((Some pbar, Some p) :: l1 @ l2)
| Fermion (p, l1), AntiFermion (pbar, l2) ->
Boson ((Some pbar, Some p) :: l1 @ l2)
| Fermion _, Fermion _ | AntiFermion _, AntiFermion _ ->
raise Impossible
(* \begin{figure}
\begin{displaymath}
\parbox{26\unitlength}{%
\begin{fmfgraph*}(25,15)
\fmfstraight
\fmfleft{f}
\fmfright{f1,f2,f3}
\fmflabel{$\psi(1)$}{f1}
\fmflabel{$\bar\psi(2)$}{f2}
\fmflabel{$\psi(3)$}{f3}
\fmflabel{$0$}{f}
\fmf{fermion}{f1,v1,f}
\fmffreeze
\fmf{fermion,tension=0.5}{f3,v2,f2}
\fmf{photon}{v1,v2}
\fmfdot{v1,v2}
\end{fmfgraph*}}
\qquad\qquad-\qquad
\parbox{26\unitlength}{%
\begin{fmfgraph*}(25,15)
\fmfstraight
\fmfleft{f}
\fmfright{f1,f2,f3}
\fmflabel{$\psi(1)$}{f1}
\fmflabel{$\bar\psi(2)$}{f2}
\fmflabel{$\psi(3)$}{f3}
\fmflabel{$0$}{f}
\fmf{fermion}{f3,v1,f}
\fmffreeze
\fmf{fermion,tension=0.5}{f1,v2,f2}
\fmf{photon}{v1,v2}
\fmfdot{v1,v2}
\end{fmfgraph*}}
\end{displaymath}
\caption{\label{fig:stat_fuse} Relative sign from Fermi statistics.}
\end{figure} *)
(* \begin{equation}
\epsilon \left(\left\{ (0,1), (2,3) \right\}\right)
= - \epsilon \left(\left\{ (0,3), (2,1) \right\}\right)
\end{equation} *)
let permutation lines =
let fout, fin = List.split lines in
let eps_in, _ = Combinatorics.sort_signed fin
and eps_out, _ = Combinatorics.sort_signed fout in
(eps_in * eps_out)
(* \begin{dubious}
This comparing of permutations of fermion lines is a bit tedious
and takes a macroscopic fraction of time. However, it's less than
20\,\%, so we don't focus on improving on it yet.
\end{dubious} *)
let stat_sign = function
| Boson lines -> permutation lines
| Fermion (p, lines) -> permutation ((None, Some p) :: lines)
| AntiFermion (pbar, lines) -> permutation ((Some pbar, None) :: lines)
end
-(* \thocwmodulesection{Tags} *)
-
-module type Tags =
- sig
- type wf
- type coupling
- type 'a children
- val null_wf : wf
- val null_coupling : coupling
- val fuse : coupling -> wf children -> wf
- val wf_to_string : wf -> string option
- val coupling_to_string : coupling -> string option
- end
-
-module type Tagger =
- functor (PT : Tuple.Poly) -> Tags with type 'a children = 'a PT.t
-
-module type Tagged_Maker =
- functor (Tagger : Tagger) ->
- functor (P : Momentum.T) -> functor (M : Model.T) ->
- T with type p = P.t
- and type flavor = Colorize.It(M).flavor
- and type flavor_sans_color = M.flavor
- and type constant = M.constant
-
-(* No tags is one option for good tags \ldots *)
-
-module No_Tags (PT : Tuple.Poly) =
- struct
- type wf = unit
- type coupling = unit
- type 'a children = 'a PT.t
- let null_wf = ()
- let null_coupling = ()
- let fuse () _ = ()
- let wf_to_string () = None
- let coupling_to_string () = None
- end
-
-(* \begin{dubious}
- Here's a simple additive tag that can grow into something useful
- for loop calculations.
- \end{dubious} *)
-
-module Loop_Tags (PT : Tuple.Poly) =
- struct
- type wf = int
- type coupling = int
- type 'a children = 'a PT.t
- let null_wf = 0
- let null_coupling = 0
- let fuse c wfs = PT.fold_left (+) c wfs
- let wf_to_string n = Some (string_of_int n)
- let coupling_to_string n = Some (string_of_int n)
- end
+(* \thocwmodulesection{The [Fusion.Make] Functor} *)
-module Order_Tags (PT : Tuple.Poly) =
- struct
- type wf = int
- type coupling = int
- type 'a children = 'a PT.t
- let null_wf = 0
- let null_coupling = 0
- let fuse c wfs = PT.fold_left (+) c wfs
- let wf_to_string n = Some (string_of_int n)
- let coupling_to_string n = Some (string_of_int n)
- end
-
-(* \thocwmodulesection{[Tagged], the [Fusion.Make] Functor} *)
-
-module Tagged (Tagger : Tagger) (PT : Tuple.Poly)
+module Make (PT : Tuple.Poly)
(Stat : Stat_Maker) (T : Topology.T with type 'a children = 'a PT.t)
(P : Momentum.T) (M : Model.T) =
struct
let vintage = true
type cache_mode = Cache_Use | Cache_Ignore | Cache_Overwrite
let cache_option = ref Cache_Ignore
type qcd_order =
| QCD_order of int
type ew_order =
| EW_order of int
let qcd_order = ref (QCD_order 99)
let ew_order = ref (EW_order 99)
let options = Options.create
[
(*i
"ignore-cache", Arg.Unit (fun () -> cache_option := Cache_Ignore),
" ignore cached model tables (default)";
"use-cache", Arg.Unit (fun () -> cache_option := Cache_Use),
" use cached model tables";
"overwrite-cache", Arg.Unit (fun () -> cache_option := Cache_Overwrite),
" overwrite cached model tables";
i*)
"qcd", Arg.Int (fun n -> qcd_order := QCD_order n),
" set QCD order n [>= 0, default = 99] (ignored)";
"ew", Arg.Int (fun n -> ew_order := EW_order n),
" set QCD order n [>=0, default = 99] (ignored)"]
exception Negative_QCD_order
exception Negative_EW_order
exception Vanishing_couplings
exception Negative_QCD_EW_orders
let int_orders =
match !qcd_order, !ew_order with
| QCD_order n, EW_order n' when n < 0 && n' >= 0 ->
raise Negative_QCD_order
| QCD_order n, EW_order n' when n >= 0 && n' < 0 ->
raise Negative_EW_order
| QCD_order n, EW_order n' when n < 0 && n' < 0 ->
raise Negative_QCD_EW_orders
| QCD_order n, EW_order n' -> (n, n')
open Coupling
module S = Stat(M)
type stat = S.stat
let stat = S.stat
let stat_sign = S.stat_sign
(* \begin{dubious}
This will do \emph{something} for 4-, 6-, \ldots fermion vertices,
but not necessarily the right thing \ldots
\end{dubious} *)
let stat_fuse s f =
PT.fold_right_internal (fun s' acc -> S.stat_fuse s' acc f) s
type constant = M.constant
(* \thocwmodulesubsection{Wave Functions} *)
(* \begin{dubious}
The code below is not yet functional. Too often, we assign to
[Tags.null_wf] instead of calling [Tags.fuse].
\end{dubious} *)
(* We will need two types of amplitudes: with color and without color. Since
we can build them using the same types with only [flavor] replaced, it pays
to use a functor to set up the scaffolding. *)
- module Tags = Tagger(PT)
-
(* In the future, we might want to have [Coupling] among the functor
arguments. However, for the moment, [Coupling] is assumed to be
comprehensive. *)
- module type Tagged_Coupling =
+ module type Signed_Coupling =
sig
type sign = int
type t =
{ sign : sign;
- coupling : constant Coupling.t;
- coupling_tag : Tags.coupling }
+ coupling : constant Coupling.t }
val sign : t -> sign
val coupling : t -> constant Coupling.t
- val coupling_tag : t -> string option
end
- module Tagged_Coupling : Tagged_Coupling =
+ module Signed_Coupling : Signed_Coupling =
struct
type sign = int
type t =
{ sign : sign;
- coupling : constant Coupling.t;
- coupling_tag : Tags.coupling }
+ coupling : constant Coupling.t }
let sign c = c.sign
let coupling c = c.coupling
- let coupling_tag_raw c = c.coupling_tag
- let coupling_tag rhs = Tags.coupling_to_string (coupling_tag_raw rhs)
end
(* \thocwmodulesubsection{Amplitudes: Monochrome and Colored} *)
module type Amplitude =
sig
- module Tags : Tags
-
type flavor
type p
type wf =
{ flavor : flavor;
- momentum : p;
- wf_tag : Tags.wf }
+ momentum : p }
val flavor : wf -> flavor
val conjugate : wf -> wf
val momentum : wf -> p
val momentum_list : wf -> int list
- val wf_tag : wf -> string option
- val wf_tag_raw : wf -> Tags.wf
val order_wf : wf -> wf -> int
val external_wfs : int -> (flavor * int) list -> wf list
type 'a children
- type coupling = Tagged_Coupling.t
+ type coupling = Signed_Coupling.t
type rhs = coupling * wf children
val sign : rhs -> int
val coupling : rhs -> constant Coupling.t
- val coupling_tag : rhs -> string option
- type exclusions
- val no_exclusions : exclusions
val children : rhs -> wf list
type fusion = wf * rhs list
val lhs : fusion -> wf
val rhs : fusion -> rhs list
type braket = wf * rhs list
val bra : braket -> wf
val ket : braket -> rhs list
module D :
DAG.T with type node = wf and type edge = coupling and type children = wf children
val wavefunctions : braket list -> wf list
+ type 'a slices
+ val unsliced : 'a -> 'a slices
+
type amplitude =
{ fusions : fusion list;
- brakets : braket list;
+ brakets : braket list slices;
on_shell : (wf -> bool);
is_gauss : (wf -> bool);
constraints : string option;
+ slicings : string list;
incoming : flavor list;
outgoing : flavor list;
externals : wf list;
symmetry : int;
dependencies : (wf -> (wf, coupling) Tree2.t);
fusion_tower : D.t;
fusion_dag : D.t }
val incoming : amplitude -> flavor list
val outgoing : amplitude -> flavor list
val externals : amplitude -> wf list
val variables : amplitude -> wf list
val fusions : amplitude -> fusion list
- val brakets : amplitude -> braket list
+ val brakets : amplitude -> braket list slices
val on_shell : amplitude -> (wf -> bool)
val is_gauss : amplitude -> (wf -> bool)
val constraints : amplitude -> string option
+ val slicings : amplitude -> string list
val symmetry : amplitude -> int
val dependencies : amplitude -> wf -> (wf, coupling) Tree2.t
val fusion_dag : amplitude -> D.t
end
- module Amplitude (PT : Tuple.Poly) (P : Momentum.T) (M : Model.T) :
+ module type Slicer =
+ sig
+ type 'a t
+ val all : 'a -> 'a t
+ end
+
+ module Unsliced =
+ struct
+ type 'a t = 'a
+ let all a = a
+ end
+
+ module Amplitude (PT : Tuple.Poly) (P : Momentum.T) (M : Model.T) (S : Slicer) :
Amplitude
with type p = P.t
and type flavor = M.flavor
and type 'a children = 'a PT.t
- and module Tags = Tags =
+ and type 'a slices = 'a S.t =
struct
type flavor = M.flavor
type p = P.t
- module Tags = Tags
-
type wf =
{ flavor : flavor;
- momentum : p;
- wf_tag : Tags.wf }
+ momentum : p }
let flavor wf = wf.flavor
let conjugate wf = { wf with flavor = M.conjugate wf.flavor }
let momentum wf = wf.momentum
let momentum_list wf = P.to_ints wf.momentum
- let wf_tag wf = Tags.wf_to_string wf.wf_tag
- let wf_tag_raw wf = wf.wf_tag
let external_wfs rank particles =
List.map
(fun (f, p) ->
{ flavor = f;
- momentum = P.singleton rank p;
- wf_tag = Tags.null_wf })
+ momentum = P.singleton rank p })
particles
(* Order wavefunctions so that the external come first, then the pairs, etc.
Also put possible Goldstone bosons \emph{before} their gauge bosons. *)
let lorentz_ordering f =
match M.lorentz f with
| Coupling.Scalar -> 0
| Coupling.Spinor -> 1
| Coupling.ConjSpinor -> 2
| Coupling.Majorana -> 3
| Coupling.Vector -> 4
| Coupling.Massive_Vector -> 5
| Coupling.Tensor_2 -> 6
| Coupling.Tensor_1 -> 7
| Coupling.Vectorspinor -> 8
| Coupling.BRS Coupling.Scalar -> 9
| Coupling.BRS Coupling.Spinor -> 10
| Coupling.BRS Coupling.ConjSpinor -> 11
| Coupling.BRS Coupling.Majorana -> 12
| Coupling.BRS Coupling.Vector -> 13
| Coupling.BRS Coupling.Massive_Vector -> 14
| Coupling.BRS Coupling.Tensor_2 -> 15
| Coupling.BRS Coupling.Tensor_1 -> 16
| Coupling.BRS Coupling.Vectorspinor -> 17
| Coupling.BRS _ -> invalid_arg "Fusion.lorentz_ordering: not needed"
| Coupling.Maj_Ghost -> 18
(*i | Coupling.Ward_Vector -> 19 i*)
let order_flavor f1 f2 =
let c = compare (lorentz_ordering f1) (lorentz_ordering f2) in
if c <> 0 then
c
else
compare f1 f2
(* Note that [Momentum().compare] guarantees that wavefunctions will be
ordered according to \emph{increasing} [Momentum().rank] of their
momenta. *)
let order_wf wf1 wf2 =
let c = P.compare wf1.momentum wf2.momentum in
if c <> 0 then
c
else
- let c = order_flavor wf1.flavor wf2.flavor in
- if c <> 0 then
- c
- else
- compare wf1.wf_tag wf2.wf_tag
+ order_flavor wf1.flavor wf2.flavor
(* This \emph{must} be a pair matching the [edge * node children] pairs of
[DAG.Forest]! *)
- type coupling = Tagged_Coupling.t
+ type coupling = Signed_Coupling.t
type 'a children = 'a PT.t
type rhs = coupling * wf children
- let sign (c, _) = Tagged_Coupling.sign c
- let coupling (c, _) = Tagged_Coupling.coupling c
- let coupling_tag (c, _) = Tagged_Coupling.coupling_tag c
- type exclusions =
- { x_flavors : flavor list;
- x_couplings : coupling list }
- let no_exclusions = { x_flavors = []; x_couplings = [] }
+ let sign (c, _) = Signed_Coupling.sign c
+ let coupling (c, _) = Signed_Coupling.coupling c
let children (_, wfs) = PT.to_list wfs
type fusion = wf * rhs list
let lhs (l, _) = l
let rhs (_, r) = r
type braket = wf * rhs list
let bra (b, _) = b
let ket (_, k) = k
module D = DAG.Make
(DAG.Forest(PT)
(struct type t = wf let compare = order_wf end)
(struct type t = coupling let compare = compare end))
module WFSet =
Set.Make (struct type t = wf let compare = order_wf end)
let wavefunctions brakets =
WFSet.elements (List.fold_left (fun set (wf1, wf23) ->
WFSet.add wf1 (List.fold_left (fun set' (_, wfs) ->
PT.fold_right WFSet.add wfs set') set wf23)) WFSet.empty brakets)
+ type 'a slices = 'a S.t
+ let unsliced a = S.all a
+
type amplitude =
{ fusions : fusion list;
- brakets : braket list;
+ brakets : braket list slices;
on_shell : (wf -> bool);
is_gauss : (wf -> bool);
constraints : string option;
+ slicings : string list;
incoming : flavor list;
outgoing : flavor list;
externals : wf list;
symmetry : int;
dependencies : (wf -> (wf, coupling) Tree2.t);
fusion_tower : D.t;
fusion_dag : D.t }
let incoming a = a.incoming
let outgoing a = a.outgoing
let externals a = a.externals
let fusions a = a.fusions
let brakets a = a.brakets
let symmetry a = a.symmetry
let on_shell a = a.on_shell
let is_gauss a = a.is_gauss
let constraints a = a.constraints
+ let slicings a = a.slicings
let variables a = List.map lhs a.fusions
let dependencies a = a.dependencies
let fusion_dag a = a.fusion_dag
end
- module A = Amplitude(PT)(P)(M)
+ module A = Amplitude(PT)(P)(M)(Unsliced)
(* Operator insertions can be fused only if they are external. *)
let is_source wf =
match M.propagator wf.A.flavor with
| Only_Insertion -> P.rank wf.A.momentum = 1
| _ -> true
(* [is_goldstone_of g v] is [true] if and only if [g] is the Goldstone boson
corresponding to the gauge particle [v]. *)
let is_goldstone_of g v =
match M.goldstone v with
| None -> false
| Some (g', _) -> g = g'
(* \begin{dubious}
In the end, [PT.to_list] should become redudant!
\end{dubious} *)
let fuse_rhs rhs = M.fuse (PT.to_list rhs)
(* \thocwmodulesubsection{Vertices} *)
(* Compute the set of all vertices in the model from the allowed
fusions and the set of all flavors:
\begin{dubious}
One could think of using [M.vertices] instead of [M.fuse2],
[M.fuse3] and [M.fuse] \ldots
\end{dubious} *)
module VSet = Map.Make(struct type t = A.flavor let compare = compare end)
let add_vertices f rhs m =
VSet.add f (try rhs :: VSet.find f m with Not_found -> [rhs]) m
let collect_vertices rhs =
List.fold_right (fun (f1, c) -> add_vertices (M.conjugate f1) (c, rhs))
(fuse_rhs rhs)
(* The set of all vertices with common left fields factored. *)
(* I used to think that constant initializers are a good idea to allow
compile time optimizations. The down side turned out to be that the
constant initializers will be evaluated \emph{every time} the functor
is applied. \emph{Relying on the fact that the functor will be
called only once is not a good idea!} *)
type vertices = (A.flavor * (constant Coupling.t * A.flavor PT.t) list) list
let vertices_nocache max_degree flavors : vertices =
VSet.fold (fun f rhs v -> (f, rhs) :: v)
(PT.power_fold collect_vertices flavors VSet.empty) []
(* Performance hack: *)
type vertex_table =
((A.flavor * A.flavor * A.flavor) * constant Coupling.vertex3 * constant) list
* ((A.flavor * A.flavor * A.flavor * A.flavor)
* constant Coupling.vertex4 * constant) list
* (A.flavor list * constant Coupling.vertexn * constant) list
(*i
module VCache =
Cache.Make (struct type t = vertex_table end) (struct type t = vertices end)
let vertices_cache = ref None
let hash () = VCache.hash (M.vertices ())
(* \begin{dubious}
Can we do better than the executable name provided by [Config.cache_prefix]???
We need a better way to avoid collisions among the caches for different models
in the same program.
\end{dubious} *)
let cache_name =
ref (Config.cache_prefix ^ "." ^ Config.cache_suffix)
let set_cache_name name =
cache_name := name
let initialize_cache dir =
Printf.eprintf
" >>> Initializing vertex table %s. This may take some time ... "
!cache_name;
flush stderr;
VCache.write_dir (hash ()) dir !cache_name
(vertices_nocache (M.max_degree ()) (M.flavors()));
Printf.eprintf "done. <<< \n"
let vertices max_degree flavors : vertices =
match !vertices_cache with
| None ->
begin match !cache_option with
| Cache_Use ->
begin match VCache.maybe_read (hash ()) !cache_name with
| VCache.Hit result -> result
| VCache.Miss ->
Printf.eprintf
" >>> Initializing vertex table %s. This may take some time ... "
!cache_name;
flush stderr;
let result = vertices_nocache max_degree flavors in
VCache.write (hash ()) !cache_name (result);
vertices_cache := Some result;
Printf.eprintf "done. <<< \n";
flush stderr;
result
| VCache.Stale file ->
Printf.eprintf
" >>> Re-initializing stale vertex table %s in file %s. "
!cache_name file;
Printf.eprintf "This may take some time ... ";
flush stderr;
let result = vertices_nocache max_degree flavors in
VCache.write (hash ()) !cache_name (result);
vertices_cache := Some result;
Printf.eprintf "done. <<< \n";
flush stderr;
result
end
| Cache_Overwrite ->
Printf.eprintf
" >>> Overwriting vertex table %s. This may take some time ... "
!cache_name;
flush stderr;
let result = vertices_nocache max_degree flavors in
VCache.write (hash ()) !cache_name (result);
vertices_cache := Some result;
Printf.eprintf "done. <<< \n";
flush stderr;
result
| Cache_Ignore ->
let result = vertices_nocache max_degree flavors in
vertices_cache := Some result;
result
end
| Some result -> result
i*)
let vertices = vertices_nocache
(* Note that we must perform any filtering of the vertices \emph{after}
caching, because the restrictions \emph{must not} influence the
cache (unless we tag the cache with model and restrictions). *)
(*i
let unpack_constant = function
| Coupling.V3 (_, _, cs) -> cs
| Coupling.V4 (_, _, cs) -> cs
| Coupling.Vn (_, _, cs) -> cs
let coupling_and_flavors_to_string (c, fs) =
M.constant_symbol (unpack_constant c) ^ "[" ^
String.concat ", " (List.map M.flavor_to_string (PT.to_list fs)) ^ "]"
let fusions_to_string (f, cfs) =
M.flavor_to_string f ^ " <- { " ^
String.concat " | " (List.map coupling_and_flavors_to_string cfs) ^
" }"
let vertices_to_string vertices =
String.concat "; " (List.map fusions_to_string vertices)
i*)
let filter_vertices select_vtx vertices =
List.fold_left
(fun acc (f, cfs) ->
let f' = M.conjugate f in
let cfs =
List.filter
(fun (c, fs) -> select_vtx c f' (PT.to_list fs))
cfs
in
match cfs with
| [] -> acc
| cfs -> (f, cfs) :: acc)
[] vertices
(* \thocwmodulesubsection{Partitions} *)
(* Vertices that are not crossing invariant need special treatment so
that they're only generated for the correct combinations of momenta.
NB: the [crossing] checks here are a bit redundant, because [CM.fuse] below
will bring the killed vertices back to life and will have to filter once more.
Nevertheless, we keep them here, for the unlikely case that anybody ever wants
to use uncolored amplitudes directly.
NB: the analogous problem does not occur for [select_wf], because this applies
to momenta instead of vertices. *)
(* \begin{dubious}
This approach worked before the colorize, but has become \emph{futile},
because [CM.fuse] will bring the killed vertices back to life. We need
to implement the same checks there again!!!
\end{dubious} *)
(* \begin{dubious}
Using [PT.Mismatched_arity] is not really good style \ldots
Tho's approach doesn't work since he does not catch charge conjugated processes or
crossed processes. Another very strange thing is that O'Mega seems always to run in the
q2 q3 timelike case, but not in the other two. (Property of how the DAG is built?).
For the $ZZZZ$ vertex I add the same vertex again, but interchange 1 and 3 in the
[crossing] vertex
\end{dubious} *)
let kmatrix_cuts c momenta =
match c with
| V4 (Vector4_K_Matrix_tho (disc, _), fusion, _)
| V4 (Vector4_K_Matrix_jr (disc, _), fusion, _) ->
let s12, s23, s13 =
begin match PT.to_list momenta with
| [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2),
P.Scattering.timelike (P.add q2 q3),
P.Scattering.timelike (P.add q1 q3))
| _ -> raise PT.Mismatched_arity
end in
begin match disc, s12, s23, s13, fusion with
| 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214)
| 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421)
| 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) ->
true
| 1, true, false, false, (F341|F431|F342|F432)
| 1, false, true, false, (F134|F143|F234|F243)
| 1, false, false, true, (F314|F413|F324|F423) ->
true
| 2, true, false, false, (F123|F213|F124|F214)
| 2, false, true, false, (F312|F321|F412|F421)
| 2, false, false, true, (F132|F231|F142|F241) ->
true
| 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234)
| 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423)
| 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) ->
true
| _ -> false
end
| V4 (Vector4_K_Matrix_cf_t0 (disc, _), fusion, _) ->
let s12, s23, s13 =
begin match PT.to_list momenta with
| [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2),
P.Scattering.timelike (P.add q2 q3),
P.Scattering.timelike (P.add q1 q3))
| _ -> raise PT.Mismatched_arity
end in
begin match disc, s12, s23, s13, fusion with
| 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214)
| 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421)
| 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) ->
true
| 1, true, false, false, (F341|F431|F342|F432)
| 1, false, true, false, (F134|F143|F234|F243)
| 1, false, false, true, (F314|F413|F324|F423) ->
true
| 2, true, false, false, (F123|F213|F124|F214)
| 2, false, true, false, (F312|F321|F412|F421)
| 2, false, false, true, (F132|F231|F142|F241) ->
true
| 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234)
| 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423)
| 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) ->
true
| _ -> false
end
| V4 (Vector4_K_Matrix_cf_t1 (disc, _), fusion, _) ->
let s12, s23, s13 =
begin match PT.to_list momenta with
| [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2),
P.Scattering.timelike (P.add q2 q3),
P.Scattering.timelike (P.add q1 q3))
| _ -> raise PT.Mismatched_arity
end in
begin match disc, s12, s23, s13, fusion with
| 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214)
| 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421)
| 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) ->
true
| 1, true, false, false, (F341|F431|F342|F432)
| 1, false, true, false, (F134|F143|F234|F243)
| 1, false, false, true, (F314|F413|F324|F423) ->
true
| 2, true, false, false, (F123|F213|F124|F214)
| 2, false, true, false, (F312|F321|F412|F421)
| 2, false, false, true, (F132|F231|F142|F241) ->
true
| 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234)
| 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423)
| 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) ->
true
| _ -> false
end
| V4 (Vector4_K_Matrix_cf_t2 (disc, _), fusion, _) ->
let s12, s23, s13 =
begin match PT.to_list momenta with
| [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2),
P.Scattering.timelike (P.add q2 q3),
P.Scattering.timelike (P.add q1 q3))
| _ -> raise PT.Mismatched_arity
end in
begin match disc, s12, s23, s13, fusion with
| 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214)
| 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421)
| 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) ->
true
| 1, true, false, false, (F341|F431|F342|F432)
| 1, false, true, false, (F134|F143|F234|F243)
| 1, false, false, true, (F314|F413|F324|F423) ->
true
| 2, true, false, false, (F123|F213|F124|F214)
| 2, false, true, false, (F312|F321|F412|F421)
| 2, false, false, true, (F132|F231|F142|F241) ->
true
| 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234)
| 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423)
| 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) ->
true
| _ -> false
end
| V4 (Vector4_K_Matrix_cf_t_rsi (disc, _), fusion, _) ->
let s12, s23, s13 =
begin match PT.to_list momenta with
| [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2),
P.Scattering.timelike (P.add q2 q3),
P.Scattering.timelike (P.add q1 q3))
| _ -> raise PT.Mismatched_arity
end in
begin match disc, s12, s23, s13, fusion with
| 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214)
| 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421)
| 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) ->
true
| 1, true, false, false, (F341|F431|F342|F432)
| 1, false, true, false, (F134|F143|F234|F243)
| 1, false, false, true, (F314|F413|F324|F423) ->
true
| 2, true, false, false, (F123|F213|F124|F214)
| 2, false, true, false, (F312|F321|F412|F421)
| 2, false, false, true, (F132|F231|F142|F241) ->
true
| 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234)
| 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423)
| 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) ->
true
| _ -> false
end
| V4 (Vector4_K_Matrix_cf_m0 (disc, _), fusion, _) ->
let s12, s23, s13 =
begin match PT.to_list momenta with
| [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2),
P.Scattering.timelike (P.add q2 q3),
P.Scattering.timelike (P.add q1 q3))
| _ -> raise PT.Mismatched_arity
end in
begin match disc, s12, s23, s13, fusion with
| 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214)
| 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421)
| 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) ->
true
| 1, true, false, false, (F341|F431|F342|F432)
| 1, false, true, false, (F134|F143|F234|F243)
| 1, false, false, true, (F314|F413|F324|F423) ->
true
| 2, true, false, false, (F123|F213|F124|F214)
| 2, false, true, false, (F312|F321|F412|F421)
| 2, false, false, true, (F132|F231|F142|F241) ->
true
| 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234)
| 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423)
| 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) ->
true
| _ -> false
end
| V4 (Vector4_K_Matrix_cf_m1 (disc, _), fusion, _) ->
let s12, s23, s13 =
begin match PT.to_list momenta with
| [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2),
P.Scattering.timelike (P.add q2 q3),
P.Scattering.timelike (P.add q1 q3))
| _ -> raise PT.Mismatched_arity
end in
begin match disc, s12, s23, s13, fusion with
| 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214)
| 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421)
| 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) ->
true
| 1, true, false, false, (F341|F431|F342|F432)
| 1, false, true, false, (F134|F143|F234|F243)
| 1, false, false, true, (F314|F413|F324|F423) ->
true
| 2, true, false, false, (F123|F213|F124|F214)
| 2, false, true, false, (F312|F321|F412|F421)
| 2, false, false, true, (F132|F231|F142|F241) ->
true
| 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234)
| 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423)
| 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) ->
true
| _ -> false
end
| V4 (Vector4_K_Matrix_cf_m7 (disc, _), fusion, _) ->
let s12, s23, s13 =
begin match PT.to_list momenta with
| [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2),
P.Scattering.timelike (P.add q2 q3),
P.Scattering.timelike (P.add q1 q3))
| _ -> raise PT.Mismatched_arity
end in
begin match disc, s12, s23, s13, fusion with
| 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214)
| 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421)
| 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) ->
true
| 1, true, false, false, (F341|F431|F342|F432)
| 1, false, true, false, (F134|F143|F234|F243)
| 1, false, false, true, (F314|F413|F324|F423) ->
true
| 2, true, false, false, (F123|F213|F124|F214)
| 2, false, true, false, (F312|F321|F412|F421)
| 2, false, false, true, (F132|F231|F142|F241) ->
true
| 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234)
| 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423)
| 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) ->
true
| _ -> false
end
| V4 (DScalar2_Vector2_K_Matrix_ms (disc, _), fusion, _) ->
let s12, s23, s13 =
begin match PT.to_list momenta with
| [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2),
P.Scattering.timelike (P.add q2 q3),
P.Scattering.timelike (P.add q1 q3))
| _ -> raise PT.Mismatched_arity
end in
begin match disc, s12, s23, s13, fusion with
| 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214)
| 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421)
| 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) ->
true
| 1, true, false, false, (F341|F432|F123|F214)
| 1, false, true, false, (F134|F243|F312|F421)
| 1, false, false, true, (F314|F423|F132|F241) ->
true
| 2, true, false, false, (F431|F342|F213|F124)
| 2, false, true, false, (F143|F234|F321|F412)
| 2, false, false, true, (F413|F324|F231|F142) ->
true
| 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234)
| 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423)
| 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) ->
true
| 4, true, false, false, (F142|F413|F231|F324)
| 4, false, true, false, (F214|F341|F123|F432)
| 4, false, false, true, (F124|F431|F213|F342) ->
true
| 5, true, false, false, (F143|F412|F321|F234)
| 5, false, true, false, (F314|F241|F132|F423)
| 5, false, false, true, (F134|F421|F312|F243) ->
true
| 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423)
| 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342)
| 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) ->
true
| 7, true, false, false, (F134|F312|F421|F243)
| 7, false, true, false, (F413|F231|F142|F324)
| 7, false, false, true, (F143|F321|F412|F432) ->
true
| 8, true, false, false, (F132|F314|F241|F423)
| 8, false, true, false, (F213|F431|F124|F342)
| 8, false, false, true, (F123|F341|F214|F234) ->
true
| _ -> false
end
| V4 (DScalar2_Vector2_m_0_K_Matrix_cf (disc, _), fusion, _) ->
let s12, s23, s13 =
begin match PT.to_list momenta with
| [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2),
P.Scattering.timelike (P.add q2 q3),
P.Scattering.timelike (P.add q1 q3))
| _ -> raise PT.Mismatched_arity
end in
begin match disc, s12, s23, s13, fusion with
| 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214)
| 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421)
| 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) ->
true
| 1, true, false, false, (F341|F432|F123|F214)
| 1, false, true, false, (F134|F243|F312|F421)
| 1, false, false, true, (F314|F423|F132|F241) ->
true
| 2, true, false, false, (F431|F342|F213|F124)
| 2, false, true, false, (F143|F234|F321|F412)
| 2, false, false, true, (F413|F324|F231|F142) ->
true
| 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234)
| 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423)
| 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) ->
true
| 4, true, false, false, (F142|F413|F231|F324)
| 4, false, true, false, (F214|F341|F123|F432)
| 4, false, false, true, (F124|F431|F213|F342) ->
true
| 5, true, false, false, (F143|F412|F321|F234)
| 5, false, true, false, (F314|F241|F132|F423)
| 5, false, false, true, (F134|F421|F312|F243) ->
true
| 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423)
| 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342)
| 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) ->
true
| 7, true, false, false, (F134|F312|F421|F243)
| 7, false, true, false, (F413|F231|F142|F324)
| 7, false, false, true, (F143|F321|F412|F432) ->
true
| 8, true, false, false, (F132|F314|F241|F423)
| 8, false, true, false, (F213|F431|F124|F342)
| 8, false, false, true, (F123|F341|F214|F234) ->
true
| _ -> false
end
| V4 (DScalar2_Vector2_m_1_K_Matrix_cf (disc, _), fusion, _) ->
let s12, s23, s13 =
begin match PT.to_list momenta with
| [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2),
P.Scattering.timelike (P.add q2 q3),
P.Scattering.timelike (P.add q1 q3))
| _ -> raise PT.Mismatched_arity
end in
begin match disc, s12, s23, s13, fusion with
| 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214)
| 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421)
| 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) ->
true
| 1, true, false, false, (F341|F432|F123|F214)
| 1, false, true, false, (F134|F243|F312|F421)
| 1, false, false, true, (F314|F423|F132|F241) ->
true
| 2, true, false, false, (F431|F342|F213|F124)
| 2, false, true, false, (F143|F234|F321|F412)
| 2, false, false, true, (F413|F324|F231|F142) ->
true
| 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234)
| 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423)
| 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) ->
true
| 4, true, false, false, (F142|F413|F231|F324)
| 4, false, true, false, (F214|F341|F123|F432)
| 4, false, false, true, (F124|F431|F213|F342) ->
true
| 5, true, false, false, (F143|F412|F321|F234)
| 5, false, true, false, (F314|F241|F132|F423)
| 5, false, false, true, (F134|F421|F312|F243) ->
true
| 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423)
| 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342)
| 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) ->
true
| 7, true, false, false, (F134|F312|F421|F243)
| 7, false, true, false, (F413|F231|F142|F324)
| 7, false, false, true, (F143|F321|F412|F432) ->
true
| 8, true, false, false, (F132|F314|F241|F423)
| 8, false, true, false, (F213|F431|F124|F342)
| 8, false, false, true, (F123|F341|F214|F234) ->
true
| _ -> false
end
| V4 (DScalar2_Vector2_m_7_K_Matrix_cf (disc, _), fusion, _) ->
let s12, s23, s13 =
begin match PT.to_list momenta with
| [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2),
P.Scattering.timelike (P.add q2 q3),
P.Scattering.timelike (P.add q1 q3))
| _ -> raise PT.Mismatched_arity
end in
begin match disc, s12, s23, s13, fusion with
| 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214)
| 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421)
| 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) ->
true
| 1, true, false, false, (F341|F432|F123|F214)
| 1, false, true, false, (F134|F243|F312|F421)
| 1, false, false, true, (F314|F423|F132|F241) ->
true
| 2, true, false, false, (F431|F342|F213|F124)
| 2, false, true, false, (F143|F234|F321|F412)
| 2, false, false, true, (F413|F324|F231|F142) ->
true
| 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234)
| 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423)
| 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) ->
true
| 4, true, false, false, (F142|F413|F231|F324)
| 4, false, true, false, (F214|F341|F123|F432)
| 4, false, false, true, (F124|F431|F213|F342) ->
true
| 5, true, false, false, (F143|F412|F321|F234)
| 5, false, true, false, (F314|F241|F132|F423)
| 5, false, false, true, (F134|F421|F312|F243) ->
true
| 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423)
| 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342)
| 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) ->
true
| 7, true, false, false, (F134|F312|F421|F243)
| 7, false, true, false, (F413|F231|F142|F324)
| 7, false, false, true, (F143|F321|F412|F432) ->
true
| 8, true, false, false, (F132|F314|F241|F423)
| 8, false, true, false, (F213|F431|F124|F342)
| 8, false, false, true, (F123|F341|F214|F234) ->
true
| _ -> false
end
| V4 (DScalar4_K_Matrix_ms (disc, _), fusion, _) ->
let s12, s23, s13 =
begin match PT.to_list momenta with
| [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2),
P.Scattering.timelike (P.add q2 q3),
P.Scattering.timelike (P.add q1 q3))
| _ -> raise PT.Mismatched_arity
end in
begin match disc, s12, s23, s13, fusion with
| 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214)
| 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421)
| 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) ->
true
| 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234)
| 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423)
| 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) ->
true
| 4, true, false, false, (F142|F413|F231|F324)
| 4, false, true, false, (F214|F341|F123|F432)
| 4, false, false, true, (F124|F431|F213|F342) ->
true
| 5, true, false, false, (F143|F412|F321|F234)
| 5, false, true, false, (F314|F241|F132|F423)
| 5, false, false, true, (F134|F421|F312|F243) ->
true
| 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423)
| 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342)
| 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) ->
true
| 7, true, false, false, (F134|F312|F421|F243)
| 7, false, true, false, (F413|F231|F142|F324)
| 7, false, false, true, (F143|F321|F412|F432) ->
true
| 8, true, false, false, (F132|F314|F241|F423)
| 8, false, true, false, (F213|F431|F124|F342)
| 8, false, false, true, (F123|F341|F214|F234) ->
true
| _ -> false
end
| _ -> true
(* Counting QCD and EW orders. *)
let qcd_ew_check orders =
if fst (orders) <= fst (int_orders) &&
snd (orders) <= snd (int_orders) then
true
else
false
(* Match a set of flavors to a set of momenta. Form the direct product for
the lists of momenta two and three with the list of couplings and flavors
two and three. *)
let flavor_keystone select_p dim (f1, f23) (p1, p23) =
({ A.flavor = f1;
- A.momentum = P.of_ints dim p1;
- A.wf_tag = A.Tags.null_wf },
+ A.momentum = P.of_ints dim p1 },
Product.fold2 (fun (c, f) p acc ->
try
let p' = PT.map (P.of_ints dim) p in
if select_p (P.of_ints dim p1) (PT.to_list p') && kmatrix_cuts c p' then
(c, PT.map2 (fun f'' p'' -> { A.flavor = f'';
- A.momentum = p'';
- A.wf_tag = A.Tags.null_wf }) f p') :: acc
+ A.momentum = p'' }) f p') :: acc
else
acc
with
| PT.Mismatched_arity -> acc) f23 p23 [])
(*i
let cnt = ref 0
let gc_stat () =
let minor, promoted, major = Gc.counters () in
Printf.sprintf "(%12.0f, %12.0f, %12.0f)" minor promoted major
let flavor_keystone select_p n (f1, f23) (p1, p23) =
incr cnt;
Gc.set { (Gc.get()) with Gc.space_overhead = 20 };
Printf.eprintf "%6d@%8.1f: %s\n" !cnt (Sys.time ()) (gc_stat ());
flush stderr;
flavor_keystone select_p n (f1, f23) (p1, p23)
i*)
(* Produce all possible combinations of vertices (flavor keystones)
and momenta by forming the direct product. The semantically equivalent
[Product.list2 (flavor_keystone select_wf n) vertices keystones] with
\emph{subsequent} filtering would be a \emph{very bad} idea, because
a potentially huge intermediate list is built for large models.
E.\,g.~for the MSSM this would lead to non-termination by thrashing
for $2\to4$ processes on most PCs. *)
let flavor_keystones filter select_p dim vertices keystones =
Product.fold2 (fun v k acc ->
filter (flavor_keystone select_p dim v k) acc) vertices keystones []
(* Flatten the nested lists of vertices into a list of attached lines. *)
let flatten_keystones t =
ThoList.flatmap (fun (p1, p23) ->
p1 :: (ThoList.flatmap (fun (_, rhs) -> PT.to_list rhs) p23)) t
(* \thocwmodulesubsection{Subtrees} *)
(* Fuse a tuple of wavefunctions, keeping track of Fermi statistics.
Record only the the sign \emph{relative} to the children.
(The type annotation is only for documentation.) *)
let fuse select_wf select_vtx wfss : (A.wf * stat * A.rhs) list =
if PT.for_all (fun (wf, _) -> is_source wf) wfss then
try
let wfs, ss = PT.split wfss in
let flavors = PT.map A.flavor wfs
- and momenta = PT.map A.momentum wfs
-(*i and wf_tags = PT.map A.wf_tag_raw wfs i*) in
+ and momenta = PT.map A.momentum wfs in
let p = PT.fold_left_internal P.add momenta in
-(*i let wft = PT.fold_left Tags.fuse wf_tags in i*)
List.fold_left
(fun acc (f, c) ->
if select_wf f p (PT.to_list momenta)
&& select_vtx c f (PT.to_list flavors)
&& kmatrix_cuts c momenta then
let s = stat_fuse ss f in
let flip =
PT.fold_left (fun acc s' -> acc * stat_sign s') (stat_sign s) ss in
({ A.flavor = f;
- A.momentum = p;
- A.wf_tag = A.Tags.null_wf }, s,
- ({ Tagged_Coupling.sign = flip;
- Tagged_Coupling.coupling = c;
- Tagged_Coupling.coupling_tag = A.Tags.null_coupling }, wfs)) :: acc
+ A.momentum = p }, s,
+ ({ Signed_Coupling.sign = flip;
+ Signed_Coupling.coupling = c }, wfs)) :: acc
else
acc)
[] (fuse_rhs flavors)
with
| P.Duplicate _ | S.Impossible -> []
else
[]
(* \begin{dubious}
Eventually, the pairs of [tower] and [dag] in [fusion_tower']
below could and should be replaced by a graded [DAG]. This will
look like, but currently [tower] containts statistics information
that is missing from [dag]:
\begin{quote}
\verb+Type node = flavor * p is not compatible with type wf * stat+
\end{quote}
This should be easy to fix. However, replacing [type t = wf]
with [type t = wf * stat] is \emph{not} a good idea because the variable
[stat] makes it impossible to test for the existance of a particular
[wf] in a [DAG].
\end{dubious}
\begin{dubious}
In summary, it seems that [(wf * stat) list array * A.D.t] should be
replaced by [(wf -> stat) * A.D.t].
\end{dubious} *)
module GF =
struct
module Nodes =
struct
type t = A.wf
module G = struct type t = int let compare = compare end
let compare = A.order_wf
let rank wf = P.rank wf.A.momentum
end
module Edges = struct type t = A.coupling let compare = compare end
module F = DAG.Forest(PT)(Nodes)(Edges)
type node = Nodes.t
type edge = F.edge
type children = F.children
type t = F.t
let compare = F.compare
let for_all = F.for_all
let fold = F.fold
end
module D' = DAG.Graded(GF)
let tower_of_dag dag =
let _, max_rank = D'.min_max_rank dag in
Array.init max_rank (fun n -> D'.ranked n dag)
(* The function [fusion_tower']
recursively builds the tower of all fusions from bottom up to a chosen
level. The argument [tower] is an array of lists, where the $i$-th sublist
(counting from 0) represents all off shell wave functions depending on
$i+1$~momenta and their Fermistatistics.
\begin{equation}
\begin{aligned}
\Bigl\lbrack
& \{ \phi_1(p_1), \phi_2(p_2), \phi_3(p_3), \ldots \}, \\
& \{ \phi_{12}(p_1+p_2), \phi'_{12}(p_1+p_2), \ldots,
\phi_{13}(p_1+p_3), \ldots, \phi_{23}(p_2+p_3), \ldots \}, \\
& \ldots \\
& \{ \phi_{1\cdots n}(p_1+\cdots+p_n),
\phi'_{1\cdots n}(p_1+\cdots+p_n), \ldots \} \Bigr\rbrack
\end{aligned}
\end{equation}
The argument [dag] is a DAG representing all the fusions calculated so far.
NB: The outer array in [tower] is always very short, so we could also
have accessed a list with [List.nth]. Appending of new members at the
end brings no loss of performance. NB: the array is supposed to be
immutable. *)
(* The towers must be sorted so that the combinatorical functions can
make consistent selections.
\begin{dubious}
Intuitively, this seems to be correct. However, one could have
expected that no element appears twice and that this ordering is
not necessary \ldots
\end{dubious} *)
let grow select_wf select_vtx tower =
let rank = succ (Array.length tower) in
- List.sort pcompare
+ List.sort Stdlib.compare
(PT.graded_sym_power_fold rank
(fun wfs acc -> fuse select_wf select_vtx wfs @ acc) tower [])
let add_offspring dag (wf, _, rhs) =
A.D.add_offspring wf rhs dag
let filter_offspring fusions =
List.map (fun (wf, s, _) -> (wf, s)) fusions
let rec fusion_tower' n_max select_wf select_vtx tower dag : (A.wf * stat) list array * A.D.t =
if Array.length tower >= n_max then
(tower, dag)
else
let tower' = grow select_wf select_vtx tower in
fusion_tower' n_max select_wf select_vtx
(Array.append tower [|filter_offspring tower'|])
(List.fold_left add_offspring dag tower')
(* Discard the tower and return a map from wave functions to Fermistatistics
together with the DAG. *)
let make_external_dag wfs =
List.fold_left (fun m (wf, _) -> A.D.add_node wf m) A.D.empty wfs
let mixed_fold_left f acc lists =
Array.fold_left (List.fold_left f) acc lists
module Stat_Map =
Map.Make (struct type t = A.wf let compare = A.order_wf end)
let fusion_tower height select_wf select_vtx wfs : (A.wf -> stat) * A.D.t =
let tower, dag =
fusion_tower' height select_wf select_vtx [|wfs|] (make_external_dag wfs) in
let stats = mixed_fold_left
(fun m (wf, s) -> Stat_Map.add wf s m) Stat_Map.empty tower in
((fun wf -> Stat_Map.find wf stats), dag)
(* Calculate the minimal tower of fusions that suffices for calculating
the amplitude. *)
let minimal_fusion_tower n select_wf select_vtx wfs : (A.wf -> stat) * A.D.t =
fusion_tower (T.max_subtree n) select_wf select_vtx wfs
(* Calculate the complete tower of fusions. It is much larger than required,
but it allows a complete set of gauge checks. *)
let complete_fusion_tower select_wf select_vtx wfs : (A.wf -> stat) * A.D.t =
fusion_tower (List.length wfs - 1) select_wf select_vtx wfs
(* \begin{dubious}
There is a natural product of two DAGs using [fuse]. Can this be
used in a replacement for [fusion_tower]? The hard part is to avoid
double counting, of course. A straight forward solution
could do a diagonal sum (in order to reject flipped offspring representing
the same fusion) and rely on the uniqueness in [DAG] otherwise.
However, this will (probably) slow down the procedure significanty,
because most fusions (including Fermi signs!) will be calculated before
being rejected by [DAG().add_offspring].
\end{dubious} *)
(* Add to [dag] all Goldstone bosons defined in [tower] that correspond
to gauge bosons in [dag]. This is only required for checking
Slavnov-Taylor identities in unitarity gauge. Currently, it is not used,
because we use the complete tower for gauge checking. *)
let harvest_goldstones tower dag =
A.D.fold_nodes (fun wf dag' ->
match M.goldstone wf.A.flavor with
| Some (g, _) ->
let wf' = { wf with A.flavor = g } in
if A.D.is_node wf' tower then begin
A.D.harvest tower wf' dag'
end else begin
dag'
end
| None -> dag') dag dag
(* Calculate the sign from Fermi statistics that is not already included
in the children.
\begin{dubious}
The use of [PT.of2_kludge] is the largest skeleton on the cupboard of
unified fusions. Currently, it is just another name for [PT.of2],
but the existence of the latter requires binary fusions. Of course, this
is just a symptom for not fully supporting four fermion vertices \ldots
\end{dubious} *)
let stat_keystone stats wf1 wfs =
let wf1' = stats wf1
and wfs' = PT.map stats wfs in
let stat =
stat_fuse
(PT.of2_kludge wf1' (stat_fuse wfs' (M.conjugate (A.flavor wf1))))
(A.flavor wf1) in
(*i Printf.eprintf "Fusion.stat_keystone: %s\n" (S.stat_to_string stat); i*)
stat_sign stat
* PT.fold_left (fun acc wf -> acc * stat_sign wf) (stat_sign wf1') wfs'
(* Test all members of a list of wave functions are defined by the DAG
simultaneously: *)
let test_rhs dag (_, wfs) =
PT.for_all (fun wf -> is_source wf && A.D.is_node wf dag) wfs
(* Add the keystone [(wf1,pairs)] to [acc] only if it is present in [dag]
and calculate the statistical factor depending on [stats]
\emph{en passant}: *)
let filter_keystone stats dag (wf1, pairs) acc =
if is_source wf1 && A.D.is_node wf1 dag then
match List.filter (test_rhs dag) pairs with
| [] -> acc
| pairs' -> (wf1, List.map (fun (c, wfs) ->
- ({ Tagged_Coupling.sign = stat_keystone stats wf1 wfs;
- Tagged_Coupling.coupling = c;
- Tagged_Coupling.coupling_tag = A.Tags.null_coupling },
+ ({ Signed_Coupling.sign = stat_keystone stats wf1 wfs;
+ Signed_Coupling.coupling = c },
wfs)) pairs') :: acc
else
acc
(* \begin{figure}
\begin{center}
\thocwincludegraphics{width=\textwidth}{bhabha0}\\
\hfil\\
\thocwincludegraphics{width=\textwidth}{bhabha}
\end{center}
\caption{\label{fig:bhabha}
The DAGs for Bhabha scattering before and after weeding out unused
nodes. The blatant asymmetry of these DAGs is caused by our
prescription for removing doubling counting for an even number
of external lines.}
\end{figure}
\begin{figure}
\begin{center}
\thocwincludegraphics{width=\textwidth}{epemudbarmunumubar0}\\
\hfil\\
\thocwincludegraphics{width=\textwidth}{epemudbarmunumubar}
\end{center}
\caption{\label{fig:epemudbarmunumubar}
The DAGs for $e^+e^-\to u\bar d \mu^-\bar\nu_\mu$ before and after
weeding out unused nodes.}
\end{figure}
\begin{figure}
\begin{center}
\thocwincludegraphics{width=\textwidth}{epemudbardubar0}\\
\hfil\\
\thocwincludegraphics{width=\textwidth}{epemudbardubar}
\end{center}
\caption{\label{fig:epemudbardubar}
The DAGs for $e^+e^-\to u\bar d d\bar u$ before and after weeding
out unused nodes.}
\end{figure} *)
(* \thocwmodulesubsection{Amplitudes} *)
module C = Cascade.Make(M)(P)
type selectors = C.selectors
+ type slicings = Orders.Conditions(Colorize.It(M)).t
let external_wfs n particles =
List.map (fun (f, p) ->
({ A.flavor = f;
- A.momentum = P.singleton n p;
- A.wf_tag = A.Tags.null_wf },
+ A.momentum = P.singleton n p },
stat f p)) particles
(* \thocwmodulesubsection{Main Function} *)
module WFMap = Map.Make (struct type t = A.wf let compare = compare end)
-(* [map_amplitude_wfs f a] applies the function [f : wf -> wf] to all
- wavefunctions appearing in the amplitude [a]. *)
- let map_amplitude_wfs f a =
- let map_rhs (c, wfs) = (c, PT.map f wfs) in
- let map_braket (wf, rhs) = (f wf, List.map map_rhs rhs)
- and map_fusion (lhs, rhs) = (f lhs, List.map map_rhs rhs) in
- let map_dag = A.D.map f (fun node rhs -> map_rhs rhs) in
- let tower = map_dag a.A.fusion_tower
- and dag = map_dag a.A.fusion_dag in
- let dependencies_map =
- A.D.fold (fun wf _ -> WFMap.add wf (A.D.dependencies dag wf)) dag WFMap.empty in
- { A.fusions = List.map map_fusion a.A.fusions;
- A.brakets = List.map map_braket a.A.brakets;
- A.on_shell = a.A.on_shell;
- A.is_gauss = a.A.is_gauss;
- A.constraints = a.A.constraints;
- A.incoming = a.A.incoming;
- A.outgoing = a.A.outgoing;
- A.externals = List.map f a.A.externals;
- A.symmetry = a.A.symmetry;
- A.dependencies = (fun wf -> WFMap.find wf dependencies_map);
- A.fusion_tower = tower;
- A.fusion_dag = dag }
-
-(*i
-(* \begin{dubious}
- Just a silly little test:
- \end{dubious} *)
-
- let hack_amplitude =
- map_amplitude_wfs (fun wf -> { wf with momentum = P.split 2 16 wf.momentum })
-i*)
-
(* This is the main function that constructs the amplitude for sets
of incoming and outgoing particles and returns the results in
conveniently packaged pieces. *)
let amplitude goldstones selectors fin fout =
(* Set up external lines and match flavors with numbered momenta. *)
let f = fin @ List.map M.conjugate fout in
let nin, nout = List.length fin, List.length fout in
let n = nin + nout in
let externals = List.combine f (ThoList.range 1 n) in
let wfs = external_wfs n externals in
let select_p = C.select_p selectors in
let select_wf =
match fin with
| [_] -> C.select_wf selectors P.Decay.timelike
| _ -> C.select_wf selectors P.Scattering.timelike in
let select_vtx = C.select_vtx selectors in
(* Build the full fusion tower (including nodes that are never
needed in the amplitude). *)
let stats, tower =
-
if goldstones then
complete_fusion_tower select_wf select_vtx wfs
else
minimal_fusion_tower n select_wf select_vtx wfs in
(* Find all vertices for which \emph{all} off shell wavefunctions
are defined by the tower. *)
-
let brakets =
flavor_keystones (filter_keystone stats tower) select_p n
(filter_vertices select_vtx
(vertices (M.max_degree ()) (M.flavors ())))
(T.keystones (ThoList.range 1 n)) in
(* Remove the part of the DAG that is never needed in the amplitude. *)
let dag =
if goldstones then
tower
else
A.D.harvest_list tower (A.wavefunctions brakets) in
(* Remove the leaf nodes of the DAG, corresponding to external lines. *)
let fusions =
List.filter (function (_, []) -> false | _ -> true) (A.D.lists dag) in
(* Calculate the symmetry factor for identical particles in the
final state. *)
let symmetry =
Combinatorics.symmetry fout in
let dependencies_map =
A.D.fold (fun wf _ -> WFMap.add wf (A.D.dependencies dag wf)) dag WFMap.empty in
(* Finally: package the results: *)
{ A.fusions = fusions;
A.brakets = brakets;
A.on_shell = (fun wf -> C.on_shell selectors (A.flavor wf) wf.A.momentum);
A.is_gauss = (fun wf -> C.is_gauss selectors (A.flavor wf) wf.A.momentum);
A.constraints = C.description selectors;
+ A.slicings = [];
A.incoming = fin;
A.outgoing = fout;
A.externals = List.map fst wfs;
A.symmetry = symmetry;
A.dependencies = (fun wf -> WFMap.find wf dependencies_map);
A.fusion_tower = tower;
A.fusion_dag = dag }
(* \thocwmodulesubsection{Color} *)
module CM = Colorize.It(M)
- module CA = Amplitude(PT)(P)(CM)
+ module CA = Amplitude(PT)(P)(CM)(Unsliced)
let colorize_wf flavor wf =
{ CA.flavor = flavor;
- CA.momentum = wf.A.momentum;
- CA.wf_tag = wf.A.wf_tag }
+ CA.momentum = wf.A.momentum }
let uncolorize_wf wf =
{ A.flavor = CM.flavor_sans_color wf.CA.flavor;
- A.momentum = wf.CA.momentum;
- A.wf_tag = wf.CA.wf_tag }
+ A.momentum = wf.CA.momentum }
(* \begin{dubious}
At the end of the day, I shall want to have some sort of
\textit{fibered DAG} as abstract data type, with a projection
of colored nodes to their uncolored counterparts.
\end{dubious} *)
module CWFBundle = Bundle.Make
(struct
type elt = CA.wf
let compare_elt = compare
type base = A.wf
let compare_base = compare
let pi wf =
{ A.flavor = CM.flavor_sans_color wf.CA.flavor;
- A.momentum = wf.CA.momentum;
- A.wf_tag = wf.CA.wf_tag }
+ A.momentum = wf.CA.momentum }
end)
(* \begin{dubious}
For now, we can live with simple aggregation:
\end{dubious} *)
type fibered_dag = { dag : CA.D.t; bundle : CWFBundle.t }
(* Not yet(?) needed: [module CS = Stat (CM)] *)
let colorize_sterile_nodes dag f wf fibered_dag =
if A.D.is_sterile wf dag then
let wf', wf_bundle' = f wf fibered_dag in
{ dag = CA.D.add_node wf' fibered_dag.dag;
bundle = wf_bundle' }
else
fibered_dag
let colorize_nodes f wf rhs fibered_dag =
let wf_rhs_list', wf_bundle' = f wf rhs fibered_dag in
let dag' =
List.fold_right
(fun (wf', rhs') -> CA.D.add_offspring wf' rhs')
wf_rhs_list' fibered_dag.dag in
{ dag = dag';
bundle = wf_bundle' }
(* O'Caml (correctly) infers the type
[val colorize_dag : (D.node -> D.edge * D.children -> fibered_dag ->
(CA.D.node * (CA.D.edge * CA.D.children)) list * CWFBundle.t) ->
(D.node -> fibered_dag -> CA.D.node * CWFBundle.t) ->
D.t -> CWFBundle.t -> fibered_dag]. *)
let colorize_dag f_node f_ext dag wf_bundle =
A.D.fold (colorize_nodes f_node) dag
(A.D.fold_nodes (colorize_sterile_nodes dag f_ext) dag
{ dag = CA.D.empty; bundle = wf_bundle })
let colorize_external wf fibered_dag =
- match CWFBundle.inv_pi wf fibered_dag.bundle with
+ match CWFBundle.inv_pi fibered_dag.bundle wf with
| [c_wf] -> (c_wf, fibered_dag.bundle)
| [] -> failwith "colorize_external: not found"
| _ -> failwith "colorize_external: not unique"
let fuse_c_wf rhs =
let momenta = PT.map (fun wf -> wf.CA.momentum) rhs in
List.filter
(fun (_, c) -> kmatrix_cuts c momenta)
(CM.fuse (List.map (fun wf -> wf.CA.flavor) (PT.to_list rhs)))
let colorize_coupling c coupling =
- { coupling with Tagged_Coupling.coupling = c }
+ { coupling with Signed_Coupling.coupling = c }
let colorize_fusion wf (coupling, children) fibered_dag =
let match_flavor (f, _) = (CM.flavor_sans_color f = A.flavor wf)
- and find_colored wf' = CWFBundle.inv_pi wf' fibered_dag.bundle in
+ and find_colored wf' = CWFBundle.inv_pi fibered_dag.bundle wf' in
let fusions =
ThoList.flatmap
(fun c_children ->
List.map
(fun (f, c) ->
(colorize_wf f wf, (colorize_coupling c coupling, c_children)))
(List.filter match_flavor (fuse_c_wf c_children)))
(PT.product (PT.map find_colored children)) in
let bundle =
- List.fold_right
- (fun (c_wf, _) -> CWFBundle.add c_wf)
- fusions fibered_dag.bundle in
+ List.fold_left
+ (fun acc (c_wf, _) -> CWFBundle.add acc c_wf)
+ fibered_dag.bundle fusions in
(fusions, bundle)
let colorize_braket1 (wf, (coupling, children)) fibered_dag =
- let find_colored wf' = CWFBundle.inv_pi wf' fibered_dag.bundle in
+ let find_colored wf' = CWFBundle.inv_pi fibered_dag.bundle wf' in
Product.fold2
(fun bra ket acc ->
List.fold_left
(fun brakets (f, c) ->
if CM.conjugate bra.CA.flavor = f then
(bra, (colorize_coupling c coupling, ket)) :: brakets
else
brakets)
acc (fuse_c_wf ket))
(find_colored wf) (PT.product (PT.map find_colored children)) []
module CWFMap =
Map.Make (struct type t = CA.wf let compare = CA.order_wf end)
module CKetSet =
Set.Make (struct type t = CA.rhs let compare = compare end)
(* Find a set of kets in [map] that belong to [bra].
Return the empty set, if nothing is found. *)
let lookup_ketset bra map =
try CWFMap.find bra map with Not_found -> CKetSet.empty
(* Return the set of kets belonging to [bra] in [map],
augmented by [ket]. *)
let addto_ketset bra ket map =
CKetSet.add ket (lookup_ketset bra map)
(* Augment or update [map] with a new [(bra, ket)] relation. *)
let addto_ketset_map map (bra, ket) =
CWFMap.add bra (addto_ketset bra ket map) map
(* Take a list of [(bra, ket)] pairs and group the [ket]s
according to [bra]. This is very similar to
[ThoList.factorize] on page~\pageref{ThoList.factorize},
but the latter keeps duplicate copies, while we keep
only one, with equality determined by [CA.order_wf]. *)
(* \begin{dubious}
Isn't [Bundle]~\ref{Bundle} the correct framework for this?
\end{dubious} *)
let factorize_brakets brakets =
CWFMap.fold
(fun bra ket acc -> (bra, CKetSet.elements ket) :: acc)
(List.fold_left addto_ketset_map CWFMap.empty brakets)
[]
let colorize_braket (wf, rhs_list) fibered_dag =
factorize_brakets
(ThoList.flatmap
(fun rhs -> (colorize_braket1 (wf, rhs) fibered_dag))
rhs_list)
let colorize_amplitude a fin fout =
let f = fin @ List.map CM.conjugate fout in
let nin, nout = List.length fin, List.length fout in
let n = nin + nout in
let externals = List.combine f (ThoList.range 1 n) in
let external_wfs = CA.external_wfs n externals in
let wf_bundle = CWFBundle.of_list external_wfs in
let fibered_dag =
colorize_dag
colorize_fusion colorize_external a.A.fusion_dag wf_bundle in
let brakets =
ThoList.flatmap
(fun braket -> colorize_braket braket fibered_dag)
a.A.brakets in
let dag = CA.D.harvest_list fibered_dag.dag (CA.wavefunctions brakets) in
let fusions =
List.filter (function (_, []) -> false | _ -> true) (CA.D.lists dag) in
let dependencies_map =
CA.D.fold
(fun wf _ -> CWFMap.add wf (CA.D.dependencies dag wf))
dag CWFMap.empty in
{ CA.fusions = fusions;
CA.brakets = brakets;
CA.constraints = a.A.constraints;
+ CA.slicings = a.A.slicings;
CA.incoming = fin;
CA.outgoing = fout;
CA.externals = external_wfs;
CA.fusion_dag = dag;
CA.fusion_tower = dag;
CA.symmetry = a.A.symmetry;
CA.on_shell = (fun wf -> a.A.on_shell (uncolorize_wf wf));
CA.is_gauss = (fun wf -> a.A.is_gauss (uncolorize_wf wf));
CA.dependencies = (fun wf -> CWFMap.find wf dependencies_map) }
- let allowed amplitude =
- match amplitude.CA.brakets with
- | [] -> false
- | _ -> true
-
let colorize_amplitudes a =
List.fold_left
(fun amps (fin, fout) ->
let amp = colorize_amplitude a fin fout in
- if allowed amp then
- amp :: amps
- else
- amps)
+ match amp.CA.brakets with
+ | [] -> amps
+ | _ -> amp :: amps)
[] (CM.amplitude a.A.incoming a.A.outgoing)
- let amplitudes goldstones exclusions selectors fin fout =
+ let amplitudes_all_orders goldstones selectors fin fout =
colorize_amplitudes (amplitude goldstones selectors fin fout)
- let amplitude_sans_color goldstones exclusions selectors fin fout =
+ let amplitude_sans_color goldstones selectors fin fout =
amplitude goldstones selectors fin fout
- type flavor = CA.flavor
+ (* \thocwmodulesubsection{Fake Coupling Constant Slices} *)
+
+ (* For the benefit of [Targets], we also copy the amplitudes to
+ equivalent sliced amplitudes with empty coupling orders. This
+ way, we can use the same output routines for the sliced and
+ unsliced amplitudes. *)
+
+ module COC = Orders.Conditions(Colorize.It(M))
+ module SCM = Orders.Slice(Colorize.It(M))
+
+ module By_Orders =
+ struct
+ type orders = SCM.orders
+ type 'a t = (orders * 'a) list
+ let all a = [([], a)]
+ end
+
+
+ module SCA = Amplitude(PT)(P)(SCM)(By_Orders)
+ type 'a slices = 'a SCA.slices
+
+ type flavor = SCA.flavor
+ type flavor_all_orders = CA.flavor
type flavor_sans_color = A.flavor
type p = A.p
- type wf = CA.wf
- let conjugate = CA.conjugate
- let flavor = CA.flavor
- let flavor_sans_color wf = CM.flavor_sans_color (CA.flavor wf)
- let momentum = CA.momentum
- let momentum_list = CA.momentum_list
- let wf_tag = CA.wf_tag
-
- type coupling = CA.coupling
-
- let sign = CA.sign
- let coupling = CA.coupling
- let coupling_tag = CA.coupling_tag
- type exclusions = CA.exclusions
- let no_exclusions = CA.no_exclusions
-
- type 'a children = 'a CA.children
- type rhs = CA.rhs
- let children = CA.children
-
- type fusion = CA.fusion
- let lhs = CA.lhs
- let rhs = CA.rhs
-
- type braket = CA.braket
- let bra = CA.bra
- let ket = CA.ket
+ type wf = SCA.wf
+ let conjugate = SCA.conjugate
+ let flavor = SCA.flavor
+ let flavor_sans_color wf = SCM.flavor_sans_color (SCA.flavor wf)
+ let flavor_all_orders wf = SCM.flavor_all_orders (SCA.flavor wf)
+ let momentum = SCA.momentum
+ let momentum_list = SCA.momentum_list
+
+ type coupling = SCA.coupling
+
+ let sign = SCA.sign
+ let coupling = SCA.coupling
+
+ type 'a children = 'a SCA.children
+ type rhs = SCA.rhs
+ let children = SCA.children
+
+ type fusion = SCA.fusion
+ let lhs = SCA.lhs
+ let rhs = SCA.rhs
+
+ type braket = SCA.braket
+ let bra = SCA.bra
+ let ket = SCA.ket
- type amplitude = CA.amplitude
+ type amplitude = SCA.amplitude
type amplitude_sans_color = A.amplitude
- let incoming = CA.incoming
- let outgoing = CA.outgoing
- let externals = CA.externals
- let fusions = CA.fusions
- let brakets = CA.brakets
- let symmetry = CA.symmetry
- let on_shell = CA.on_shell
- let is_gauss = CA.is_gauss
- let constraints = CA.constraints
+ let incoming = SCA.incoming
+ let outgoing = SCA.outgoing
+ let externals = SCA.externals
+ let fusions = SCA.fusions
+ let brakets = SCA.brakets
+ let symmetry = SCA.symmetry
+ let on_shell = SCA.on_shell
+ let is_gauss = SCA.is_gauss
+ let constraints = SCA.constraints
+ let slicings = SCA.slicings
let variables a = List.map lhs (fusions a)
- let dependencies = CA.dependencies
+ let dependencies = SCA.dependencies
+
+ let slice_wf flavor wf =
+ { SCA.flavor = flavor;
+ SCA.momentum = wf.CA.momentum }
+
+ let unslice_wf wf =
+ { CA.flavor = SCM.flavor_all_orders wf.SCA.flavor;
+ CA.momentum = wf.SCA.momentum }
+
+ module SCWFBundle = Bundle.Make
+ (struct
+ type elt = SCA.wf
+ let compare_elt = compare
+ type base = CA.wf
+ let compare_base = compare
+ let pi = unslice_wf
+ end)
+
+ type sliced_fibered_dag =
+ { sliced_dag : SCA.D.t; sliced_bundle : SCWFBundle.t }
+
+ type wf_slicer = CA.wf -> sliced_fibered_dag -> SCA.wf * SCWFBundle.t
+ type sliced_fusion = SCA.wf * SCA.rhs
+ type node_slicer = CA.wf -> CA.rhs -> sliced_fibered_dag -> sliced_fusion list * SCWFBundle.t
+
+ let slice_sterile_nodes : CA.D.t -> wf_slicer -> CA.D.node -> sliced_fibered_dag -> sliced_fibered_dag =
+ fun dag f wf fibered_dag ->
+ if CA.D.is_sterile wf dag then
+ let wf', wf_bundle' = f wf fibered_dag in
+ { sliced_dag = SCA.D.add_node wf' fibered_dag.sliced_dag;
+ sliced_bundle = wf_bundle' }
+ else
+ fibered_dag
+
+ let slice_nodes : node_slicer -> CA.wf -> CA.rhs -> sliced_fibered_dag -> sliced_fibered_dag =
+ fun f wf rhs fibered_dag ->
+ let wf_rhs_list', wf_bundle' = f wf rhs fibered_dag in
+ let dag' =
+ List.fold_right
+ (fun (wf', rhs') -> SCA.D.add_offspring wf' rhs')
+ wf_rhs_list' fibered_dag.sliced_dag in
+ { sliced_dag = dag';
+ sliced_bundle = wf_bundle' }
+
+ let slice_dag : node_slicer -> wf_slicer -> CA.D.t -> SCWFBundle.t -> sliced_fibered_dag =
+ fun f_node f_ext dag wf_bundle ->
+ CA.D.fold (slice_nodes f_node) dag
+ (CA.D.fold_nodes (slice_sterile_nodes dag f_ext) dag
+ { sliced_dag = SCA.D.empty; sliced_bundle = wf_bundle })
+
+ let lift_wf wf =
+ slice_wf (SCM.trivial wf.CA.flavor) wf
+
+ let lift_external : wf_slicer =
+ fun wf fibered_dag ->
+ (lift_wf wf, fibered_dag.sliced_bundle)
+
+ let lift_fusion : node_slicer =
+ fun wf (coupling, children) fibered_dag ->
+ let wf = lift_wf wf
+ and children = PT.map lift_wf children in
+ let sliced_bundle = SCWFBundle.add fibered_dag.sliced_bundle wf in
+ ( [ (wf, (coupling, children)) ], sliced_bundle )
+
+ let lift_dag : CA.D.t -> SCWFBundle.t -> sliced_fibered_dag =
+ fun dag wf_bundle ->
+ slice_dag lift_fusion lift_external dag wf_bundle
+
+ let lift_braket : CA.braket -> SCA.braket =
+ fun (wf, rhs) ->
+ let wf = lift_wf wf
+ and rhs = List.map (fun (coupling, children) -> (coupling, PT.map lift_wf children)) rhs in
+ (wf, rhs)
+
+ module SCBra = struct type t = SCA.wf let compare = SCA.order_wf end
+ module SCBraMap = Map.Make(SCBra)
+
+ let lift_amplitude a =
+ let fin = List.map SCM.trivial a.CA.incoming
+ and fout = List.map SCM.trivial a.CA.outgoing in
+ let f = fin @ List.map SCM.conjugate fout in
+ let nin, nout = List.length fin, List.length fout in
+ let n = nin + nout in
+ let externals = List.combine f (ThoList.range 1 n) in
+ let external_wfs = SCA.external_wfs n externals in
+ let wf_bundle = SCWFBundle.of_list external_wfs in
+ let fibered_dag = lift_dag a.CA.fusion_dag wf_bundle in
+ let brakets = List.map lift_braket a.CA.brakets in
+ let dag = SCA.D.harvest_list fibered_dag.sliced_dag (SCA.wavefunctions brakets) in
+ let fusions = List.filter (function (_, []) -> false | _ -> true) (SCA.D.lists dag) in
+ let dependencies_map =
+ SCA.D.fold (fun wf _ -> SCBraMap.add wf (SCA.D.dependencies dag wf)) dag SCBraMap.empty in
+ { SCA.fusions = fusions;
+ SCA.brakets = SCA.unsliced brakets;
+ SCA.constraints = a.CA.constraints;
+ SCA.slicings = a.CA.slicings;
+ SCA.incoming = fin;
+ SCA.outgoing = fout;
+ SCA.externals = external_wfs;
+ SCA.fusion_dag = dag;
+ SCA.fusion_tower = dag;
+ SCA.symmetry = a.CA.symmetry;
+ SCA.on_shell = (fun wf -> a.CA.on_shell (unslice_wf wf));
+ SCA.is_gauss = (fun wf -> a.CA.is_gauss (unslice_wf wf));
+ SCA.dependencies = (fun wf -> SCBraMap.find wf dependencies_map) }
+
+ let lift_amplitudes amplitudes =
+ List.map lift_amplitude amplitudes
+
+ let amplitudes goldstones selectors slicings fin fout =
+ let a = amplitudes_all_orders goldstones selectors fin fout in
+ match slicings with
+ | None -> lift_amplitudes a
+ | Some _ -> invalid_arg "Fusion.*.amplitudes: order slicing not supported in the vintage version!"
+
+ let amplitudes_all_orders goldstones selectors fin fout =
+ lift_amplitudes (amplitudes_all_orders goldstones selectors fin fout)
+
+ let allowed amplitude =
+ match amplitude.SCA.brakets with
+ | [] -> false
+ | _ -> true
(* \thocwmodulesubsection{Checking Conservation Laws} *)
let check_charges () =
let vlist3, vlist4, vlistn = M.vertices () in
List.filter
(fun flist -> not (M.Ch.is_null (M.Ch.sum (List.map M.charges flist))))
(List.map (fun ((f1, f2, f3), _, _) -> [f1; f2; f3]) vlist3
@ List.map (fun ((f1, f2, f3, f4), _, _) -> [f1; f2; f3; f4]) vlist4
@ List.map (fun (flist, _, _) -> flist) vlistn)
(* \thocwmodulesubsection{Diagnostics} *)
+ let all_brakets a =
+ ThoList.flatmap snd a.SCA.brakets
+
let count_propagators a =
- List.length a.CA.fusions
+ List.length a.SCA.fusions
let count_fusions a =
- List.fold_left (fun n (_, a) -> n + List.length a) 0 a.CA.fusions
- + List.fold_left (fun n (_, t) -> n + List.length t) 0 a.CA.brakets
- + List.length a.CA.brakets
+ let brakets = all_brakets a in
+ List.fold_left (fun n (_, a) -> n + List.length a) 0 a.SCA.fusions
+ + List.fold_left (fun n (_, t) -> n + List.length t) 0 brakets
+ + List.length brakets
(* \begin{dubious}
This brute force approach blows up for more than ten particles.
Find a smarter algorithm.
\end{dubious} *)
let count_diagrams a =
List.fold_left (fun n (wf1, wf23) ->
- n + CA.D.count_trees wf1 a.CA.fusion_dag *
+ n + SCA.D.count_trees wf1 a.SCA.fusion_dag *
(List.fold_left (fun n' (_, wfs) ->
n' + PT.fold_left (fun n'' wf ->
- n'' * CA.D.count_trees wf a.CA.fusion_dag) 1 wfs) 0 wf23))
- 0 a.CA.brakets
+ n'' * SCA.D.count_trees wf a.SCA.fusion_dag) 1 wfs) 0 wf23))
+ 0 (all_brakets a)
exception Impossible
let forest' a =
- let below wf = CA.D.forest_memoized wf a.CA.fusion_dag in
+ let below wf = SCA.D.forest_memoized wf a.SCA.fusion_dag in
ThoList.flatmap
(fun (bra, ket) ->
(Product.list2 (fun bra' ket' -> bra' :: ket')
(below bra)
(ThoList.flatmap
(fun (_, wfs) ->
Product.list (fun w -> w) (PT.to_list (PT.map below wfs)))
ket)))
- a.CA.brakets
+ (all_brakets a)
let cross wf =
- { CA.flavor = CM.conjugate wf.CA.flavor;
- CA.momentum = P.neg wf.CA.momentum;
- CA.wf_tag = wf.CA.wf_tag }
+ { SCA.flavor = SCM.conjugate wf.SCA.flavor;
+ SCA.momentum = P.neg wf.SCA.momentum }
let fuse_trees wf ts =
Tree.fuse (fun (wf', e) -> (cross wf', e))
wf (fun t -> List.mem wf (Tree.leafs t)) ts
let forest wf a =
List.map (fuse_trees wf) (forest' a)
(*i
(* \begin{dubious}
The following duplication should be replaced by polymorphism
or a functor.
\end{dubious} *)
let forest_uncolored' a =
let below wf = A.D.forest_memoized wf a.A.fusion_dag in
ThoList.flatmap
(fun (bra, ket) ->
(Product.list2 (fun bra' ket' -> bra' :: ket')
(below bra)
(ThoList.flatmap
(fun (_, wfs) ->
Product.list (fun w -> w) (PT.to_list (PT.map below wfs)))
ket)))
a.A.brakets
let cross_uncolored wf =
{ A.flavor = M.conjugate wf.A.flavor;
- A.momentum = P.neg wf.A.momentum;
- A.wf_tag = wf.A.wf_tag }
+ A.momentum = P.neg wf.A.momentum }
let fuse_trees_uncolored wf ts =
Tree.fuse (fun (wf', e) -> (cross_uncolored wf', e))
wf (fun t -> List.mem wf (Tree.leafs t)) ts
let forest_sans_color wf a =
List.map (fuse_trees_uncolored wf) (forest_uncolored' a)
i*)
let poles_beneath wf dag =
- CA.D.eval_memoized (fun wf' -> [[]])
+ SCA.D.eval_memoized (fun wf' -> [[]])
(fun wf' _ p -> List.map (fun p' -> wf' :: p') p)
(fun wf1 wf2 ->
Product.fold2 (fun wf' wfs' wfs'' -> (wf' @ wfs') :: wfs'') wf1 wf2 [])
(@) [[]] [[]] wf dag
let poles a =
ThoList.flatmap (fun (wf1, wf23) ->
- let poles_wf1 = poles_beneath wf1 a.CA.fusion_dag in
+ let poles_wf1 = poles_beneath wf1 a.SCA.fusion_dag in
(ThoList.flatmap (fun (_, wfs) ->
Product.list List.flatten
(PT.to_list (PT.map (fun wf ->
- poles_wf1 @ poles_beneath wf a.CA.fusion_dag) wfs)))
+ poles_wf1 @ poles_beneath wf a.SCA.fusion_dag) wfs)))
wf23))
- a.CA.brakets
+ (all_brakets a)
module WFSet =
- Set.Make (struct type t = CA.wf let compare = CA.order_wf end)
+ Set.Make (struct type t = SCA.wf let compare = SCA.order_wf end)
let s_channel a =
WFSet.elements
(ThoList.fold_right2
(fun wf wfs ->
- if P.Scattering.timelike wf.CA.momentum then
+ if P.Scattering.timelike wf.SCA.momentum then
WFSet.add wf wfs
else
wfs) (poles a) WFSet.empty)
(* \begin{dubious}
This should be much faster! Is it correct? Is it faster indeed?
\end{dubious} *)
let poles' a =
- List.map CA.lhs a.CA.fusions
+ List.map SCA.lhs a.SCA.fusions
let s_channel a =
WFSet.elements
(List.fold_right
(fun wf wfs ->
- if P.Scattering.timelike wf.CA.momentum then
+ if P.Scattering.timelike wf.SCA.momentum then
WFSet.add wf wfs
else
wfs) (poles' a) WFSet.empty)
(* \thocwmodulesubsection{Pictures} *)
(* Export the DAG in the \texttt{dot(1)} file format so that we can
draw pretty pictures to impress audiences \ldots *)
let p2s p =
if p >= 0 && p <= 9 then
string_of_int p
else if p <= 36 then
String.make 1 (Char.chr (Char.code 'A' + p - 10))
else
"_"
let variable wf =
- CM.flavor_symbol wf.CA.flavor ^
- String.concat "" (List.map p2s (P.to_ints wf.CA.momentum))
+ SCM.flavor_symbol wf.SCA.flavor ^
+ String.concat "" (List.map p2s (P.to_ints wf.SCA.momentum))
- module Int = Map.Make (struct type t = int let compare = compare end)
+ module IMap = Map.Make(Int)
let add_to_list i n m =
- Int.add i (n :: try Int.find i m with Not_found -> []) m
+ IMap.add i (n :: try IMap.find i m with Not_found -> []) m
let classify_nodes dag =
- Int.fold (fun i n acc -> (i, n) :: acc)
- (CA.D.fold_nodes (fun wf -> add_to_list (P.rank wf.CA.momentum) wf)
- dag Int.empty) []
+ IMap.fold (fun i n acc -> (i, n) :: acc)
+ (SCA.D.fold_nodes (fun wf -> add_to_list (P.rank wf.SCA.momentum) wf)
+ dag IMap.empty) []
let dag_to_dot ch brakets dag =
Printf.fprintf ch "digraph OMEGA {\n";
- CA.D.iter_nodes (fun wf ->
+ SCA.D.iter_nodes (fun wf ->
Printf.fprintf ch " \"%s\" [ label = \"%s\" ];\n"
(variable wf) (variable wf)) dag;
List.iter (fun (_, wfs) ->
Printf.fprintf ch " { rank = same;";
List.iter (fun n ->
Printf.fprintf ch " \"%s\";" (variable n)) wfs;
Printf.fprintf ch " };\n") (classify_nodes dag);
List.iter (fun n ->
Printf.fprintf ch " \"*\" -> \"%s\";\n" (variable n))
(flatten_keystones brakets);
- CA.D.iter (fun n (_, ns) ->
+ SCA.D.iter (fun n (_, ns) ->
let p = variable n in
PT.iter (fun n' ->
Printf.fprintf ch " \"%s\" -> \"%s\";\n" p (variable n')) ns) dag;
Printf.fprintf ch "}\n"
let tower_to_dot ch a =
- dag_to_dot ch a.CA.brakets a.CA.fusion_tower
+ dag_to_dot ch (all_brakets a) a.SCA.fusion_tower
let amplitude_to_dot ch a =
- dag_to_dot ch a.CA.brakets a.CA.fusion_dag
+ dag_to_dot ch (all_brakets a) a.SCA.fusion_dag
(* \thocwmodulesubsection{Phasespace} *)
let variable wf =
M.flavor_to_string wf.A.flavor ^
"[" ^ String.concat "/" (List.map p2s (P.to_ints wf.A.momentum)) ^ "]"
let below_to_channel transform ch dag wf =
let n2s wf = variable (transform wf)
and e2s c = "" in
Tree2.to_channel ch n2s e2s (A.D.dependencies dag wf)
let bra_to_channel transform ch dag wf =
let tree = A.D.dependencies dag wf in
if Tree2.is_singleton tree then
let n2s wf = variable (transform wf)
and e2s c = "" in
Tree2.to_channel ch n2s e2s tree
else
failwith "Fusion.phase_space_channels: wrong topology!"
let ket_to_channel transform ch dag ket =
Printf.fprintf ch "(";
begin match A.children ket with
| [] -> ()
| [child] -> below_to_channel transform ch dag child
| child :: children ->
below_to_channel transform ch dag child;
List.iter
(fun child ->
Printf.fprintf ch ",";
below_to_channel transform ch dag child)
children
end;
Printf.fprintf ch ")"
let phase_space_braket transform ch (bra, ket) dag =
bra_to_channel transform ch dag bra;
Printf.fprintf ch ": {";
begin match ket with
| [] -> ()
| [ket1] ->
Printf.fprintf ch " ";
ket_to_channel transform ch dag ket1
| ket1 :: kets ->
Printf.fprintf ch " ";
ket_to_channel transform ch dag ket1;
List.iter
(fun k ->
Printf.fprintf ch " \\\n | ";
ket_to_channel transform ch dag k)
kets
end;
Printf.fprintf ch " }\n"
(*i Food for thought:
let braket_to_tree2 dag (bra, ket) =
let bra' = A.D.dependencies dag bra in
if Tree2.is_singleton bra' then
Tree2.cons
[(fst ket, bra, List.map (A.D.dependencies dag) (A.children ket))]
else
failwith "Fusion.phase_space_channels: wrong topology!"
let phase_space_braket transform ch (bra, ket) dag =
let n2s wf = variable (transform wf)
and e2s c = "" in
Printf.fprintf
ch "%s\n" (Tree2.to_string n2s e2s (braket_to_tree2 dag (bra, ket)))
i*)
let phase_space_channels_transformed transform ch a =
List.iter
(fun braket -> phase_space_braket transform ch braket a.A.fusion_dag)
a.A.brakets
let phase_space_channels ch a =
phase_space_channels_transformed (fun wf -> wf) ch a
let exchange_momenta_list p1 p2 p =
List.map
(fun pi ->
if pi = p1 then
p2
else if pi = p2 then
p1
else
pi)
p
let exchange_momenta p1 p2 p =
P.of_ints (P.dim p) (exchange_momenta_list p1 p2 (P.to_ints p))
let flip_momenta wf =
{ wf with A.momentum = exchange_momenta 1 2 wf.A.momentum }
let phase_space_channels_flipped ch a =
phase_space_channels_transformed flip_momenta ch a
end
-module Make = Tagged(No_Tags)
-
module Binary = Make(Tuple.Binary)(Stat_Dirac)(Topology.Binary)
-module Tagged_Binary (T : Tagger) =
- Tagged(T)(Tuple.Binary)(Stat_Dirac)(Topology.Binary)
(* \thocwmodulesection{Fusions with Majorana Fermions} *)
module Stat_Majorana (M : Model.T) : (Stat with type flavor = M.flavor) =
struct
type flavor = M.flavor
type stat =
| Fermion of int * int list
| AntiFermion of int * int list
| Boson of int list
| Majorana of int * int list
let stat f p =
let s = M.fermion f in
if s = 0 then
Boson []
else if s < 0 then
AntiFermion (p, [])
else if s = 1 then (* [if s = 1 then] *)
Fermion (p, [])
else (* [if s > 1 then] *)
Majorana (p, [])
let lines_to_string lines =
ThoList.to_string string_of_int lines
let stat_to_string = function
| Boson lines -> Printf.sprintf "Boson %s" (lines_to_string lines)
| Fermion (p, lines) ->
Printf.sprintf "Fermion (%d, %s)" p (lines_to_string lines)
| AntiFermion (p, lines) ->
Printf.sprintf "AntiFermion (%d, %s)" p (lines_to_string lines)
| Majorana (p, lines) ->
Printf.sprintf "Majorana (%d, %s)" p (lines_to_string lines)
(* \begin{JR}
In the formalism of~\cite{Denner:Majorana}, it does not matter to distinguish
spinors and conjugate spinors, it is only important to know in which direction
a fermion line is calculated. So the sign is made by the calculation together
with an aditional one due to the permuation of the pairs of endpoints of
fermion lines in the direction they are calculated. We propose a
``canonical'' direction from the right to the left child at a fusion point
so we only have to keep in mind which external particle hangs at each side.
Therefore we need not to have a list of pairs of conjugate spinors and
spinors but just a list in which the pairs are right-left-right-left
and so on. Unfortunately it is unavoidable to have couplings with clashing
arrows in supersymmetric theories so we need transmutations from fermions
in antifermions and vice versa as well.
\end{JR} *)
exception Impossible
(*i
let stat_fuse s1 s2 f =
match s1, s2, M.lorentz f with
| Boson l1, Boson l2, _ -> Boson (l1 @ l2)
| Boson l1, Fermion (p, l2), Coupling.Majorana ->
Majorana (p, l1 @ l2)
| Boson l1, Fermion (p, l2), _ -> Fermion (p, l1 @ l2)
| Boson l1, AntiFermion (p, l2), Coupling.Majorana ->
Majorana (p, l1 @ l2)
| Boson l1, AntiFermion (p, l2), _ -> AntiFermion (p, l1 @ l2)
| Fermion (p, l1), Boson l2, Coupling.Majorana ->
Majorana (p, l1 @ l2)
| Fermion (p, l1), Boson l2, _ -> Fermion (p, l1 @ l2)
| AntiFermion (p, l1), Boson l2, Coupling.Majorana ->
Majorana (p, l1 @ l2)
| AntiFermion (p, l1), Boson l2, _ ->
AntiFermion (p, l1 @ l2)
| Majorana (p, l1), Boson l2, Coupling.Spinor ->
Fermion (p, l1 @ l2)
| Majorana (p, l1), Boson l2, Coupling.ConjSpinor ->
AntiFermion (p, l1 @ l2)
| Majorana (p, l1), Boson l2, _ ->
Majorana (p, l1 @ l2)
| Boson l1, Majorana (p, l2), Coupling.Spinor ->
Fermion (p, l1 @ l2)
| Boson l1, Majorana (p, l2), Coupling.ConjSpinor ->
AntiFermion (p, l1 @ l2)
| Boson l1, Majorana (p, l2), _ ->
Majorana (p, l1 @ l2)
| AntiFermion (pbar, l1), Fermion (p, l2), _ ->
Boson ([p; pbar] @ l1 @ l2)
| Fermion (p, l1), AntiFermion (pbar, l2), _ ->
Boson ([pbar; p] @ l1 @ l2)
| Fermion (pf, l1), Majorana (pm, l2), _ ->
Boson ([pm; pf] @ l1 @ l2)
| Majorana (pm, l1), Fermion (pf, l2), _ ->
Boson ([pf; pm] @ l1 @ l2)
| AntiFermion (pa, l1), Majorana (pm, l2), _ ->
Boson ([pm; pa] @ l1 @ l2)
| Majorana (pm, l1), AntiFermion (pa, l2), _ ->
Boson ([pa; pm] @ l1 @ l2)
| Majorana (p1, l1), Majorana (p2, l2), _ ->
Boson ([p2; p1] @ l1 @ l2)
| Fermion _, Fermion _, _ | AntiFermion _,
AntiFermion _, _ -> raise Impossible
i*)
let stat_fuse s1 s2 f =
match s1, s2, M.lorentz f with
| Boson l1, Fermion (p, l2), Coupling.Majorana
| Boson l1, AntiFermion (p, l2), Coupling.Majorana
| Fermion (p, l1), Boson l2, Coupling.Majorana
| AntiFermion (p, l1), Boson l2, Coupling.Majorana
| Majorana (p, l1), Boson l2, Coupling.Majorana
| Boson l1, Majorana (p, l2), Coupling.Majorana ->
Majorana (p, l1 @ l2)
| Boson l1, Fermion (p, l2), Coupling.Spinor
| Boson l1, AntiFermion (p, l2), Coupling.Spinor
| Fermion (p, l1), Boson l2, Coupling.Spinor
| AntiFermion (p, l1), Boson l2, Coupling.Spinor
| Majorana (p, l1), Boson l2, Coupling.Spinor
| Boson l1, Majorana (p, l2), Coupling.Spinor ->
Fermion (p, l1 @ l2)
| Boson l1, Fermion (p, l2), Coupling.ConjSpinor
| Boson l1, AntiFermion (p, l2), Coupling.ConjSpinor
| Fermion (p, l1), Boson l2, Coupling.ConjSpinor
| AntiFermion (p, l1), Boson l2, Coupling.ConjSpinor
| Majorana (p, l1), Boson l2, Coupling.ConjSpinor
| Boson l1, Majorana (p, l2), Coupling.ConjSpinor ->
AntiFermion (p, l1 @ l2)
| Boson l1, Fermion (p, l2), Coupling.Vectorspinor
| Boson l1, AntiFermion (p, l2), Coupling.Vectorspinor
| Fermion (p, l1), Boson l2, Coupling.Vectorspinor
| AntiFermion (p, l1), Boson l2, Coupling.Vectorspinor
| Majorana (p, l1), Boson l2, Coupling.Vectorspinor
| Boson l1, Majorana (p, l2), Coupling.Vectorspinor ->
Majorana (p, l1 @ l2)
| Boson l1, Boson l2, _ -> Boson (l1 @ l2)
| AntiFermion (p1, l1), Fermion (p2, l2), _
| Fermion (p1, l1), AntiFermion (p2, l2), _
| Fermion (p1, l1), Fermion (p2, l2), _
| AntiFermion (p1, l1), AntiFermion (p2, l2), _
| Fermion (p1, l1), Majorana (p2, l2), _
| Majorana (p1, l1), Fermion (p2, l2), _
| AntiFermion (p1, l1), Majorana (p2, l2), _
| Majorana (p1, l1), AntiFermion (p2, l2), _
| Majorana (p1, l1), Majorana (p2, l2), _ ->
Boson ([p2; p1] @ l1 @ l2)
| Boson l1, Majorana (p, l2), _ -> Majorana (p, l1 @ l2)
| Boson l1, Fermion (p, l2), _ -> Fermion (p, l1 @ l2)
| Boson l1, AntiFermion (p, l2), _ -> AntiFermion (p, l1 @ l2)
| Fermion (p, l1), Boson l2, _ -> Fermion (p, l1 @ l2)
| AntiFermion (p, l1), Boson l2, _ -> AntiFermion (p, l1 @ l2)
| Majorana (p, l1), Boson l2, _ -> Majorana (p, l1 @ l2)
let stat_fuse s1 s2 f =
let stat = stat_fuse s1 s2 f in
(*i Printf.eprintf
"Fusion.Stat_Majorana.stat_fuse_legacy: %s <- %s -> %s\n"
(M.flavor_to_string f)
(ThoList.to_string stat_to_string [s1; s2])
(stat_to_string stat); i*)
stat
(*i These are the old Impossible raising rules. We keep them to ask Ohl
what the generalized topologies do and if our stat_fuse does the right
for 4-vertices with
| Boson l1, AntiFermion (p, l2), _
| Fermion (p, l1), Boson l2, _
| AntiFermion (p, l1), Boson l2, _
| Majorana (p, l1), Boson l2, _
| Boson l1, Majorana (p, l2), _ ->
raise Impossible
i*)
let permutation lines = fst (Combinatorics.sort_signed lines)
let stat_sign = function
| Boson lines -> permutation lines
| Fermion (p, lines) -> permutation (p :: lines)
| AntiFermion (pbar, lines) -> permutation (pbar :: lines)
| Majorana (pm, lines) -> permutation (pm :: lines)
end
module Binary_Majorana =
Make(Tuple.Binary)(Stat_Majorana)(Topology.Binary)
module Nary (B: Tuple.Bound) =
Make(Tuple.Nary(B))(Stat_Dirac)(Topology.Nary(B))
module Nary_Majorana (B: Tuple.Bound) =
Make(Tuple.Nary(B))(Stat_Majorana)(Topology.Nary(B))
module Mixed23 =
Make(Tuple.Mixed23)(Stat_Dirac)(Topology.Mixed23)
module Mixed23_Majorana =
Make(Tuple.Mixed23)(Stat_Majorana)(Topology.Mixed23)
module Helac (B: Tuple.Bound) =
Make(Tuple.Nary(B))(Stat_Dirac)(Topology.Helac(B))
module Helac_Majorana (B: Tuple.Bound) =
Make(Tuple.Nary(B))(Stat_Majorana)(Topology.Helac(B))
(* \thocwmodulesection{Multiple Amplitudes} *)
module type Multi =
sig
exception Mismatch
val options : Options.t
type flavor
type process = flavor list * flavor list
type amplitude
type fusion
type wf
- type exclusions
- val no_exclusions : exclusions
type selectors
+ type slicings
type amplitudes
val amplitudes : bool -> int option ->
- exclusions -> selectors -> process list -> amplitudes
+ selectors -> slicings option -> process list -> amplitudes
val empty : amplitudes
(*i
val initialize_cache : string -> unit
val set_cache_name : string -> unit
i*)
val flavors : amplitudes -> process list
val vanishing_flavors : amplitudes -> process list
val color_flows : amplitudes -> Color.Flow.t list
val helicities : amplitudes -> (int list * int list) list
val processes : amplitudes -> amplitude list
val process_table : amplitudes -> amplitude option array array
val fusions : amplitudes -> (fusion * amplitude) list
val multiplicity : amplitudes -> wf -> int
val dictionary : amplitudes -> amplitude -> wf -> int
val color_factors : amplitudes -> Color.Flow.factor array array
val constraints : amplitudes -> string option
+ val slicings : amplitudes -> string list
end
module type Multi_Maker = functor (Fusion_Maker : Maker) ->
functor (P : Momentum.T) ->
functor (M : Model.T) ->
Multi with type flavor = M.flavor
and type amplitude = Fusion_Maker(P)(M).amplitude
and type fusion = Fusion_Maker(P)(M).fusion
and type wf = Fusion_Maker(P)(M).wf
and type selectors = Fusion_Maker(P)(M).selectors
+ and type slicings = Orders.Conditions(Colorize.It(M)).t
module Multi (Fusion_Maker : Maker) (P : Momentum.T) (M : Model.T) =
struct
exception Mismatch
type progress_mode =
| Quiet
| Channel of out_channel
| File of string
let progress_option = ref Quiet
module CM = Colorize.It(M)
+ module SCM = Orders.Slice(Colorize.It(M))
module F = Fusion_Maker(P)(M)
module C = Cascade.Make(M)(P)
(* \begin{dubious}
A kludge, at best \ldots
\end{dubious} *)
let options = Options.extend F.options
[ "progress", Arg.Unit (fun () -> progress_option := Channel stderr),
"report progress to the standard error stream";
"progress_file", Arg.String (fun s -> progress_option := File s),
"report progress to a file" ]
type flavor = M.flavor
type p = F.p
type process = flavor list * flavor list
type amplitude = F.amplitude
type fusion = F.fusion
type wf = F.wf
- type exclusions = F.exclusions
- let no_exclusions = F.no_exclusions
type selectors = F.selectors
+ type slicings = Orders.Conditions(Colorize.It(M)).t
type flavors = flavor list array
type helicities = int list array
type colors = Color.Flow.t array
type amplitudes' = amplitude array array array
type amplitudes =
{ flavors : process list;
vanishing_flavors : process list;
color_flows : Color.Flow.t list;
helicities : (int list * int list) list;
processes : amplitude list;
process_table : amplitude option array array;
fusions : (fusion * amplitude) list;
multiplicity : (wf -> int);
dictionary : (amplitude -> wf -> int);
color_factors : Color.Flow.factor array array;
- constraints : string option }
+ constraints : string option;
+ slicings : string list }
let flavors a = a.flavors
let vanishing_flavors a = a.vanishing_flavors
let color_flows a = a.color_flows
let helicities a = a.helicities
let processes a = a.processes
let process_table a = a.process_table
let fusions a = a.fusions
let multiplicity a = a.multiplicity
let dictionary a = a.dictionary
let color_factors a = a.color_factors
let constraints a = a.constraints
+ let slicings a = a.slicings
let sans_colors f =
- List.map CM.flavor_sans_color f
+ List.map SCM.flavor_sans_color f
let colors (fin, fout) =
List.map M.color (fin @ fout)
let process_sans_color a =
(sans_colors (F.incoming a), sans_colors (F.outgoing a))
let color_flow a =
- CM.flow (F.incoming a) (F.outgoing a)
+ SCM.flow (F.incoming a) (F.outgoing a)
let process_to_string fin fout =
String.concat " " (List.map M.flavor_to_string fin)
^ " -> " ^ String.concat " " (List.map M.flavor_to_string fout)
let count_processes colored_processes =
List.length colored_processes
module FMap =
Map.Make (struct type t = process let compare = compare end)
module CMap =
Map.Make (struct type t = Color.Flow.t let compare = compare end)
(* Recently [Product.list] began to guarantee lexicographic order for sorted
arguments. Anyway, we still force a lexicographic order. *)
let rec order_spin_table1 s1 s2 =
match s1, s2 with
| h1 :: t1, h2 :: t2 ->
let c = compare h1 h2 in
if c <> 0 then
c
else
order_spin_table1 t1 t2
| [], [] -> 0
| _ -> invalid_arg "order_spin_table: inconsistent lengths"
let order_spin_table (s1_in, s1_out) (s2_in, s2_out) =
let c = compare s1_in s2_in in
if c <> 0 then
c
else
order_spin_table1 s1_out s2_out
let sort_spin_table table =
List.sort order_spin_table table
let id x = x
let pair x y = (x, y)
(* \begin{dubious}
Improve support for on shell Ward identities: [Coupling.Vector -> [4]] for one
and only one external vector.
\end{dubious} *)
let rec hs_of_lorentz = function
| Coupling.Scalar -> [0]
| Coupling.Spinor | Coupling.ConjSpinor
| Coupling.Majorana | Coupling.Maj_Ghost -> [-1; 1]
| Coupling.Vector -> [-1; 1]
| Coupling.Massive_Vector -> [-1; 0; 1]
| Coupling.Tensor_1 -> [-1; 0; 1]
| Coupling.Vectorspinor -> [-2; -1; 1; 2]
| Coupling.Tensor_2 -> [-2; -1; 0; 1; 2]
| Coupling.BRS f -> hs_of_lorentz f
let hs_of_flavor f =
hs_of_lorentz (M.lorentz f)
let hs_of_flavors (fin, fout) =
(List.map hs_of_flavor fin, List.map hs_of_flavor fout)
let rec unphysical_of_lorentz = function
| Coupling.Vector -> [4]
| Coupling.Massive_Vector -> [4]
| _ -> invalid_arg "unphysical_of_lorentz: not a vector particle"
let unphysical_of_flavor f =
unphysical_of_lorentz (M.lorentz f)
let unphysical_of_flavors1 n f_list =
ThoList.mapi
(fun i f -> if i = n then unphysical_of_flavor f else hs_of_flavor f)
1 f_list
let unphysical_of_flavors n (fin, fout) =
(unphysical_of_flavors1 n fin, unphysical_of_flavors1 (n - List.length fin) fout)
let helicity_table unphysical flavors =
let hs =
begin match unphysical with
| None -> List.map hs_of_flavors flavors
| Some n -> List.map (unphysical_of_flavors n) flavors
end in
if not (ThoList.homogeneous hs) then
invalid_arg "Fusion.helicity_table: not all flavors have the same helicity states!"
else
match hs with
| [] -> []
| (hs_in, hs_out) :: _ ->
sort_spin_table (Product.list2 pair (Product.list id hs_in) (Product.list id hs_out))
module Proc = Process.Make(M)
module WFMap = Map.Make (struct type t = F.wf let compare = compare end)
module WFSet2 =
Set.Make (struct type t = F.wf * (F.wf, F.coupling) Tree2.t let compare = compare end)
module WFMap2 =
Map.Make (struct type t = F.wf * (F.wf, F.coupling) Tree2.t let compare = compare end)
module WFTSet =
Set.Make (struct type t = (F.wf, F.coupling) Tree2.t let compare = compare end)
(* All wavefunctions are unique per amplitude. So we can use per-amplitude
dependency trees without additional \emph{internal} tags to identify identical
wave functions. *)
(* \textbf{NB:} we miss potential optimizations, because we assume all coupling to
be different, while in fact we have horizontal/family symmetries and non abelian
gauge couplings are universal anyway. *)
let disambiguate_fusions amplitudes =
let fusions =
ThoList.flatmap (fun amplitude ->
List.map
(fun fusion -> (fusion, F.dependencies amplitude (F.lhs fusion)))
(F.fusions amplitude))
amplitudes in
let duplicates =
List.fold_left
(fun map (fusion, dependencies) ->
let wf = F.lhs fusion in
let set = try WFMap.find wf map with Not_found -> WFTSet.empty in
WFMap.add wf (WFTSet.add dependencies set) map)
WFMap.empty fusions in
let multiplicity_map =
WFMap.fold (fun wf dependencies acc ->
let cardinal = WFTSet.cardinal dependencies in
if cardinal <= 1 then
acc
else
WFMap.add wf cardinal acc)
duplicates WFMap.empty
and dictionary_map =
WFMap.fold (fun wf dependencies acc ->
let cardinal = WFTSet.cardinal dependencies in
if cardinal <= 1 then
acc
else
snd (WFTSet.fold
(fun dependency (i', acc') ->
(succ i', WFMap2.add (wf, dependency) i' acc'))
dependencies (1, acc)))
duplicates WFMap2.empty in
let multiplicity wf =
WFMap.find wf multiplicity_map
and dictionary amplitude wf =
WFMap2.find (wf, F.dependencies amplitude wf) dictionary_map in
(multiplicity, dictionary)
let eliminate_common_fusions1 seen_wfs amplitude =
List.fold_left
(fun (seen, acc) f ->
let wf = F.lhs f in
let dependencies = F.dependencies amplitude wf in
if WFSet2.mem (wf, dependencies) seen then
(seen, acc)
else
(WFSet2.add (wf, dependencies) seen, (f, amplitude) :: acc))
seen_wfs (F.fusions amplitude)
let eliminate_common_fusions processes =
let _, rev_fusions =
List.fold_left
eliminate_common_fusions1
(WFSet2.empty, []) processes in
List.rev rev_fusions
(*i
let eliminate_common_fusions processes =
ThoList.flatmap
(fun amplitude ->
(List.map (fun f -> (f, amplitude)) (F.fusions amplitude)))
processes
i*)
(* \thocwmodulesubsection{Calculate All The Amplitudes} *)
- let amplitudes goldstones unphysical exclusions select_wf processes =
+ let amplitudes goldstones unphysical select_wf orders processes =
(* \begin{dubious}
Eventually, we might want to support inhomogeneous helicities. However,
this makes little physics sense for external particles on the mass shell,
unless we have a model with degenerate massive fermions and bosons.
\end{dubious} *)
if not (ThoList.homogeneous (List.map hs_of_flavors processes)) then
invalid_arg "Fusion.Multi.amplitudes: incompatible helicities";
let unique_uncolored_processes =
Proc.remove_duplicate_final_states (C.partition select_wf) processes in
let progress =
match !progress_option with
| Quiet -> Progress.dummy
| Channel oc -> Progress.channel oc (count_processes unique_uncolored_processes)
| File name -> Progress.file name (count_processes unique_uncolored_processes) in
let allowed =
ThoList.flatmap
(fun (fi, fo) ->
Progress.begin_step progress (process_to_string fi fo);
- let amps = F.amplitudes goldstones exclusions select_wf fi fo in
+ let amps = F.amplitudes goldstones select_wf orders fi fo in
begin match amps with
| [] -> Progress.end_step progress "forbidden"
| _ -> Progress.end_step progress "allowed"
end;
amps) unique_uncolored_processes in
Progress.summary progress "all processes done";
let color_flows =
ThoList.uniq (List.sort compare (List.map color_flow allowed))
and flavors =
ThoList.uniq (List.sort compare (List.map process_sans_color allowed)) in
let vanishing_flavors =
Proc.diff processes flavors in
let helicities =
helicity_table unphysical flavors in
let f_index =
fst (List.fold_left
(fun (m, i) f -> (FMap.add f i m, succ i))
(FMap.empty, 0) flavors)
and c_index =
fst (List.fold_left
(fun (m, i) c -> (CMap.add c i m, succ i))
(CMap.empty, 0) color_flows) in
let table =
Array.make_matrix (List.length flavors) (List.length color_flows) None in
List.iter
(fun a ->
let f = FMap.find (process_sans_color a) f_index
and c = CMap.find (color_flow a) c_index in
table.(f).(c) <- Some (a))
allowed;
let cf_array = Array.of_list color_flows in
let ncf = Array.length cf_array in
let color_factor_table = Array.make_matrix ncf ncf Color.Flow.zero in
for i = 0 to pred ncf do
for j = 0 to i do
color_factor_table.(i).(j) <-
Color.Flow.factor cf_array.(i) cf_array.(j);
color_factor_table.(j).(i) <-
color_factor_table.(i).(j)
done
done;
let fusions = eliminate_common_fusions allowed
and multiplicity, dictionary = disambiguate_fusions allowed in
{ flavors = flavors;
vanishing_flavors = vanishing_flavors;
color_flows = color_flows;
helicities = helicities;
processes = allowed;
process_table = table;
fusions = fusions;
multiplicity = multiplicity;
dictionary = dictionary;
color_factors = color_factor_table;
- constraints = C.description select_wf }
+ constraints = C.description select_wf;
+ slicings = [] }
(*i
let initialize_cache = F.initialize_cache
let set_cache_name = F.set_cache_name
i*)
let empty =
{ flavors = [];
vanishing_flavors = [];
color_flows = [];
helicities = [];
processes = [];
process_table = Array.make_matrix 0 0 None;
fusions = [];
multiplicity = (fun _ -> 1);
dictionary = (fun _ _ -> 1);
color_factors = Array.make_matrix 0 0 Color.Flow.zero;
- constraints = None }
+ constraints = None;
+ slicings = [] }
end
Index: trunk/omega/src/cascade.ml
===================================================================
--- trunk/omega/src/cascade.ml (revision 8899)
+++ trunk/omega/src/cascade.ml (revision 8900)
@@ -1,522 +1,521 @@
(* cascade.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
module type T =
sig
type constant
type flavor
type p
type t
val of_string_list : int -> string list -> t
val to_string : t -> string
type selectors
val to_selectors : t -> selectors
val no_cascades : selectors
val select_wf : selectors -> (p -> bool) -> flavor -> p -> p list -> bool
val select_p : selectors -> p -> p list -> bool
val on_shell : selectors -> flavor -> p -> bool
val is_gauss : selectors -> flavor -> p -> bool
val select_vtx : selectors -> constant Coupling.t ->
flavor -> flavor list -> bool
val partition : selectors -> int list list
val description : selectors -> string option
end
module Make (M : Model.T) (P : Momentum.T) :
(T with type flavor = M.flavor and type constant = M.constant and type p = P.t) =
struct
module CS = Cascade_syntax
type constant = M.constant
type flavor = M.flavor
type p = P.t
(* Since we have
\begin{equation}
p \le q \Longleftrightarrow (-q) \le (-p)
\end{equation}
also for $\le$ as set inclusion [lesseq], only four of the eight
combinations are independent
\begin{equation}
\begin{aligned}
p &\le q &&\Longleftrightarrow & (-q) &\le (-p) \\
q &\le p &&\Longleftrightarrow & (-p) &\le (-q) \\
p &\le (-q) &&\Longleftrightarrow & q &\le (-p) \\
(-q) &\le p &&\Longleftrightarrow & (-p) &\le q
\end{aligned}
\end{equation} *)
let one_compatible p q =
let neg_q = P.neg q in
P.lesseq p q ||
P.lesseq q p ||
P.lesseq p neg_q ||
P.lesseq neg_q p
(* 'tis wasteful \ldots (at least by a factor of two, because every momentum
combination is generated, including the negative ones. *)
let all_compatible p p_list q =
let l = List.length p_list in
if l <= 2 then
one_compatible p q
else
let tuple_lengths = ThoList.range 2 (succ l / 2) in
let tuples = ThoList.flatmap (fun n -> Combinatorics.choose n p_list) tuple_lengths in
let momenta = List.map (List.fold_left P.add (P.zero (P.dim q))) tuples in
List.for_all (one_compatible q) momenta
(* The following assumes that the [flavor list] is always very short. Otherwise
one should use an efficient set implementation. *)
type wf =
| True
| False
| On_shell of flavor list * P.t
| On_shell_not of flavor list * P.t
| Off_shell of flavor list * P.t
| Off_shell_not of flavor list * P.t
| Gauss of flavor list * P.t
| Gauss_not of flavor list * P.t
| Any_flavor of P.t
| And of wf list
module Constant = Modeltools.Constant (M)
type vtx =
{ couplings : M.constant list;
fields : flavor list }
type t =
{ wf : wf;
(* TODO: The following lists should be sets for efficiency. *)
flavors : flavor list;
vertices : vtx list }
let default =
{ wf = True;
flavors = [];
vertices = [] }
let of_string s =
Cascade_parser.main Cascade_lexer.token (Lexing.from_string s)
(* \begin{dubious}
If we knew that we're dealing with a scattering, we could apply
[P.flip_s_channel_in] to all momenta, so that $1+2$ accepts the particle
and not the antiparticle. Right now, we don't have this information.
\end{dubious} *)
let only_wf wf = { default with wf = wf }
let cons_and_wf c wfs =
match c.wf, wfs with
| True, wfs -> wfs
| False, _ -> [False]
| wf, [] -> [wf]
| wf, wfs -> wf :: wfs
let and_cascades_wf c =
match List.fold_right cons_and_wf c [] with
| [] -> True
| [wf] -> wf
| wfs -> And wfs
let uniq l =
ThoList.uniq (List.sort compare l)
let import dim cascades =
let rec import' = function
| CS.True ->
only_wf True
| CS.False ->
only_wf False
| CS.On_shell (f, p) ->
only_wf
(On_shell (List.map M.flavor_of_string f, P.of_ints dim p))
| CS.On_shell_not (f, p) ->
only_wf
(On_shell_not (List.map M.flavor_of_string f, P.of_ints dim p))
| CS.Off_shell (fs, p) ->
only_wf
(Off_shell (List.map M.flavor_of_string fs, P.of_ints dim p))
| CS.Off_shell_not (fs, p) ->
only_wf
(Off_shell_not (List.map M.flavor_of_string fs, P.of_ints dim p))
| CS.Gauss (f, p) ->
only_wf
(Gauss (List.map M.flavor_of_string f, P.of_ints dim p))
| CS.Gauss_not (f, p) ->
only_wf
(Gauss (List.map M.flavor_of_string f, P.of_ints dim p))
| CS.Any_flavor p ->
only_wf (Any_flavor (P.of_ints dim p))
| CS.And cs ->
let cs = List.map import' cs in
{ wf = and_cascades_wf cs;
flavors = uniq (List.concat
(List.map (fun c -> c.flavors) cs));
vertices = uniq (List.concat
(List.map (fun c -> c.vertices) cs)) }
| CS.X_Flavor fs ->
let fs = List.map M.flavor_of_string fs in
{ default with flavors = uniq (fs @ List.map M.conjugate fs) }
| CS.X_Vertex (cs, fss) ->
let cs = List.map Constant.of_string cs
and fss = List.map (List.map M.flavor_of_string) fss in
let expanded =
List.map
(fun fs -> { couplings = cs; fields = fs })
(match fss with
| [] -> [[]] (* Subtle: \emph{not} an empty list! *)
| fss -> Product.list (fun fs -> fs) fss) in
{ default with vertices = expanded }
in
import' cascades
let of_string_list dim strings =
match List.map of_string strings with
| [] -> default
| first :: next ->
import dim (List.fold_right CS.mk_and next first)
let flavors_to_string fs =
(String.concat ":" (List.map M.flavor_to_string fs))
let momentum_to_string p =
String.concat "+" (List.map string_of_int (P.to_ints p))
let rec wf_to_string = function
| True ->
"true"
| False ->
"false"
| On_shell (fs, p) ->
momentum_to_string p ^ " = " ^ flavors_to_string fs
| On_shell_not (fs, p) ->
momentum_to_string p ^ " = !" ^ flavors_to_string fs
| Off_shell (fs, p) ->
momentum_to_string p ^ " ~ " ^ flavors_to_string fs
| Off_shell_not (fs, p) ->
momentum_to_string p ^ " ~ !" ^ flavors_to_string fs
| Gauss (fs, p) ->
momentum_to_string p ^ " # " ^ flavors_to_string fs
| Gauss_not (fs, p) ->
momentum_to_string p ^ " # !" ^ flavors_to_string fs
| Any_flavor p ->
momentum_to_string p ^ " ~ ?"
| And cs ->
String.concat " && " (List.map (fun c -> "(" ^ wf_to_string c ^ ")") cs)
let vertex_to_string v =
"^" ^ String.concat ":" (List.map M.constant_symbol v.couplings) ^
"[" ^ String.concat "," (List.map M.flavor_to_string v.fields) ^ "]"
let vertices_to_string vs =
(String.concat " && " (List.map vertex_to_string vs))
let to_string = function
| { wf = True; flavors = []; vertices = [] } ->
""
| { wf = True; flavors = fs; vertices = [] } ->
"!" ^ flavors_to_string fs
| { wf = True; flavors = []; vertices = vs } ->
vertices_to_string vs
| { wf = True; flavors = fs; vertices = vs } ->
"!" ^ flavors_to_string fs ^ " && " ^ vertices_to_string vs
| { wf = wf; flavors = []; vertices = [] } ->
wf_to_string wf
| { wf = wf; flavors = []; vertices = vs } ->
vertices_to_string vs ^ " && " ^ wf_to_string wf
| { wf = wf; flavors = fs; vertices = [] } ->
"!" ^ flavors_to_string fs ^ " && " ^ wf_to_string wf
| { wf = wf; flavors = fs; vertices = vs } ->
"!" ^ flavors_to_string fs ^
" && " ^ vertices_to_string vs ^
" && " ^ wf_to_string wf
type selectors =
{ select_p : p -> p list -> bool;
select_wf : (p -> bool) -> flavor -> p -> p list -> bool;
on_shell : flavor -> p -> bool;
is_gauss : flavor -> p -> bool;
select_vtx : constant Coupling.t -> flavor -> flavor list -> bool;
partition : int list list;
description : string option }
let no_cascades =
{ select_p = (fun _ _ -> true);
select_wf = (fun _ _ _ _ -> true);
on_shell = (fun _ _ -> false);
is_gauss = (fun _ _ -> false);
select_vtx = (fun _ _ _ -> true);
partition = [];
description = None }
let select_p s = s.select_p
let select_wf s = s.select_wf
let on_shell s = s.on_shell
let is_gauss s = s.is_gauss
let select_vtx s = s.select_vtx
let partition s = s.partition
let description s = s.description
let to_select_p cascades p p_in =
let rec to_select_p' = function
| True -> true
| False -> false
| On_shell (_, momentum) | On_shell_not (_, momentum)
| Off_shell (_, momentum) | Off_shell_not (_, momentum)
| Gauss (_, momentum) | Gauss_not (_, momentum)
| Any_flavor momentum -> all_compatible p p_in momentum
| And [] -> false
| And cs -> List.for_all to_select_p' cs in
to_select_p' cascades
let to_select_wf cascades is_timelike f p p_in =
let f' = M.conjugate f in
let rec to_select_wf' = function
| True -> true
| False -> false
| Off_shell (flavors, momentum) ->
if p = momentum then
List.mem f' flavors || (if is_timelike p then false else List.mem f flavors)
else if p = P.neg momentum then
List.mem f flavors || (if is_timelike p then false else List.mem f' flavors)
else
one_compatible p momentum && all_compatible p p_in momentum
| On_shell (flavors, momentum) | Gauss (flavors, momentum) ->
if is_timelike p then begin
if p = momentum then
List.mem f' flavors
else if p = P.neg momentum then
List.mem f flavors
else
one_compatible p momentum && all_compatible p p_in momentum
end else
false
| Off_shell_not (flavors, momentum) ->
if p = momentum then
not (List.mem f' flavors || (if is_timelike p then false else List.mem f flavors))
else if p = P.neg momentum then
not (List.mem f flavors || (if is_timelike p then false else List.mem f' flavors))
else
one_compatible p momentum && all_compatible p p_in momentum
| On_shell_not (flavors, momentum) | Gauss_not (flavors, momentum) ->
if is_timelike p then begin
if p = momentum then
not (List.mem f' flavors)
else if p = P.neg momentum then
not (List.mem f flavors)
else
one_compatible p momentum && all_compatible p p_in momentum
end else
false
| Any_flavor momentum ->
one_compatible p momentum && all_compatible p p_in momentum
| And [] -> false
| And cs -> List.for_all to_select_wf' cs in
not (List.mem f cascades.flavors) && to_select_wf' cascades.wf
(* In case you're wondering: [to_on_shell f p] and [is_gauss f p] only search
for on shell conditions and are to be used in a target, not in [Fusion]! *)
let to_on_shell cascades f p =
let f' = M.conjugate f in
let rec to_on_shell' = function
| True | False | Any_flavor _
| Off_shell (_, _) | Off_shell_not (_, _)
| Gauss (_, _) | Gauss_not (_, _) -> false
| On_shell (flavors, momentum) ->
(p = momentum || p = P.neg momentum) && (List.mem f flavors || List.mem f' flavors)
| On_shell_not (flavors, momentum) ->
(p = momentum || p = P.neg momentum) && not (List.mem f flavors || List.mem f' flavors)
| And [] -> false
| And cs -> List.for_all to_on_shell' cs in
to_on_shell' cascades
let to_gauss cascades f p =
let f' = M.conjugate f in
let rec to_gauss' = function
| True | False | Any_flavor _
| Off_shell (_, _) | Off_shell_not (_, _)
| On_shell (_, _) | On_shell_not (_, _) -> false
| Gauss (flavors, momentum) ->
(p = momentum || p = P.neg momentum) &&
(List.mem f flavors || List.mem f' flavors)
| Gauss_not (flavors, momentum) ->
(p = momentum || p = P.neg momentum) &&
not (List.mem f flavors || List.mem f' flavors)
| And [] -> false
| And cs -> List.for_all to_gauss' cs in
to_gauss' cascades
module Fields =
struct
type f = M.flavor
type c = M.constant list
let compare = compare
let conjugate = M.conjugate
end
module Fusions = Modeltools.Fusions (Fields)
let dummy3 = Coupling.Scalar_Scalar_Scalar 1
let dummy4 = Coupling.Scalar4 1
- let dummyn = Coupling.UFO (Algebra.QC.unit, "dummy", [], [], Color.Vertex.one)
+ let dummyn = Coupling.UFO (Algebra.QC.unit, "dummy", [], [], Birdtracks.one)
(* Translate the vertices in a pair of lists: the first is the list
of always rejected couplings and the second the remaining
vertices suitable as input to [Fusions.of_vertices]. *)
let translate_vertices vertices =
List.fold_left
(fun (cs, (v3, v4, vn) as acc) v ->
match v.fields with
| [] -> (v.couplings @ cs, (v3, v4, vn))
| [_] | [_;_] -> acc
| [f1; f2; f3] ->
(cs, (((f1, f2, f3), dummy3, v.couplings)::v3, v4, vn))
| [f1; f2; f3; f4] ->
(cs, (v3, ((f1, f2, f3, f4), dummy4, v.couplings)::v4, vn))
| fs -> (cs, (v3, v4, (fs, dummyn, v.couplings)::vn)))
([], ([], [], [])) vertices
(*i
let fusion_to_string c f fs =
M.flavor_to_string f ^ " <- " ^ M.constant_symbol c ^ "[" ^
String.concat " , " (List.map M.flavor_to_string fs) ^ "]"
i*)
let unpack_constant = function
| Coupling.V3 (_, _, cs) -> cs
| Coupling.V4 (_, _, cs) -> cs
| Coupling.Vn (_, _, cs) -> cs
(* Sometimes, the empty list is a wildcard and matches any coupling: *)
let match_coupling c cs =
List.mem c cs
let match_coupling_wildcard c = function
| [] -> true
| cs -> match_coupling c cs
let to_select_vtx cascades =
match cascades.vertices with
| [] ->
(* No vertex constraints means that we always accept. *)
(fun c f fs -> true)
| vertices ->
match translate_vertices vertices with
| [], ([],[],[]) ->
(* If [cascades.vertices] is not empty, we mustn't
get here \ldots *)
failwith "Cascade.to_select_vtx: unexpected"
| couplings, ([],[],[]) ->
(* No constraints on the fields. Just make sure that the
coupling [c] doesn't appear in the vetoed [couplings]. *)
(fun c f fs ->
let c = unpack_constant c in
not (match_coupling c couplings))
| couplings, vertices ->
(* Make sure that [Fusions.of_vertices] is only evaluated
once for efficiency. *)
let fusions = Fusions.of_vertices vertices in
(fun c f fs ->
let c = unpack_constant c in
(* Make sure that none of the vetoed [couplings] matches.
Here an empty [couplings] list is \emph{not} a
wildcard. *)
if match_coupling c couplings then
false
else
(* Also make sure that none of the vetoed [vertices]
matches. Here an empty [couplings] list \emph{is}
a wildcard. *)
not (List.exists
(fun (f', cs') ->
let cs' = unpack_constant cs' in
f = f' && match_coupling_wildcard c cs')
(Fusions.fuse fusions fs)))
(* \begin{dubious}
Not a working implementation yet, but it isn't used either \ldots
\end{dubious} *)
- module IPowSet =
- PowSet.Make (struct type t = int let compare = compare let to_string = string_of_int end)
+ module IPowSet = PowSet.Make (Int)
let rec coarsest_partition' = function
| True | False -> IPowSet.empty
| On_shell (_, momentum) | On_shell_not (_, momentum)
| Off_shell (_, momentum) | Off_shell_not (_, momentum)
| Gauss (_, momentum) | Gauss_not (_, momentum)
| Any_flavor momentum -> IPowSet.of_lists [P.to_ints momentum]
| And [] -> IPowSet.empty
| And cs -> IPowSet.basis (IPowSet.union (List.map coarsest_partition' cs))
let coarsest_partition cascades =
let p = coarsest_partition' cascades in
if IPowSet.is_empty p then
[]
else
IPowSet.to_lists p
let part_to_string part =
"{" ^ String.concat "," (List.map string_of_int part) ^ "}"
let partition_to_string = function
| [] -> ""
| parts ->
" grouping {" ^ String.concat "," (List.map part_to_string parts) ^ "}"
let to_selectors = function
| { wf = True; flavors = []; vertices = [] } -> no_cascades
| c ->
let partition = coarsest_partition c.wf in
{ select_p = to_select_p c.wf;
select_wf = to_select_wf c;
on_shell = to_on_shell c.wf;
is_gauss = to_gauss c.wf;
select_vtx = to_select_vtx c;
partition = partition;
description = Some (to_string c ^ partition_to_string partition) }
(*i
let to_selectors cascades =
prerr_endline (">>> " ^ to_string cascades);
to_selectors cascades
i*)
end
Index: trunk/omega/src/omega_NMSSM_CKM.ml
===================================================================
--- trunk/omega/src/omega_NMSSM_CKM.ml (revision 8899)
+++ trunk/omega/src/omega_NMSSM_CKM.ml (revision 8900)
@@ -1,26 +1,26 @@
(* omega_NMSSM_CKM.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23_Majorana_vintage(Targets.Fortran_Majorana)(Modellib_NMSSM.NMSSM_func(Modellib_NMSSM.NMSSM_CKM))
+module O = Omega.Mixed23_Majorana_vintage(Target_Fortran.Make_Majorana)(Modellib_NMSSM.NMSSM_func(Modellib_NMSSM.NMSSM_CKM))
let _ = O.main ()
Index: trunk/omega/src/thoArray.mli
===================================================================
--- trunk/omega/src/thoArray.mli (revision 8899)
+++ trunk/omega/src/thoArray.mli (revision 8900)
@@ -1,71 +1,70 @@
(* thoArray.mli --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
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. *)
(* Compressed arrays, i.\,e.~arrays with only unique elements and
an embedding that allows to recover the original array.
NB: in the current implementation, compressing saves space,
if \emph{and only if} objects of type ['a] require more storage
than integers. The main use of ['a compressed] is \emph{not} for
saving space, anyway, but for avoiding the repetition of hard
calculations. *)
type 'a compressed
val uniq : 'a compressed -> 'a array
val embedding : 'a compressed -> int array
(* These two are inverses of each other: *)
val compress : 'a array -> 'a compressed
val uncompress : 'a compressed -> 'a array
(* One can play the same game for matrices. *)
type 'a compressed2
val uniq2 : 'a compressed2 -> 'a array array
val embedding1 : 'a compressed2 -> int array
val embedding2 : 'a compressed2 -> int array
(* Again, these two are inverses of each other: *)
val compress2 : 'a array array -> 'a compressed2
val uncompress2 : 'a compressed2 -> 'a array array
(* [compare cmp a1 a2] compare two arrays [a1] and [a2] according to
[cmp]. [cmp] defaults to the polymorphic [Pervasives.compare]. *)
val compare : ?cmp:('a -> 'a -> int) -> 'a array -> 'a array -> int
(* Searching arrays *)
val find_first : ('a -> bool) -> 'a array -> int
val match_first : 'a -> 'a array -> int
val find_all : ('a -> bool) -> 'a array -> int list
val match_all : 'a -> 'a array -> int list
val num_rows : 'a array array -> int
val num_columns : 'a array array -> int
-module Test : sig val suite : OUnit.test end
+(* Implement the Fisher-Yates shuffle to randomly
+ shuffle an array in place, cf.~\cite{TAOCP2}, pp.~139-140. *)
+val shuffle : 'a array -> unit
+
+val rank3 : int -> int -> int -> 'a -> 'a array array array
-(*i
- * Local Variables:
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
+module Test : sig val suite : OUnit.test end
Index: trunk/omega/src/orders_parser.mly
===================================================================
--- trunk/omega/src/orders_parser.mly (revision 0)
+++ trunk/omega/src/orders_parser.mly (revision 8900)
@@ -0,0 +1,96 @@
+/* orders_parser.mly --
+
+ Copyright (C) 2023- by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+
+ WHIZARD is free software; you can redistribute it and/or modify it
+ under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ WHIZARD is distributed in the hope that it will be useful, but
+ WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */
+
+%{
+open Orders_syntax
+let parse_error msg =
+ raise (Syntax_Error (msg, symbol_start (), symbol_end ()))
+%}
+
+%token < string > ID
+%token < int > INT
+%token OR AND EQ BACKSLASH TILDE RANGE COMMA
+%token LPAREN RPAREN LBRACE RBRACE LBRACKET RBRACKET
+%token SEMI
+%token END
+
+%left OR
+%left AND
+%left BACKSLASH
+%nonassoc TILDE
+
+%start main
+%type < Orders_syntax.t > main
+
+%%
+
+main:
+ END { And [] }
+ | condition END { $1 }
+ | conjunction END { And $1 }
+ | alternative END { Or $1 }
+;
+
+condition:
+ atom { Atom $1 }
+ | LPAREN conjunction RPAREN { And $2 }
+ | LPAREN alternative RPAREN { Or $2 }
+;
+
+conjunction:
+ condition { [$1] }
+ | condition AND conjunction { $1 :: $3 }
+ | condition SEMI conjunction { $1 :: $3 }
+;
+
+alternative:
+ condition { [$1] }
+ | condition OR alternative { $1 :: $3 }
+;
+
+atom:
+ set EQ LBRACE range RBRACE { Slices ($1, $4) }
+ | set EQ LBRACKET range RBRACKET { Interval ($1, $4) }
+ | set EQ INT { Exact ($1, $3) }
+ | set { Null $1 }
+;
+
+set:
+ LBRACE RBRACE { Set [] }
+ | ID { Set [$1] }
+ | LBRACE orders RBRACE { Set $2 }
+ | TILDE set { Complement $2 }
+ | set BACKSLASH set { Diff ($1, $3) }
+;
+
+orders:
+ ID { [$1] }
+ | ID COMMA orders { $1 :: $3 }
+;
+
+range:
+ RANGE INT { Max $2 }
+ | INT RANGE { Min $1 }
+ | INT RANGE INT { Range ($1, $3) }
+ | INT { Range ($1, $1) }
+;
+
Index: trunk/omega/src/algebra.mli
===================================================================
--- trunk/omega/src/algebra.mli (revision 8899)
+++ trunk/omega/src/algebra.mli (revision 8900)
@@ -1,296 +1,347 @@
(* algebra.mli --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
module type Test =
sig
val suite : OUnit.test
end
(* \thocwmodulesection{Coefficients} *)
-(* For our algebra, we need coefficient rings. *)
+(* For our algebra, we need coefficient rings with addition, subtraction,
+ multiplication and the corresponding neutral elements. *)
module type CRing =
sig
type t
+
+ (* [add null x = x = add x null] *)
val null : t
- val unit : t
- val mul : t -> t -> t
+ val is_null : t -> bool
val add : t -> t -> t
- val sub : t -> t -> t
+
+ (* [neg x = sub null x] and [sub x y = add x (neg y)] *)
val neg : t -> t
- val to_string : t -> string
+ val sub : t -> t -> t
+
+ (* [mul unit x = x = mul x unit] *)
+ val unit : t
+ val is_unit : t -> bool
+ val mul : t -> t -> t
+
+ (* Equality: *)
+ val equal : t -> t -> bool
+
end
-(* And rational numbers provide a particularly important example: *)
+(* Rational numbers provide a particularly important example and they come
+ with a partial inverse: *)
module type Rational =
sig
include CRing
- val is_null : t -> bool
- val is_unit : t -> bool
val is_positive : t -> bool
val is_negative : t -> bool
val is_integer : t -> bool
val make : int -> int -> t
val abs : t -> t
val inv : t -> t
val div : t -> t -> t
val pow : t -> int -> t
val sum : t list -> t
val to_ratio : t -> int * int
val to_float : t -> float
val to_integer : t -> int
+ (* Convenience: $n \mapsto n/1$ and $n \mapsto 1/n$ *)
+ val int : int -> t
+ val fraction : int -> t
+ (* Order *)
+ val compare : t -> t -> int
+ (* Tracing, debugging, toplevel and unit testing *)
+ val to_string : t -> string
+ val pp : Format.formatter -> t -> unit
module Test : Test
end
(* \thocwmodulesection{Naive Rational Arithmetic} *)
(* \begin{dubious}
This \emph{is} dangerous and will overflow even for simple
applications. The production code will have to be linked to
a library for large integer arithmetic.
\end{dubious} *)
module Small_Rational : Rational
module Q : Rational
(* \thocwmodulesection{Rational Complex Numbers} *)
module type QComplex =
sig
- type q
- type t
+ include CRing
+ type q
val make : q -> q -> t
- val null : t
- val unit : t
-
- val real : t -> q
- val imag : t -> q
+ val re : t -> q
+ val im : t -> q
val conj : t -> t
- val neg : t -> t
- val add : t -> t -> t
- val sub : t -> t -> t
- val mul : t -> t -> t
val inv : t -> t
val div : t -> t -> t
val pow : t -> int -> t
val sum : t list -> t
- val is_null : t -> bool
- val is_unit : t -> bool
val is_positive : t -> bool
val is_negative : t -> bool
val is_integer : t -> bool
val is_real : t -> bool
- val to_string : t -> string
+ (* Convenience: real rationals and integers, *)
+ val rational : q -> t
+ val int : int -> t
+
+ (* $n \to 1/n$ *)
+ val fraction : int -> t
+
+ (* $n \to n\ii$ *)
+ val imag : int -> t
+ (* Order *)
+ val compare : t -> t -> int
+
+ (* Tracing, debugging, toplevel and unit testing *)
+ val to_string : t -> string
+ val pp : Format.formatter -> t -> unit
module Test : Test
end
module QComplex : functor (Q' : Rational) -> QComplex with type q = Q'.t
module QC : QComplex with type q = Q.t
(* \thocwmodulesection{Laurent Polynomials} *)
(* Polynomials, including negative powers, in one variable.
In our applications, the variable~$x$ will often be~$N_C$,
the number of colors
\begin{equation}
\sum_n c_n N_C^n
\end{equation} *)
module type Laurent =
sig
+ include CRing
+
(* The type of coefficients. In the implementation below,
it is [QComplex.t]: complex numbers with rational real
and imaginary parts. *)
type c
- type t
-
- (* Elementary constructors *)
- val null : t
- val is_null : t -> bool
- val unit : t
(* [atom c n] constructs a term $c x^n$, where $x$ denotes
the variable. *)
val atom : c -> int -> t
(* Shortcut: [const c = atom c 0] *)
val const : c -> t
(* Elementary arithmetic *)
val scale : c -> t -> t
- val neg : t -> t
- val add : t -> t -> t
- val diff : t -> t -> t
val sum : t list -> t
- val mul : t -> t -> t
val product : t list -> t
- val pow : int -> t -> t
+ val pow : t -> int -> t
+
+ (* [log]$(cN_C^n)$ returns [Some]$(c,n)$. For other terms,
+ [log] returns [None]. *)
+ val log : t -> (c * int) option
+
+ (* return the corresponding list of coefficients and descending powers *)
+ val to_list : t -> (c * int) list
(* [eval c p] evaluates the polynomial [p] by substituting
the constant [c] for the variable. *)
val eval : c -> t -> c
(* A total ordering. Does not correspond to any mathematical order. *)
val compare : t -> t -> int
- (* Logging, debugging and toplevel integration. *)
+ (* Provide some convenience functions for constructing coefficients
+ from integers and rationals. *)
+
+ (* Rationals coefficients (without imaginary part!)
+ $\left\{(q_i,n_i)\right\}_n \mapsto \sum_i q_i x^{n_i}$ *)
+ val rationals : (Q.t * int) list -> t
+
+ (* Integer coefficients
+ $\left\{(k_i,n_i)\right\}_n \mapsto \sum_i k_i x^{n_i}$ *)
+ val ints : (int * int) list -> t
+
+ (* For convenience, some special cases. Starting with injections *)
+ val rational : Q.t -> t
+ val int : int -> t
+
+ (* $k\mapsto 1/k = k^{-1}$ *)
+ val fraction : int -> t
+
+ (* $k\mapsto k \ii$ *)
+ val imag : int -> t
+
+ (* $k\mapsto k x$ *)
+ val nc : int -> t
+
+ (* $k\mapsto k / x = k x^{-1}$ *)
+ val over_nc : int -> t
+
+ (* Tracing, debugging, toplevel and unit testing *)
val to_string : string -> t -> string
val pp : Format.formatter -> t -> unit
module Test : Test
+
end
(* \begin{dubious}
Could (should?) be functorialized over [QComplex].
We had to wait until we upgraded our O'Caml requirements to 4.02,
but that has been done.
\end{dubious} *)
module Laurent : Laurent with type c = QC.t
(* \thocwmodulesection{Expressions: Terms, Rings and Linear Combinations} *)
(* The tensor algebra will be spanned by an abelian monoid: *)
module type Term =
sig
type 'a t
val unit : unit -> 'a t
val is_unit : 'a t -> bool
val atom : 'a -> 'a t
- val power : int -> 'a t -> 'a t
+ val power : 'a t -> int -> 'a t
val mul : 'a t -> 'a t -> 'a t
val map : ('a -> 'b) -> 'a t -> 'b t
val to_string : ('a -> string) -> 'a t -> string
(* The derivative of a term is \emph{not} a term,
but a sum of terms instead:
\begin{equation}
D (f_1^{p_1}f_2^{p_2}\cdots f_n^{p_n}) =
\sum_i (Df_i) p_i f_1^{p_1}f_2^{p_2}\cdots f_i^{p_i-1} \cdots f_n^{p_n}
\end{equation}
The function returns the sum as a list of triples
$(Df_i,p_i, f_1^{p_1}f_2^{p_2}\cdots f_i^{p_i-1} \cdots f_n^{p_n})$.
Summing the terms is left to the calling module and the $Df_i$ are
\emph{not} guaranteed to be different.
NB: The function implementating the inner derivative, is supposed to
return~[Some]~$Df_i$ and [None], iff~$Df_i$ vanishes. *)
val derive : ('a -> 'b option) -> 'a t -> ('b * int * 'a t) list
(* convenience function *)
val product : 'a t list -> 'a t
val atoms : 'a t -> 'a list
end
module type Ring =
sig
module C : Rational
type 'a t
val null : unit -> 'a t
val unit : unit -> 'a t
val is_null : 'a t -> bool
val is_unit : 'a t -> bool
val atom : 'a -> 'a t
val scale : C.t -> 'a t -> 'a t
val add : 'a t -> 'a t -> 'a t
val sub : 'a t -> 'a t -> 'a t
val mul : 'a t -> 'a t -> 'a t
val neg : 'a t -> 'a t
(* Again
\begin{equation}
D (f_1^{p_1}f_2^{p_2}\cdots f_n^{p_n}) =
\sum_i (Df_i) p_i f_1^{p_1}f_2^{p_2}\cdots f_i^{p_i-1} \cdots f_n^{p_n}
\end{equation}
but, iff~$Df_i$ can be identified with a~$f'$, we know how to perform
the sum. *)
val derive_inner : ('a -> 'a t) -> 'a t -> 'a t (* this? *)
val derive_inner' : ('a -> 'a t option) -> 'a t -> 'a t (* or that? *)
(* Below, we will need partial derivatives that lead out of the ring:
[derive_outer derive_atom term] returns a list of partial derivatives
['b] with non-zero coefficients ['a t]: *)
val derive_outer : ('a -> 'b option) -> 'a t -> ('b * 'a t) list
(* convenience functions *)
val sum : 'a t list -> 'a t
val product : 'a t list -> 'a t
(* The list of all generators appearing in an expression: *)
val atoms : 'a t -> 'a list
val to_string : ('a -> string) -> 'a t -> string
end
module type Linear =
sig
module C : Ring
type ('a, 'c) t
val null : unit -> ('a, 'c) t
val atom : 'a -> ('a, 'c) t
val singleton : 'c C.t -> 'a -> ('a, 'c) t
val scale : 'c C.t -> ('a, 'c) t -> ('a, 'c) t
val add : ('a, 'c) t -> ('a, 'c) t -> ('a, 'c) t
val sub : ('a, 'c) t -> ('a, 'c) t -> ('a, 'c) t
(* A partial derivative w.\,r.\,t.~a vector maps from a coefficient ring to
the dual vector space. *)
val partial : ('c -> ('a, 'c) t) -> 'c C.t -> ('a, 'c) t
(* A linear combination of vectors
\begin{equation}
\text{[linear]} \lbrack (v_1, c_1); (v_2, c_2); \ldots; (v_n, c_n)\rbrack
= \sum_{i=1}^{n} c_i\cdot v_i
\end{equation} *)
val linear : (('a, 'c) t * 'c C.t) list -> ('a, 'c) t
(* Some convenience functions *)
val map : ('a -> 'c C.t -> ('b, 'd) t) -> ('a, 'c) t -> ('b, 'd) t
val sum : ('a, 'c) t list -> ('a, 'c) t
(* The list of all generators and the list of all generators of coefficients
appearing in an expression: *)
val atoms : ('a, 'c) t -> 'a list * 'c list
val to_string : ('a -> string) -> ('c -> string) -> ('a, 'c) t -> string
end
module Term : Term
module Make_Ring (C : Rational) (T : Term) : Ring
module Make_Linear (C : Ring) : Linear with module C = C
Index: trunk/omega/src/omega_MSSM_Grav.ml
===================================================================
--- trunk/omega/src/omega_MSSM_Grav.ml (revision 8899)
+++ trunk/omega/src/omega_MSSM_Grav.ml (revision 8900)
@@ -1,34 +1,26 @@
(* omega_MSSM_Grav.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23_Majorana_vintage(Targets.Fortran_Majorana)(Modellib_MSSM.MSSM(Modellib_MSSM.MSSM_Grav))
+module O = Omega.Mixed23_Majorana_vintage(Target_Fortran.Make_Majorana)(Modellib_MSSM.MSSM(Modellib_MSSM.MSSM_Grav))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/bundle.ml
===================================================================
--- trunk/omega/src/bundle.ml (revision 8899)
+++ trunk/omega/src/bundle.ml (revision 8900)
@@ -1,150 +1,145 @@
(* bundle.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
module type Elt_Base =
sig
type elt
type base
val compare_elt : elt -> elt -> int
val compare_base : base -> base -> int
end
module type Dyn =
sig
type t
type elt
type fiber = elt list
type base
- val add : (elt -> base) -> elt -> t -> t
+ val empty : t
+ val add : (elt -> base) -> t -> elt -> t
val of_list : (elt -> base) -> elt list -> t
- val inv_pi : base -> t -> fiber
+ val inv_pi : t -> base -> fiber
val base : t -> base list
- val fiber : (elt -> base) -> elt -> t -> fiber
+ val fiber : (elt -> base) -> t -> elt -> fiber
val fibers : t -> (base * fiber) list
end
module Dyn (P : Elt_Base) =
struct
type elt = P.elt
type base = P.base
type fiber = elt list
module InvPi = Map.Make (struct type t = P.base let compare = P.compare_base end)
module Fiber = Set.Make (struct type t = P.elt let compare = P.compare_elt end)
type t = Fiber.t InvPi.t
- let add pi element fibers =
+ let empty = InvPi.empty
+
+ let add pi fibers element =
let base = pi element in
let fiber =
try InvPi.find base fibers with Not_found -> Fiber.empty in
InvPi.add base (Fiber.add element fiber) fibers
let of_list pi list =
- List.fold_right (add pi) list InvPi.empty
+ List.fold_left (add pi) InvPi.empty list
let fibers bundle =
- InvPi.fold
- (fun base fiber acc -> (base, Fiber.elements fiber) :: acc) bundle []
+ InvPi.fold (fun base fiber acc -> (base, Fiber.elements fiber) :: acc) bundle []
let base bundle =
- InvPi.fold
- (fun base fiber acc -> base :: acc) bundle []
+ InvPi.fold (fun base fiber acc -> base :: acc) bundle []
- let inv_pi base bundle =
+ let inv_pi bundle base =
try
Fiber.elements (InvPi.find base bundle)
with
| Not_found -> []
- let fiber pi elt bundle =
- inv_pi (pi elt) bundle
+ let fiber pi bundle elt =
+ inv_pi bundle (pi elt)
end
module type Projection =
sig
include Elt_Base
val pi : elt -> base
end
module type T =
sig
type t
type elt
type fiber = elt list
type base
- val add : elt -> t -> t
+ val empty : t
+ val add : t -> elt -> t
val of_list : elt list -> t
val pi : elt -> base
- val inv_pi : base -> t -> fiber
+ val inv_pi : t -> base -> fiber
val base : t -> base list
- val fiber : elt -> t -> fiber
+ val fiber : t -> elt -> fiber
val fibers : t -> (base * fiber) list
end
module Make (P : Projection) =
struct
module D = Dyn (P)
type elt = D.elt
type base = D.base
type fiber = D.fiber
type t = D.t
+ let empty = D.empty
let pi = P.pi
let add = D.add pi
let of_list = D.of_list pi
let base = D.base
let inv_pi = D.inv_pi
let fibers = D.fibers
- let fiber elt bundle =
- inv_pi (pi elt) bundle
+ let fiber bundle elt =
+ inv_pi bundle (pi elt)
end
(*i
module Test = Make (struct
type fiber = int
type base = int
let compare_fiber = compare
let compare_base = compare
let pi = abs
end)
let sample = [-1; -4; 7; -8; 9; 42; -137; -42; 42; 4; 1; -9]
Test.fibers (Test.classify sample);;
i*)
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/orders_lexer.mll
===================================================================
--- trunk/omega/src/orders_lexer.mll (revision 0)
+++ trunk/omega/src/orders_lexer.mll (revision 8900)
@@ -0,0 +1,59 @@
+(* orders_lexer.mll --
+
+ Copyright (C) 1999-2023 by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+ with contributions from
+ Christian Speckner <cnspeckn@googlemail.com>
+
+ WHIZARD is free software; you can redistribute it and/or modify it
+ under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ WHIZARD is distributed in the hope that it will be useful, but
+ WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
+
+{
+open Orders_parser
+let unquote s =
+ String.sub s 1 (String.length s - 2)
+}
+
+let digit = ['0'-'9']
+let upper = ['A'-'Z']
+let lower = ['a'-'z']
+let char = upper | lower
+let word = char | digit | '_'
+let white = [' ' '\t' '\n']
+
+(* We use a very liberal definition of strings for flavor names. *)
+rule token = parse
+ white { token lexbuf } (* skip blanks *)
+ | '#' [^'\n']* '\n'
+ { token lexbuf } (* skip comments *)
+ | digit+ { INT (int_of_string (Lexing.lexeme lexbuf)) }
+ | '=' { EQ }
+ | '~' { TILDE }
+ | '\\' '\\'? { BACKSLASH }
+ | '{' { LBRACE }
+ | '}' { RBRACE }
+ | '[' { LBRACKET }
+ | ']' { RBRACKET }
+ | '(' { LPAREN }
+ | ')' { RPAREN }
+ | ';' { SEMI }
+ | '&' '&'? { AND }
+ | '|' '|'? { OR }
+ | '.' '.' { RANGE }
+ | ',' { COMMA }
+ | char word* { ID (Lexing.lexeme lexbuf) }
+ | eof { END }
Index: trunk/omega/src/omega_SM_top.ml
===================================================================
--- trunk/omega/src/omega_SM_top.ml (revision 8899)
+++ trunk/omega/src/omega_SM_top.ml (revision 8900)
@@ -1,629 +1,624 @@
(* omega_SM_top.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
(* \thocwmodulesection{SM with charge $4/3$ top} *)
module type SM_flags =
sig
val include_anomalous : bool
val k_matrix : bool
end
module SM_no_anomalous : SM_flags =
struct
let include_anomalous = false
let k_matrix = false
end
module SM_gluons : SM_flags =
struct
let include_anomalous = false
let k_matrix = false
end
module Anomtop (Flags : SM_flags) =
struct
open Coupling
let default_width = ref Timelike
let use_fudged_width = ref false
let options = Options.create
[ "constant_width", Arg.Unit (fun () -> default_width := Constant),
"use constant width (also in t-channel)";
"fudged_width", Arg.Set use_fudged_width,
"use fudge factor for charge particle width";
"custom_width", Arg.String (fun f -> default_width := Custom f),
"use custom width";
"cancel_widths", Arg.Unit (fun () -> default_width := Vanishing),
"use vanishing width";
"running_width", Arg.Unit (fun () -> default_width := Running),
"use running width" ]
let caveats () = []
type matter_field = L of int | N of int | U of int | D of int
type gauge_boson = Ga | Wp | Wm | Z | Gl
type other = Phip | Phim | Phi0 | H
type flavor = M of matter_field | G of gauge_boson | O of other
let matter_field f = M f
let gauge_boson f = G f
let other f = O f
type field =
| Matter of matter_field
| Gauge of gauge_boson
| Other of other
let field = function
| M f -> Matter f
| G f -> Gauge f
| O f -> Other f
type gauge = unit
let gauge_symbol () =
failwith "Models.Anomtop.gauge_symbol: internal error"
let family n = List.map matter_field [ L n; N n; U n; D n ]
let external_flavors () =
[ "1st Generation", ThoList.flatmap family [1; -1];
"2nd Generation", ThoList.flatmap family [2; -2];
"3rd Generation", ThoList.flatmap family [3; -3];
"Gauge Bosons", List.map gauge_boson [Ga; Z; Wp; Wm; Gl];
"Higgs", [O H];
"Goldstone Bosons", List.map other [Phip; Phim; Phi0] ]
let flavors () = ThoList.flatmap snd (external_flavors ())
let spinor n =
if n >= 0 then
Spinor
else
ConjSpinor
let lorentz = function
| M f ->
begin match f with
| L n -> spinor n | N n -> spinor n
| U n -> spinor n | D n -> spinor n
end
| G f ->
begin match f with
| Ga | Gl -> Vector
| Wp | Wm | Z -> Massive_Vector
end
| O f ->
Scalar
- let color = function
+ let color = function
| M (U n) -> Color.SUN (if n > 0 then 3 else -3)
| M (D n) -> Color.SUN (if n > 0 then 3 else -3)
| G Gl -> Color.AdjSUN 3
| _ -> Color.Singlet
let nc () = 3
let prop_spinor n =
if n >= 0 then
Prop_Spinor
else
Prop_ConjSpinor
let propagator = function
| M f ->
begin match f with
| L n -> prop_spinor n | N n -> prop_spinor n
| U n -> prop_spinor n | D n -> prop_spinor n
end
| G f ->
begin match f with
| Ga | Gl -> Prop_Feynman
| Wp | Wm | Z -> Prop_Unitarity
end
| O f ->
begin match f with
| Phip | Phim | Phi0 -> Only_Insertion
| H -> Prop_Scalar
end
(* Optionally, ask for the fudge factor treatment for the widths of
charged particles. Currently, this only applies to $W^\pm$ and top. *)
let width f =
if !use_fudged_width then
match f with
| G Wp | G Wm | M (U 3) | M (U (-3)) -> Fudged
| _ -> !default_width
else
!default_width
let goldstone = function
| G f ->
begin match f with
| Wp -> Some (O Phip, Coupling.Integer 1)
| Wm -> Some (O Phim, Coupling.Integer 1)
| Z -> Some (O Phi0, Coupling.Integer 1)
| _ -> None
end
| _ -> None
let conjugate = function
| M f ->
M (begin match f with
| L n -> L (-n) | N n -> N (-n)
| U n -> U (-n) | D n -> D (-n)
end)
| G f ->
G (begin match f with
| Gl -> Gl | Ga -> Ga | Z -> Z
| Wp -> Wm | Wm -> Wp
end)
| O f ->
O (begin match f with
| Phip -> Phim | Phim -> Phip | Phi0 -> Phi0
| H -> H
end)
let fermion = function
| M f ->
begin match f with
| L n -> if n > 0 then 1 else -1
| N n -> if n > 0 then 1 else -1
| U n -> if n > 0 then 1 else -1
| D n -> if n > 0 then 1 else -1
end
| G f ->
begin match f with
| Gl | Ga | Z | Wp | Wm -> 0
end
| O _ -> 0
(* Electrical charge, lepton number, baryon number. We could avoid the
rationals altogether by multiplying the first and last by 3 \ldots *)
module Ch = Charges.QQ
let ( // ) = Algebra.Small_Rational.make
let generation' = function
| 1 -> [ 1//1; 0//1; 0//1]
| 2 -> [ 0//1; 1//1; 0//1]
| 3 -> [ 0//1; 0//1; 1//1]
| -1 -> [-1//1; 0//1; 0//1]
| -2 -> [ 0//1; -1//1; 0//1]
| -3 -> [ 0//1; 0//1; -1//1]
| n -> invalid_arg ("SM_top.generation': " ^ string_of_int n)
let generation f =
match f with
| M (L n | N n | U n | D n) -> generation' n
| G _ | O _ -> [0//1; 0//1; 0//1]
let charge = function
| M f ->
begin match f with
| L n -> if n > 0 then -1//1 else 1//1
| N n -> 0//1
| U (1|2) -> 2//3
| U ((-1)|(-2)) -> -2//3
| U 3 -> -4//3
| U (-3) -> 4//3
| U n -> invalid_arg ("SM_top.charge: up quark " ^ string_of_int n)
| D n -> if n > 0 then -1//3 else 1//3
end
| G f ->
begin match f with
| Gl | Ga | Z -> 0//1
| Wp -> 1//1
| Wm -> -1//1
end
| O f ->
begin match f with
| H | Phi0 -> 0//1
| Phip -> 1//1
| Phim -> -1//1
end
let lepton = function
| M f ->
begin match f with
| L n | N n -> if n > 0 then 1//1 else -1//1
| U _ | D _ -> 0//1
end
| G _ | O _ -> 0//1
let baryon = function
| M f ->
begin match f with
| L _ | N _ -> 0//1
| U n | D n -> if n > 0 then 1//1 else -1//1
end
| G _ | O _ -> 0//1
let charges f =
[ charge f; lepton f; baryon f] @ generation f
type constant =
| Unit | Pi | Alpha_QED | Sin2thw
| Sinthw | Costhw | E | G_weak | Vev
| Q_lepton | Q_up | Q_down | Q_top | G_CC
| G_NC_neutrino | G_NC_lepton | G_NC_up | G_NC_down | G_NC_top
| I_Q_W | I_G_ZWW
| G_WWWW | G_ZZWW | G_AZWW | G_AAWW
| G_HWW | G_HHWW | G_HZZ | G_HHZZ
| G_Htt | G_Hbb | G_Hcc | G_Htautau | G_H3 | G_H4
| Gs | I_Gs | G2
| Mass of flavor | Width of flavor
(* Two integer counters for the QCD and EW order of the couplings. *)
- type orders = int * int
+ type coupling_order = QCD | EW
+ let all_coupling_orders () = [QCD; EW]
+ let coupling_order_to_string = function
+ | QCD -> "QCD"
+ | EW -> "EW"
- let orders = function
- | _ -> (0,0)
+ let coupling_orders = function
+ | _ -> failwith "Omega_SM_top.Anomtop.orders: not implemented yet!"
let input_parameters =
[]
let derived_parameters =
[]
let derived_parameter_arrays =
[]
let parameters () =
{ input = input_parameters;
derived = derived_parameters;
derived_arrays = derived_parameter_arrays }
module F = Modeltools.Fusions (struct
type f = flavor
type c = constant
let compare = compare
let conjugate = conjugate
end)
(* \begin{equation}
\mathcal{L}_{\textrm{EM}} =
- e \sum_i q_i \bar\psi_i\fmslash{A}\psi_i
\end{equation} *)
let mgm ((m1, g, m2), fbf, c) = ((M m1, G g, M m2), fbf, c)
let electromagnetic_currents' n =
List.map mgm
[ ((L (-n), Ga, L n), FBF (1, Psibar, V, Psi), Q_lepton);
((D (-n), Ga, D n), FBF (1, Psibar, V, Psi), Q_down) ]
let em_up_type_currents =
List.map mgm
[ ((U (-1), Ga, U 1), FBF (1, Psibar, V, Psi), Q_up);
((U (-2), Ga, U 2), FBF (1, Psibar, V, Psi), Q_up);
((U (-3), Ga, U 3), FBF (1, Psibar, V, Psi), Q_top)]
let electromagnetic_currents =
ThoList.flatmap electromagnetic_currents' [1;2;3] @
em_up_type_currents
let color_currents n =
List.map mgm
[ ((U (-n), Gl, U n), FBF ((-1), Psibar, V, Psi), Gs);
((D (-n), Gl, D n), FBF ((-1), Psibar, V, Psi), Gs) ]
(* \begin{equation}
\mathcal{L}_{\textrm{NC}} =
- \frac{g}{2\cos\theta_W}
\sum_i \bar\psi_i\fmslash{Z}(g_V^i-g_A^i\gamma_5)\psi_i
\end{equation} *)
let neutral_currents' n =
List.map mgm
[ ((L (-n), Z, L n), FBF (1, Psibar, VA, Psi), G_NC_lepton);
((N (-n), Z, N n), FBF (1, Psibar, VA, Psi), G_NC_neutrino);
((D (-n), Z, D n), FBF (1, Psibar, VA, Psi), G_NC_down) ]
let neutral_up_type_currents =
List.map mgm
[ ((U (-1), Z, U 1), FBF (1, Psibar, VA, Psi), G_NC_up);
((U (-2), Z, U 2), FBF (1, Psibar, VA, Psi), G_NC_up);
((U (-3), Z, U 3), FBF (1, Psibar, VA, Psi), G_NC_top) ]
let neutral_currents =
ThoList.flatmap neutral_currents' [1;2;3] @
neutral_up_type_currents
(* \begin{equation}
\mathcal{L}_{\textrm{CC}} =
- \frac{g}{2\sqrt2} \sum_i \bar\psi_i
(T^+\fmslash{W}^+ + T^-\fmslash{W}^-)(1-\gamma_5)\psi_i
\end{equation} *)
let charged_currents' n =
List.map mgm
[ ((L (-n), Wm, N n), FBF (1, Psibar, VL, Psi), G_CC);
((N (-n), Wp, L n), FBF (1, Psibar, VL, Psi), G_CC) ]
let charged_up_currents =
List.map mgm
[ ((U (-1), Wp, D 1), FBF (1, Psibar, VL, Psi), G_CC);
((U (-2), Wp, D 2), FBF (1, Psibar, VL, Psi), G_CC);
((U (-3), Wm, D 3), FBF (1, Psibar, VL, Psi), G_CC);
((D (-1), Wm, U 1), FBF (1, Psibar, VL, Psi), G_CC);
((D (-2), Wm, U 2), FBF (1, Psibar, VL, Psi), G_CC);
((D (-3), Wp, U 3), FBF (1, Psibar, VL, Psi), G_CC) ]
let charged_currents =
ThoList.flatmap charged_currents' [1;2;3] @
charged_up_currents
let yukawa =
[ ((M (U (-3)), O H, M (U 3)), FBF (1, Psibar, S, Psi), G_Htt);
((M (D (-3)), O H, M (D 3)), FBF (1, Psibar, S, Psi), G_Hbb);
((M (U (-2)), O H, M (U 2)), FBF (1, Psibar, S, Psi), G_Hcc);
((M (L (-3)), O H, M (L 3)), FBF (1, Psibar, S, Psi), G_Htautau) ]
(* \begin{equation}
\mathcal{L}_{\textrm{TGC}} =
- e \partial_\mu A_\nu W_+^\mu W_-^\nu + \ldots
- e \cot\theta_w \partial_\mu Z_\nu W_+^\mu W_-^\nu + \ldots
\end{equation} *)
let tgc ((g1, g2, g3), t, c) = ((G g1, G g2, G g3), t, c)
let triple_gauge =
List.map tgc
[ ((Ga, Wm, Wp), Gauge_Gauge_Gauge 1, I_Q_W);
((Z, Wm, Wp), Gauge_Gauge_Gauge 1, I_G_ZWW);
((Gl, Gl, Gl), Gauge_Gauge_Gauge 1, I_Gs)]
let qgc ((g1, g2, g3, g4), t, c) = ((G g1, G g2, G g3, G g4), t, c)
let gauge4 = Vector4 [(2, C_13_42); (-1, C_12_34); (-1, C_14_23)]
let minus_gauge4 = Vector4 [(-2, C_13_42); (1, C_12_34); (1, C_14_23)]
let quartic_gauge =
List.map qgc
[ (Wm, Wp, Wm, Wp), gauge4, G_WWWW;
(Wm, Z, Wp, Z), minus_gauge4, G_ZZWW;
(Wm, Z, Wp, Ga), minus_gauge4, G_AZWW;
(Wm, Ga, Wp, Ga), minus_gauge4, G_AAWW;
(Gl, Gl, Gl, Gl), gauge4, G2 ]
let gauge_higgs =
[ ((O H, G Wp, G Wm), Scalar_Vector_Vector 1, G_HWW);
((O H, G Z, G Z), Scalar_Vector_Vector 1, G_HZZ) ]
let gauge_higgs4 =
[ (O H, O H, G Wp, G Wm), Scalar2_Vector2 1, G_HHWW;
(O H, O H, G Z, G Z), Scalar2_Vector2 1, G_HHZZ ]
let higgs =
[ (O H, O H, O H), Scalar_Scalar_Scalar 1, G_H3 ]
let higgs4 =
[ (O H, O H, O H, O H), Scalar4 1, G_H4 ]
let goldstone_vertices =
[ ((O Phi0, G Wm, G Wp), Scalar_Vector_Vector 1, I_G_ZWW);
((O Phip, G Ga, G Wm), Scalar_Vector_Vector 1, I_Q_W);
((O Phip, G Z, G Wm), Scalar_Vector_Vector 1, I_G_ZWW);
((O Phim, G Wp, G Ga), Scalar_Vector_Vector 1, I_Q_W);
((O Phim, G Wp, G Z), Scalar_Vector_Vector 1, I_G_ZWW) ]
let vertices3 =
(electromagnetic_currents @
ThoList.flatmap color_currents [1;2;3] @
neutral_currents @
charged_currents @
yukawa @ triple_gauge @
gauge_higgs @ higgs @ goldstone_vertices)
let vertices4 =
quartic_gauge @ gauge_higgs4 @ higgs4
let vertices () = (vertices3, vertices4, [])
(* For efficiency, make sure that [F.of_vertices vertices] is
evaluated only once. *)
let table = F.of_vertices (vertices ())
let fuse2 = F.fuse2 table
let fuse3 = F.fuse3 table
let fuse = F.fuse table
let max_degree () = 4
let flavor_of_string = function
| "e-" -> M (L 1) | "e+" -> M (L (-1))
| "mu-" -> M (L 2) | "mu+" -> M (L (-2))
| "tau-" -> M (L 3) | "tau+" -> M (L (-3))
| "nue" -> M (N 1) | "nuebar" -> M (N (-1))
| "numu" -> M (N 2) | "numubar" -> M (N (-2))
| "nutau" -> M (N 3) | "nutaubar" -> M (N (-3))
| "u" -> M (U 1) | "ubar" -> M (U (-1))
| "c" -> M (U 2) | "cbar" -> M (U (-2))
| "t" -> M (U 3) | "tbar" -> M (U (-3))
| "d" -> M (D 1) | "dbar" -> M (D (-1))
| "s" -> M (D 2) | "sbar" -> M (D (-2))
| "b" -> M (D 3) | "bbar" -> M (D (-3))
| "g" | "gl" -> G Gl
| "A" -> G Ga | "Z" | "Z0" -> G Z
| "W+" -> G Wp | "W-" -> G Wm
| "H" -> O H
| _ -> invalid_arg "Models.Anomtop.flavor_of_string"
let flavor_to_string = function
| M f ->
begin match f with
| L 1 -> "e-" | L (-1) -> "e+"
| L 2 -> "mu-" | L (-2) -> "mu+"
| L 3 -> "tau-" | L (-3) -> "tau+"
| L _ -> invalid_arg
"Models.Anomtop.flavor_to_string: invalid lepton"
| N 1 -> "nue" | N (-1) -> "nuebar"
| N 2 -> "numu" | N (-2) -> "numubar"
| N 3 -> "nutau" | N (-3) -> "nutaubar"
| N _ -> invalid_arg
"Models.Anomtop.flavor_to_string: invalid neutrino"
| U 1 -> "u" | U (-1) -> "ubar"
| U 2 -> "c" | U (-2) -> "cbar"
| U 3 -> "t" | U (-3) -> "tbar"
| U _ -> invalid_arg
"Models.Anomtop.flavor_to_string: invalid up type quark"
| D 1 -> "d" | D (-1) -> "dbar"
| D 2 -> "s" | D (-2) -> "sbar"
| D 3 -> "b" | D (-3) -> "bbar"
| D _ -> invalid_arg
"Models.Anomtop.flavor_to_string: invalid down type quark"
end
| G f ->
begin match f with
| Gl -> "g"
| Ga -> "A" | Z -> "Z"
| Wp -> "W+" | Wm -> "W-"
end
| O f ->
begin match f with
| Phip -> "phi+" | Phim -> "phi-" | Phi0 -> "phi0"
| H -> "H"
end
let flavor_to_TeX = function
| M f ->
begin match f with
| L 1 -> "e^-" | L (-1) -> "e^+"
| L 2 -> "\\mu^-" | L (-2) -> "\\mu^+"
| L 3 -> "\\tau^-" | L (-3) -> "\\tau^+"
| L _ -> invalid_arg
"Models.Anomtop.flavor_to_TeX: invalid lepton"
| N 1 -> "\\nu_e" | N (-1) -> "\\bar{\\nu}_e"
| N 2 -> "\\nu_\\mu" | N (-2) -> "\\bar{\\nu}_\\mu"
| N 3 -> "\\nu_\\tau" | N (-3) -> "\\bar{\\nu}_\\tau"
| N _ -> invalid_arg
"Models.Anomtop.flavor_to_TeX: invalid neutrino"
| U 1 -> "u" | U (-1) -> "\\bar{u}"
| U 2 -> "c" | U (-2) -> "\\bar{c}"
| U 3 -> "t" | U (-3) -> "\\bar{t}"
| U _ -> invalid_arg
"Models.Anomtop.flavor_to_TeX: invalid up type quark"
| D 1 -> "d" | D (-1) -> "\\bar{d}"
| D 2 -> "s" | D (-2) -> "\\bar{s}"
| D 3 -> "b" | D (-3) -> "\\bar{b}"
| D _ -> invalid_arg
"Models.Anomtop.flavor_to_TeX: invalid down type quark"
end
| G f ->
begin match f with
| Gl -> "g"
| Ga -> "\\gamma" | Z -> "Z"
| Wp -> "W^+" | Wm -> "W^-"
end
| O f ->
begin match f with
| Phip -> "phi+" | Phim -> "phi-" | Phi0 -> "phi0"
| H -> "H"
end
let flavor_symbol = function
| M f ->
begin match f with
| L n when n > 0 -> "l" ^ string_of_int n
| L n -> "l" ^ string_of_int (abs n) ^ "b"
| N n when n > 0 -> "n" ^ string_of_int n
| N n -> "n" ^ string_of_int (abs n) ^ "b"
| U n when n > 0 -> "u" ^ string_of_int n
| U n -> "u" ^ string_of_int (abs n) ^ "b"
| D n when n > 0 -> "d" ^ string_of_int n
| D n -> "d" ^ string_of_int (abs n) ^ "b"
end
| G f ->
begin match f with
| Gl -> "gl"
| Ga -> "a" | Z -> "z"
| Wp -> "wp" | Wm -> "wm"
end
| O f ->
begin match f with
| Phip -> "pp" | Phim -> "pm" | Phi0 -> "p0"
| H -> "h"
end
let pdg = function
| M f ->
begin match f with
| L n when n > 0 -> 9 + 2*n
| L n -> - 9 + 2*n
| N n when n > 0 -> 10 + 2*n
| N n -> - 10 + 2*n
| U n when n > 0 -> 2*n
| U n -> 2*n
| D n when n > 0 -> - 1 + 2*n
| D n -> 1 + 2*n
end
| G f ->
begin match f with
| Gl -> 21
| Ga -> 22 | Z -> 23
| Wp -> 24 | Wm -> (-24)
end
| O f ->
begin match f with
| Phip | Phim -> 27 | Phi0 -> 26
| H -> 25
end
let mass_symbol f =
"mass(" ^ string_of_int (abs (pdg f)) ^ ")"
let width_symbol f =
"width(" ^ string_of_int (abs (pdg f)) ^ ")"
let constant_symbol = function
| Unit -> "unit" | Pi -> "PI"
| Alpha_QED -> "alpha" | E -> "e" | G_weak -> "g" | Vev -> "vev"
| Sin2thw -> "sin2thw" | Sinthw -> "sinthw" | Costhw -> "costhw"
| Q_lepton -> "qlep" | Q_up -> "qup" | Q_down -> "qdwn"
| Q_top -> "qtop"
| G_NC_lepton -> "gnclep" | G_NC_neutrino -> "gncneu"
| G_NC_up -> "gncup" | G_NC_down -> "gncdwn"
| G_NC_top -> "gnctop"
| G_CC -> "gcc"
| I_Q_W -> "iqw" | I_G_ZWW -> "igzww"
| G_WWWW -> "gw4" | G_ZZWW -> "gzzww"
| G_AZWW -> "gazww" | G_AAWW -> "gaaww"
| G_HWW -> "ghww" | G_HZZ -> "ghzz"
| G_HHWW -> "ghhww" | G_HHZZ -> "ghhzz"
| G_Htt -> "ghtt" | G_Hbb -> "ghbb"
| G_Htautau -> "ghtautau" | G_Hcc -> "ghcc"
| G_H3 -> "gh3" | G_H4 -> "gh4"
| Gs -> "gs" | I_Gs -> "igs" | G2 -> "gs**2"
| Mass f -> "mass" ^ flavor_symbol f
| Width f -> "width" ^ flavor_symbol f
end
-module O = Omega.Mixed23(Targets.Fortran)
- (Anomtop(SM_no_anomalous))
+module O = Omega.Mixed23(Target_Fortran.Make)(Anomtop(SM_no_anomalous))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/omega_SM_tt_threshold.ml
===================================================================
--- trunk/omega/src/omega_SM_tt_threshold.ml (revision 8899)
+++ trunk/omega/src/omega_SM_tt_threshold.ml (revision 8900)
@@ -1,27 +1,26 @@
(* omega_SM_tt_threshold.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@physik.uni-freiburg.de>
Christian Speckner <christian.speckner@physik.uni-freiburg.de>
Fabian Bach <fabian.bach@cern.ch> (only this file)
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.Fortran)
- (Modellib_SM.SM(Modellib_SM.SM_tt_threshold))
+module O = Omega.Mixed23(Target_Fortran.Make)(Modellib_SM.SM(Modellib_SM.SM_tt_threshold))
let _ = O.main ()
Index: trunk/omega/src/omega_PSSSM.ml
===================================================================
--- trunk/omega/src/omega_PSSSM.ml (revision 8899)
+++ trunk/omega/src/omega_PSSSM.ml (revision 8900)
@@ -1,34 +1,26 @@
(* omega_PSSSM.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23_Majorana_vintage(Targets.Fortran_Majorana)(Modellib_PSSSM.ExtMSSM(Modellib_PSSSM.PSSSM))
+module O = Omega.Mixed23_Majorana_vintage(Target_Fortran.Make_Majorana)(Modellib_PSSSM.ExtMSSM(Modellib_PSSSM.PSSSM))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/omega_Zprime.ml
===================================================================
--- trunk/omega/src/omega_Zprime.ml (revision 8899)
+++ trunk/omega/src/omega_Zprime.ml (revision 8900)
@@ -1,35 +1,26 @@
(* omega_Zprime.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.Fortran)
- (Modellib_Zprime.Zprime(Modellib_Zprime.SM_no_anomalous))
+module O = Omega.Mixed23(Target_Fortran.Make)(Modellib_Zprime.Zprime(Modellib_Zprime.SM_no_anomalous))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/omega_SSC_AltT.ml
===================================================================
--- trunk/omega/src/omega_SSC_AltT.ml (revision 8899)
+++ trunk/omega/src/omega_SSC_AltT.ml (revision 8900)
@@ -1,36 +1,27 @@
(* omega_SSC.ml --
Copyright (C) 1999-2015 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@physik.uni-freiburg.de>
with contributions from
Marco Sekulla <sekulla@physik.uni-siegen.de>
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.Fortran)
- (Modellib_BSM.SSC_AltT(Modellib_BSM.SSC_kmatrix_2))
+module O = Omega.Mixed23(Target_Fortran.Make)(Modellib_BSM.SSC_AltT(Modellib_BSM.SSC_kmatrix_2))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/omega_Threeshl.ml
===================================================================
--- trunk/omega/src/omega_Threeshl.ml (revision 8899)
+++ trunk/omega/src/omega_Threeshl.ml (revision 8900)
@@ -1,35 +1,26 @@
(* omega_Threeshl.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.Fortran)
- (Modellib_BSM.Threeshl(Modellib_BSM.Threeshl_no_ckm))
+module O = Omega.Mixed23(Target_Fortran.Make)(Modellib_BSM.Threeshl(Modellib_BSM.Threeshl_no_ckm))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/UFOx.mli
===================================================================
--- trunk/omega/src/UFOx.mli (revision 8899)
+++ trunk/omega/src/UFOx.mli (revision 8900)
@@ -1,251 +1,255 @@
(* vertex.mli --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
module Expr :
sig
type t
val of_string : string -> t
val of_strings : string list -> t
val substitute : string -> t -> t -> t
val rename : (string * string) list -> t -> t
val map_names : (string -> string) -> t -> t
val half : string -> t
val variables : t -> Sets.String_Caseless.t
val functions : t -> Sets.String_Caseless.t
end
module Value :
sig
type t
val of_expr : Expr.t -> t
val to_string : t -> string
val to_coupling : (string -> 'b) -> t -> 'b Coupling.expr
end
(* \begin{dubious}
UFO represents rank-2 indices $(i,j)$ as $1000\cdot j + i$.
This should be replaced by a proper union type eventually.
Unfortunately, this requires many changes in the [Atom]s in
[UFOx]. Therefore, we try a quick'n'dirty proof of principle
first.
\end{dubious} *)
module type Index =
sig
type t = int
val position : t -> int
val factor : t -> int
val unpack : t -> int * int
val pack : int -> int -> t
val map_position : (int -> int) -> t -> t
val to_string : t -> string
val list_to_string : t list -> string
(* Indices are represented by a pair [int * 'r], where
['r] denotes the representation the index belongs to. *)
(* [free indices] returns all free indices in the
list [indices], i.\,e.~all positive indices. *)
val free : (t * 'r) list -> (t * 'r) list
(* [summation indices] returns all summation indices in the
list [indices], i.\,e.~all negative indices. *)
val summation : (t * 'r) list -> (t * 'r) list
val classes_to_string : ('r -> string) -> (t * 'r) list -> string
(* Generate summation indices, starting from~$-1001$.
TODO: check that there are no clashes with explicitely
named indices. *)
val fresh_summation : unit -> t
val named_summation : string -> unit -> t
end
module Index : Index
module type Tensor =
sig
type atom
(* A tensor is a linear combination of products of [atom]s
with rational coefficients. The following could be refined
by introducing [scalar] atoms and restricting the denominators
to [(scalar list * Algebra.QC.t) list]. At the moment, this
restriction is implemented dynamically by [of_expr] and not
statically in the type system.
Polymorphic variants appear to be the right tool, either
directly or as phantom types.
However, this is certainly only \textit{nice-to-have}
and is not essential. *)
type 'a linear = ('a list * Algebra.QC.t) list
type t =
| Linear of atom linear
| Ratios of (atom linear * atom linear) list
(* We might need to replace atoms if the syntax is not
context free. *)
val map_atoms : (atom -> atom) -> t -> t
(* We need to rename indices to implement permutations \ldots *)
val map_indices : (int -> int) -> t -> t
(* \ldots{} but in order to to clean up inconsistencies
in the syntax of \texttt{lorentz.py} and
\texttt{propagators.py} we also need to rename indices
without touching the second argument of \texttt{P}, the
argument of \texttt{Mass} etc. *)
val rename_indices : (int -> int) -> t -> t
(* We need scale coefficients. *)
val map_coeff : (Algebra.QC.t -> Algebra.QC.t) -> t -> t
(* Try to contract adjacent pairs of [atoms] as allowed
but [Atom.contract_pair]. This is not exhaustive, but
helps a lot with invariant squares of momenta in
applications of [Lorentz]. *)
val contract_pairs : t -> t
(* The list of variable referenced in the tensor expression,
that will need to be imported by the numerical code. *)
val variables : t -> string list
(* Parsing and unparsing. Lists of [string]s are
interpreted as sums. *)
val of_expr : UFOx_syntax.expr -> t
val of_string : string -> t
val of_strings : string list -> t
val to_string : t -> string
(* The supported representations. *)
type r
val classify_indices : t -> (int * r) list
val rep_to_string : r -> string
val rep_to_string_whizard : r -> string
val rep_of_int : bool -> int -> r
+ val rep_of_int_or_young_tableau : bool -> int option -> int Young.tableau option -> r
val rep_conjugate : r -> r
val rep_trivial : r -> bool
(* There is not a 1-to-1 mapping between the representations
in the model files and the representations used by O'Mega,
e.\,g.~in [Coupling.lorentz]. We might need to use heuristics. *)
type r_omega
val omega : r -> r_omega
end
module type Atom =
sig
type t
val map_indices : (int -> int) -> t -> t
val rename_indices : (int -> int) -> t -> t
val contract_pair : t -> t -> t option
val variable : t -> string option
val scalar : t -> bool
val is_unit : t -> bool
val invertible : t -> bool
val invert : t -> t
val of_expr : string -> UFOx_syntax.expr list -> t list
val to_string : t -> string
type r
val classify_indices : t list -> (int * r) list
val disambiguate_indices : t list -> t list
val rep_to_string : r -> string
val rep_to_string_whizard : r -> string
val rep_of_int : bool -> int -> r
+ val rep_of_int_or_young_tableau : bool -> int option -> int Young.tableau option -> r
val rep_conjugate : r -> r
val rep_trivial : r -> bool
type r_omega
val omega : r -> r_omega
end
module type Lorentz_Atom =
sig
type dirac = private
| C of int * int
| Gamma of int * int * int
| Gamma5 of int * int
| Identity of int * int
| ProjP of int * int
| ProjM of int * int
| Sigma of int * int * int * int
type vector = (* private *)
| Epsilon of int * int * int * int
| Metric of int * int
| P of int * int
type scalar = (* private *)
| Mass of int
| Width of int
| P2 of int
| P12 of int * int
| Variable of string
| Coeff of Value.t
type t = (* private *)
| Dirac of dirac
| Vector of vector
| Scalar of scalar
| Inverse of scalar
val map_indices_scalar : (int -> int) -> scalar -> scalar
val map_indices_vector : (int -> int) -> vector -> vector
val rename_indices_vector : (int -> int) -> vector -> vector
end
module Lorentz_Atom : Lorentz_Atom
module Lorentz : Tensor
with type atom = Lorentz_Atom.t and type r_omega = Coupling.lorentz
module type Color_Atom =
sig
type t = (* private *)
| Identity of int * int
| Identity8 of int * int
+ | Delta of int Young.tableau * int * int
| T of int * int * int
+ | TY of int Young.tableau * int * int * int
| F of int * int * int
| D of int * int * int
| Epsilon of int * int * int
| EpsilonBar of int * int * int
| T6 of int * int * int
| K6 of int * int * int
| K6Bar of int * int * int
end
module Color_Atom : Color_Atom
module Color : Tensor
with type atom = Color_Atom.t and type r_omega = Color.t
module type Test =
sig
val suite : OUnit.test
end
module Test : Test
Index: trunk/omega/src/PArray.ml
===================================================================
--- trunk/omega/src/PArray.ml (revision 0)
+++ trunk/omega/src/PArray.ml (revision 8900)
@@ -0,0 +1,259 @@
+(* PArray.ml --
+
+ Copyright (C) 2022-2023 by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+ with contributions from
+ Christian Speckner <cnspeckn@googlemail.com>
+
+ 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. *)
+
+
+(* \begin{dubious}
+ The [Map] based implementation has the drawback that the polymorphic
+ [compare] and [(=)] will occasionally report two [PArray.t] as
+ different even if they describe the same array. Options
+ \begin{enumerate}
+ \item Replace [compare] by specific functions everywhere. This is
+ the preferred approach, but can become very tedious.
+ \item Replace [Map] by sorted association lists.
+ \end{enumerate}
+ \end{dubious} *)
+
+(* \thocwmodulesection{Maps} *)
+module Maps =
+ struct
+
+ module IMap = Map.Make(Int)
+
+ type 'a t = 'a IMap.t
+
+ let empty = IMap.empty
+ let is_empty = IMap.is_empty
+ let map = IMap.map
+ let add = IMap.add
+ let remove = IMap.remove
+ let get_opt = IMap.find_opt
+
+ let min_key map = fst (IMap.min_binding map)
+ let max_key map = fst (IMap.max_binding map)
+
+ let index_base = 0
+
+ let to_option_list map =
+ if IMap.is_empty map then
+ []
+ else if min_key map < index_base then
+ invalid_arg "PArray.Maps.to_option_list"
+ else
+ let rec to_option_list' acc n =
+ if n < index_base then
+ acc
+ else
+ to_option_list' (get_opt n map :: acc) (pred n) in
+ to_option_list' [] (max_key map)
+
+ let to_string a2s map =
+ match to_option_list map with
+ | [] -> "[]"
+ | [None] -> "?"
+ | [Some a] -> a2s a
+ | pairs -> ThoList.to_string (function None -> "?" | Some a -> a2s a) pairs
+
+ let of_pairs pairs =
+ List.fold_right
+ (fun (k, v) map ->
+ if k < index_base then
+ invalid_arg "PArray.Maps.of_pairs"
+ else
+ IMap.add k v map)
+ pairs IMap.empty
+
+ let to_pairs = IMap.bindings
+
+ let compare = IMap.compare
+ let equal = IMap.equal
+
+ type ('a, 'b) taken =
+ | Nothing of 'b t
+ | Single of int * 'a * 'b t
+ | Multiple of int * 'a * 'a t
+
+ let take_one project_opt parray =
+ let select k v =
+ match project_opt k v with
+ | Some _ -> false
+ | None -> true
+ and project k v =
+ match project_opt k v with
+ | Some v' -> v'
+ | None -> failwith "PArray.Maps.take_one: impossible" in
+ let matches, other = IMap.partition select parray in
+ match IMap.choose_opt matches with
+ | None -> Nothing (IMap.mapi project parray)
+ | Some (k, v) ->
+ let more_matches = remove k matches in
+ if is_empty more_matches then
+ Single (k, v, IMap.mapi project other)
+ else
+ Multiple (k, v, IMap.fold IMap.add more_matches other)
+
+ end
+
+(* \thocwmodulesection{Association Lists} *)
+
+(* We assume that the lists are short and use non tail recursive implementations
+ if they are faster. *)
+
+module Alists =
+ struct
+
+ type 'a t = (int * 'a) list
+
+ let empty = []
+
+ let is_empty = function
+ | [] -> true
+ | _ -> false
+
+ let map f parray =
+ List.map (fun (i, a) -> (i, f a)) parray
+
+ let rec add i a = function
+ | [] -> [(i, a)]
+ | (i', a' as ia') :: tail as alist ->
+ if i' = i then
+ (i, a) :: tail
+ else if i' > i then
+ (i, a) :: alist
+ else
+ ia' :: add i a tail
+
+ let rec remove i = function
+ | [] -> []
+ | (i', _ as ia') :: tail as alist ->
+ if i' = i then
+ tail
+ else if i' > i then
+ alist
+ else
+ ia' :: remove i tail
+
+ let rec get_opt i = function
+ | [] -> None
+ | (i', a') :: tail ->
+ if i' = i then
+ Some a'
+ else
+ get_opt i tail
+
+ let min_key = function
+ | [] -> invalid_arg "PArray.Alists.min_key"
+ | (i, _) :: _ -> i
+
+ let rec max_key = function
+ | [] -> invalid_arg "PArray.Alists.max_key"
+ | [(i, _)] -> i
+ | _ :: tail -> max_key tail
+
+ let index_base = 0
+
+ let to_option_list parray =
+ let rec to_option_list' i = function
+ | [] -> []
+ | (i', a') :: tail ->
+ (if i' = i then Some a' else None) :: to_option_list' (succ i) tail in
+ to_option_list' index_base parray
+
+ let to_string a2s map =
+ match to_option_list map with
+ | [] -> "[]"
+ | [None] -> "?"
+ | [Some a] -> a2s a
+ | pairs -> ThoList.to_string (function None -> "?" | Some a -> a2s a) pairs
+
+ let of_pairs pairs =
+ List.fold_right
+ (fun (i, a) acc ->
+ if i < index_base then
+ invalid_arg "PArray.Alists.of_pairs"
+ else
+ add i a acc)
+ pairs empty
+
+ let to_pairs parray = parray
+
+ let compare _ = compare
+ let equal _ = (=)
+
+ type ('a, 'b) taken =
+ | Nothing of 'b t
+ | Single of int * 'a * 'b t
+ | Multiple of int * 'a * 'a t
+
+ let take_one project_opt parray =
+ let select (k, v) =
+ match project_opt k v with
+ | Some _ -> false
+ | None -> true
+ and project (k, v) =
+ match project_opt k v with
+ | Some v' -> (k, v')
+ | None -> failwith "PArray.Alists.take_one: impossible" in
+ match List.partition select parray with
+ | [], other -> Nothing (List.map project other)
+ | [(k, v)], other -> Single (k, v, List.map project other)
+ | (k, v) :: _, _ -> Multiple (k, v, remove k parray)
+
+ end
+
+include Alists
+
+module Test =
+ struct
+
+ open OUnit
+
+ let project_single _ = function
+ | [v] -> Some v
+ | _ -> None
+
+ let suite_take_one =
+ "take_one" >:::
+ [ "Nothing" >::
+ (fun () ->
+ assert_equal
+ (Nothing (of_pairs [(1, "1"); (3, "3")]))
+ (take_one project_single (of_pairs [(1, ["1"]); (3, ["3"])])));
+
+ "Single" >::
+ (fun () ->
+ assert_equal
+ (Single (2, ["2"; "2"], of_pairs [(1, "1"); (3, "3")]))
+ (take_one project_single (of_pairs [(1, ["1"]); (3, ["3"]); (2, ["2"; "2"])])));
+
+ "Multiple" >::
+ (fun () ->
+ assert_equal
+ (Multiple (2, ["2"; "2"], of_pairs [(1, ["1"]); (3, ["3"]); (4, [])]))
+ (take_one project_single (of_pairs [(1, ["1"]); (3, ["3"]); (2, ["2"; "2"]); (4, [])]))) ]
+
+ let suite =
+ "PArray" >:::
+ [ suite_take_one ]
+
+ end
Index: trunk/omega/src/orders_syntax.ml
===================================================================
--- trunk/omega/src/orders_syntax.ml (revision 0)
+++ trunk/omega/src/orders_syntax.ml (revision 8900)
@@ -0,0 +1,46 @@
+(* orders.ml --
+
+ Copyright (C) 2023- by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+
+ 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. *)
+
+type co = string
+
+type co_set =
+ | Set of co list
+ | Diff of co_set * co_set
+ | Complement of co_set
+
+type range =
+ | Range of int * int
+ | Min of int
+ | Max of int
+
+type atom =
+ | Interval of co_set * range
+ | Slices of co_set * range
+ | Exact of co_set * int
+ | Null of co_set
+
+type t =
+ | Atom of atom
+ | And of t list
+ | Or of t list
+
+exception Syntax_Error of string * int * int
Index: trunk/omega/src/orders.mli
===================================================================
--- trunk/omega/src/orders.mli (revision 0)
+++ trunk/omega/src/orders.mli (revision 8900)
@@ -0,0 +1,299 @@
+(* orders.mli --
+
+ Copyright (C) 1999-2023 by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+
+ WHIZARD is free software; you can redistribute it and/or modify it
+ under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ WHIZARD is distributed in the hope that it will be useful, but
+ WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
+
+
+(* \thocwmodulesection{Conditions} *)
+
+(* The function [of_strings] parses a small domain specific language.
+ The list of strings can be understood as multiple command line options
+ or as lines in a file:
+ \begin{itemize}
+ \item except for newlines, white space is \emph{not} significant.
+ \item newlines are only significant as terminator for comments that start
+ with a~["#"].
+ \item [coupling_order]s are represented as unquoted strings, taken from
+ the codomain of the model's [coupling_order_to_string] function.
+ Strings outside of the codomain trigger a non-terminal error message and are ignored.
+ \item sets of [coupling_order]s are written as comma separated lists,
+ enclosed in matching braces, e.\,.g.~["{QED,QCD}"].
+ \item the braces are optional for single element sets, i.\,e.~["QED"]
+ and~["{QED}"] are equivalent.
+ \item the empty set is represented by ["{}"].
+ \item\relax ["~"] denotes the set complement with respect to the model's
+ [all_coupling_orders ()]. In particular, ["~{}"] denotes
+ [all_coupling_orders ()] and ["~{QED,QCD}"] all coupling orders
+ except~["QED"] and~["QCD"].
+ \item set difference is denoted by \texttt{\textbackslash},
+ i.\,e.~["{QED,QCD} \ QCD"] is just~["QED"] and~["~{} \ QED"]
+ is a complicated way to write ["~QED"].
+ NB: as long as there are no variables for sets, the set difference is probably only
+ useful as syntactic sugar for very few cases.
+ Typical applications can be expressed as set complements. Set union and intersection
+ would be trivial, but appear to be even less useful.
+ \item ranges of orders come as
+ \begin{itemize}
+ \item slices~["{2..3}"] and
+ \item intervals~["[2..3]"].
+ \end{itemize}
+ In the case of slices, code for amplitudes at all orders in the range is generated,
+ while in the case of intervals, code for the sum of these is generated. If there
+ is only one order in the range, the notations~["{3..3}"] or~["{3}"]
+ and~["[3..3]"] or~["[3]"] produce equivalent physics, of course, but the interface
+ code for the generated amplitudes are slightly different of course. In the case of a
+ slice~["{3..3}"], the order~3 will be exposed, while it will not be visible
+ in the case of an interval~["[3..3]"].
+ The abbreviation by a single integer, ["3"], behaves exactly as the
+ slice~["{3..3}"] or~["{3}"].
+ If the systematic expansion is performed in the
+ squared matrix element, slices are more useful than intervals.
+ \item ranges can be limited on one side or on both sides: in the former case,
+ ["[..3]"] is equivalent to~["[0..3]"],
+ while~["[0..]"] is equivalent to no limit at all.
+ \item ranges for sets of coupling constants are set with an equal sign, as
+ in~["{QED,QCD} = {2..4}"]. Note that the range~["0"] need not
+ be spelled out: ["~{QCD}"] is equivalent to~["~{QCD} = 0"]
+ and switches off all couplings with a positive QCD coupling order.
+ \item specifications can be combined by a logical AND~["&&"] or logical
+ OR~["||"] both operators associate to the left and
+ parentheses ["("] and [")"] can be used for grouping
+ (the support for logical OR is limited, but might be extended in
+ the future to fill a gap in [Cascade]).
+ \item combining conditions by a semicolon [";"] or as
+ separate strings corresponds to a logical AND. For example, the following
+ \begin{itemize}
+ \item [of_strings ["QED = {..4}; QCD = {..2}"]]
+ \item [of_strings ["QED = {..4} && QCD = {..2}"]]
+ \item [of_strings ["QED = {..4}"; "QCD = {..2}"]]
+ \end{itemize}
+ are equivalent ways to select upto and including second order in QCD
+ and fourth order in QED
+ \item a logical AND translates to set intersection for coupling orders,
+ e.\,g.~["QCD = {2,4}; QCD = {3,5}"] is equivalent to~["QCD = {3,4}"].
+ In the case of mixed types, the result will be a slice, if at least one
+ of the sets is a slice.
+ \item a natural consequence is that an empty intersection corresponds to
+ switching off the coupling order completely e.\,g.~["QCD = 2; QCD = 4"]
+ is equivalent to~["QCD"] or~["QCD=0"]
+ \item for convenience, there is one exception to this rule: in a logical AND,
+ if one set is~["{0}"], it is ignored and the result is the other set,
+ e.\,g.~["~{}; QCD = 3"] is equivalent to the more verbose~["~{QCD}; QCD = 3"].
+ \item since logical AND associates to the left, the above rules imply
+ that~["QCD = 2; QCD = 4; QCD = 6"] is equivalent to~["QCD = 0; QCD = 6"]
+ and finally to~["QCD = 6"].
+ \end{itemize}
+ The powers of all the coupling orders that are neither set to zero nor summed over
+ will be encoded into the variable names for the shell wave functions. If there are
+ to many of these, we will run into the target language's limits on variable names.
+ In models like typical SMEFT implementations, that define many different coupling orders,
+ one can not ask for ["~{QED,QCD} = [..1]"] in order get all first order new physics
+ contributions. The list of all new physics coupling orders is just too long.
+ Instead one needs to select a specfic coupling or a small set like in
+ ["~{QED,QCD}; NP = [..1]"] *)
+
+module type Conditions =
+ sig
+
+ (* This is the same as [coupling_order] from [Model.T]. *)
+ type coupling_order
+
+ (* Orders is just an abbreviation to make the interface more readable. *)
+ type orders = (coupling_order * int) list
+
+ (* This type collects the conditions on the orders of coupling constants
+ and will be used by the functions below to select coupling constants,
+ fusions and brakets. *)
+ type t
+
+ (* Keep all orders and sum them. *)
+ val trivial : t
+
+ (* Parse a list of strings as described above.*)
+ val of_strings : string list -> t
+
+ (* Return a human readable textual representation that can be inserted
+ into the output source code for documentation. *)
+ val to_strings : t -> string list
+
+ (* The following three predicates test whether coupling orders
+ \begin{itemize}
+ \item have been switched off completely ([constant])
+ \item still can be added to ([fusion])
+ \item satisfy the overall condition ([braket]).
+ \end{itemize} *)
+
+ (* [constant condition (M.coupling_orders c)] checks that none of the
+ [coupling_order]s of the coupling constant [c] is non-zero and
+ switched off in [condition] at the same time. If not, the corresponding
+ fusion or braket can be discarded immediately. *)
+
+ (* \begin{dubious}
+ NB: this can be used very early, before colorization or even during
+ the model definition to avoid constructing pieces that will eventually be
+ discarded anyways.
+ \end{dubious} *)
+ val constant : t -> orders -> bool
+
+ (* Check that none of the [coupling_order]s exceeds the limits. They can
+ be below the lower bounds, since additional fusions might add more powers. *)
+
+ val fusion : t -> orders -> bool
+
+ (* Check that all of the [coupling_order]s are inside the limits.
+ Return only the [coupling_order]s corresponding to
+ slices. This performs the sum over intervals implicitely. *)
+ val braket : t -> orders -> orders option
+
+ (* The list of coupling orders that is neither set to zero nor summed
+ over without constraints. *)
+ val exclusive_fusion : t -> coupling_order list
+
+ (* The list of coupling orders with fixed powers. *)
+ val exclusive_braket : t -> coupling_order list
+
+ (* Compute the coupling order conditions on the scattering amplitude
+ that allow to compute the squared amplitude to the given order.
+ Note that intervals must be converted to slices, to be able to compute
+ the interferences. For example
+ \begin{equation}
+ \left| \mathcal{M}_{\text{SM}} + \lambda \mathcal{M}_{\text{BSM}} \right|^2
+ = \mathcal{M}_{\text{SM}}^* \mathcal{M}_{\text{SM}}
+ + \lambda \mathcal{M}_{\text{SM}}^* \mathcal{M}_{\text{BSM}}
+ + \lambda \mathcal{M}_{\text{BSM}}^* \mathcal{M}_{\text{SM}}
+ + \mathcal{O}(\lambda^2)
+ \end{equation} *)
+
+ (* For the general case, we arrange $n$ coupling orders~$\{c_k\}_{k=1,\ldots,n}$ in a sequence
+ \begin{equation}
+ c=(c_1,c_2,\ldots,c_n)\,,
+ \end{equation}
+ so that we can introduce a multi index notation for the powers
+ \begin{equation}
+ i=(i_1,i_2,\ldots,i_n)
+ \end{equation}
+ and write
+ \begin{equation}
+ c^i = \prod_{k=1}^n c_k^{i_k}\,.
+ \end{equation}
+ The matrix element is then
+ \begin{equation}
+ \mathcal{M}_\chi = \sum_{i} \chi(i) c^i \mathcal{M}_i\,,
+ \end{equation}
+ where the function~$\chi:\mathbf{N}_0^n\to\{0,1\}$ encodes the conditions on the
+ coupling orders.
+ For the squared matrix element with the condition~$\chi_2:\mathbf{N}_0^n\to\{0,1\}$
+ we must find all~$\mathcal{M}_i$ that contribute to the sum
+ \begin{equation}
+ \left|\mathcal{M}\right|^2_{\chi_2}
+ = \sum_{i,j} \chi_2(i+j) c^{i+j} \mathcal{M}^*_i \mathcal{M}_j\,.
+ \end{equation}
+ This means, that we need to find a function~$\chi$ such that
+ \begin{equation}
+ \forall i,j\in\mathrm{N}_0^n: \chi_2(i+j) = 1 \Rightarrow \chi(i)=\chi(j)=1\,.
+ \end{equation}
+ There are infinitely many of such~$\chi$, of course, and we want the function
+ that is non-zero for the smallest possible subset of~$\mathrm{N}_0^n$. *)
+
+ (* If~$\chi_2$ is non-zero for only one~$\hat\imath$, it is straightforward to
+ construct a corresponding set~$I=\{i\}$ for which~$\chi$ doesn't vanish as a cartesian
+ product
+ \begin{equation}
+ I = \times_{k=1}^n \{0,1,\ldots \hat\imath_{k}\}\,.
+ \end{equation}
+ If there is a larger set of~$i$ for which~$\chi_2(i)=1$, we can form the union by
+ selecting the maximum order for each coupling order independently. This can be implemented
+ easily by replacing each slice and interval by the slice running from 0 to the
+ upper limit. *)
+
+ (* Infortunately, this will in general \emph{not} be the smallest such set
+ for a given amplitude, because not all coupling order combinations can contribute.
+ Therefore, only \emph{after} constructing the sliced amplitude, we can find all matching
+ pairs. *)
+
+ (* \begin{dubious}
+ In addition, we should provide the Fortran code with the combinations
+ of coupling orders to be multiplied an summed.
+ \end{dubious} *)
+ val square_root : t -> t
+
+ (* Return a compact textual representation that can be parsed again by [of_strings].
+ This is useful for testing and debugging. *)
+ val to_string : t -> string
+ val pp : Format.formatter -> t -> unit
+ end
+
+(* A projection of [Model.T] containing only coupling constants
+ and coupling orders. This is useful for testing without having
+ to link real models. *)
+module type Model_CO =
+ sig
+ type constant
+ type coupling_order
+ val all_coupling_orders : unit -> coupling_order list
+ val coupling_order_to_string : coupling_order -> string
+ val coupling_orders : constant -> (coupling_order * int) list
+ end
+
+module Conditions (M : Model_CO (* $\subset$ [Model.T] *)) : Conditions
+ with type coupling_order = M.coupling_order
+
+(* \thocwmodulesection{Slicing} *)
+
+(* The idea is to slice a [DAG.t] representing an amplitude into
+ pieces that correspond to given orders in a set of coupling
+ constants. This allows to assign a fixed order to all brakets
+ and to write the corresponding amplitude.
+
+ The mapping from one amplitude to many amplitudes is analogous
+ to colorization and can be implemented as such.
+
+ \begin{dubious}
+ There is a certain co-product vibe to this, but I don't know if
+ it is useful to investigate the analogy further. First get a
+ working prototype.
+ \end{dubious}
+
+ \begin{dubious}
+ It is not obvious whether it is more efficient to
+ \begin{enumerate}
+ \item slice first, colorize later
+ \item colorize first, slice later
+ \end{enumerate}
+ In the first case, we have to slice a smaller [DAG.t], but
+ subsequently colorize a more complicated [DAG.]. In the second
+ case, we have to colorize a smaller [DAG.t], but subsequently slice a
+ more complicated [DAG.]. Probably, this varies from amplitude to
+ amplitude and doesn't matter. For the moment we choose route of slicing
+ the colorized [DAG.t], because we don't have to touch the [Colorize.It()]
+ functor.
+ \end{dubious} *)
+
+module Slice (CM : Model.Colorized) : Model.Sliced_by_Orders
+ with type flavor_all_orders = CM.flavor
+ and type flavor_sans_color = CM.flavor_sans_color
+ and type constant = CM.constant
+ and type coupling_order = CM.coupling_order
+ and type orders = (CM.coupling_order * int) list
+
+(* \thocwmodulesection{Tests} *)
+
+module Test : sig val suite : OUnit.test end
+
Index: trunk/omega/src/omega_QCD.ml
===================================================================
--- trunk/omega/src/omega_QCD.ml (revision 8899)
+++ trunk/omega/src/omega_QCD.ml (revision 8900)
@@ -1,36 +1,27 @@
(* omega_QCD.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.Fortran)(Modellib_SM.QCD)
+module O = Omega.Mixed23(Target_Fortran.Make)(Modellib_SM.QCD)
let _ = O.main ()
-
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/omega_cli.ml
===================================================================
--- trunk/omega/src/omega_cli.ml (revision 0)
+++ trunk/omega/src/omega_cli.ml (revision 8900)
@@ -0,0 +1,694 @@
+(* omega_cli.ml --
+
+ Copyright (C) 1999-2023 by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+
+ WHIZARD is free software; you can redistribute it and/or modify it
+ under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ WHIZARD is distributed in the hope that it will be useful, but
+ WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
+
+(* \thocwmodulesection{Model Collection} *)
+module SMap = Map.Make(String)
+
+module Models =
+ struct
+
+ type t = (string * string * (module Model.T)) SMap.t
+
+ let normalize = String.lowercase_ascii
+
+ let of_list model_list =
+ List.fold_left
+ (fun acc (name, _, _ as model) ->
+ let key = normalize name in
+ begin match SMap.find_opt key acc with
+ | None -> ()
+ | Some (clash, _, _) ->
+ invalid_arg
+ (Printf.sprintf "Omega_cli.Models.of_list: ambiguous model names '%s' ~ '%s'!" name clash)
+ end;
+ SMap.add key model acc)
+ SMap.empty model_list
+
+ let by_name_opt models name =
+ match SMap.find_opt (normalize name) models with
+ | None -> None
+ | Some (_, _, model) -> Some model
+
+ let names models =
+ List.map (fun (_, (name, description, _)) -> (name, description)) (SMap.bindings models)
+
+ end
+
+(* \thocwmodulesection{Output Files} *)
+
+type filename_components =
+ { stem : string;
+ extension : string }
+
+type filename =
+ | Components of filename_components
+ | Full of string
+ | Stdout
+
+let open_output_channel name =
+ let oc = open_out name in
+ let close () = close_out oc in
+ (oc, close, name)
+
+let standard_output_channel =
+ (stdout, (fun () -> flush stdout), "/dev/stdout")
+
+let prefix_directory directory_opt name =
+ match directory_opt with
+ | None -> name
+ | Some dir ->
+ if Filename.is_relative name && Filename.is_implicit name then
+ Filename.concat dir name
+ else
+ name
+
+let output_channel directory_opt prefix = function
+ | Stdout -> standard_output_channel
+ | Full name -> open_output_channel (prefix_directory directory_opt name)
+ | Components { stem; extension } ->
+ begin match prefix, stem, extension with
+ | "", "", "" -> standard_output_channel
+ | _, _, _ ->
+ let suffix =
+ if stem = "" || extension = "" then
+ stem ^ extension
+ else
+ stem ^ "." ^ extension in
+ let name =
+ if prefix = "" || suffix = "" then
+ prefix ^ suffix
+ else
+ prefix ^ "_" ^ suffix in
+ open_output_channel (prefix_directory directory_opt name)
+ end
+
+let with_output_channel ?logging directory_opt prefix file f =
+ let channel, close, name = output_channel directory_opt prefix file in
+ begin match logging with
+ | None -> f channel
+ | Some product ->
+ Printf.eprintf "Omega_cli: writing %s to '%s' ..." product name;
+ f channel;
+ Printf.eprintf " done.\n"
+ end;
+ close ()
+
+(* \thocwmodulesection{Output File Options} *)
+
+module type Output =
+ sig
+ type t = { write : bool; file : filename }
+ val default : t
+ val specs : t ref -> (Arg.key * Arg.spec * Arg.doc) list
+ end
+
+module type File =
+ sig
+ val write : bool
+ val opt : string
+ val stem : string
+ val ext : string
+ end
+
+module Output (F : File) : Output =
+ struct
+
+ type t = { write : bool; file : filename }
+
+ let default =
+ { write = F.write;
+ file = Components { stem = F.stem; extension = F.ext } }
+
+ let write output yorn =
+ output := { !output with write = yorn }
+
+ let stdout output () =
+ output := { write = true; file = Stdout }
+
+ let name output file =
+ output := { write = true; file = Full file }
+
+ let warn_component component ignored name =
+ Printf.eprintf
+ "omega3: new %s file %s '%s' ignored, full name '%s' already set!\n"
+ F.opt component ignored name
+
+ let stem output stem =
+ match !output.file with
+ | Components components -> output := { !output with file = Components { components with stem } }
+ | Full name -> warn_component "stem" stem name
+ | _ -> ()
+
+ let extension output extension =
+ match !output.file with
+ | Components components -> output := { !output with file = Components { components with extension } }
+ | Full name -> warn_component "extension" extension name
+ | _ -> ()
+
+ let specs output =
+ let open Printf in
+ [ ("--" ^ F.opt, Arg.Bool (write output),
+ sprintf "true|false write %s file (default: %b)" F.opt F.write);
+ ("--" ^ F.opt ^ "_stdout", Arg.Unit (stdout output),
+ sprintf " write %s file to /dev/stdout" F.opt);
+ ("--" ^ F.opt ^ "_name", Arg.String (name output),
+ sprintf "name set %s file name" F.opt);
+ ("--" ^ F.opt ^ "_stem", Arg.String (stem output),
+ sprintf "stem set %s file stem (default='%s')" F.opt F.stem);
+ ("--" ^ F.opt ^ "_extension", Arg.String (extension output),
+ sprintf "ext set %s file extension (default='%s')" F.opt F.ext) ]
+
+ end
+
+module Amplitude = Output (struct let write = true let opt = "amplitude" let stem = opt let ext = "f90" end)
+module Log = Output (struct let write = true let opt = "log" let stem = "amplitude" let ext = "log" end)
+module Parameters = Output (struct let write = false let opt = "parameters" let stem = opt let ext = "f90" end)
+module Phasespace = Output (struct let write = false let opt = "phasespace" let stem = opt let ext = "phs" end)
+module Poles = Output (struct let write = false let opt = "poles" let stem = opt let ext = "poles" end)
+module Whizard_Model = Output (struct let write = false let opt = "whizard" let stem = opt let ext = "mdl" end)
+module Forest = Output (struct let write = false let opt = "forest" let stem = opt let ext = "out" end)
+module Diagrams = Output (struct let write = false let opt = "diagrams" let stem = opt let ext = "tex" end)
+module Colorflows = Output (struct let write = false let opt = "colorflows" let stem = opt let ext = "tex" end)
+module DAG = Output (struct let write = false let opt = "dag" let stem = opt let ext = "dot" end)
+module Full_DAG = Output (struct let write = false let opt = "full_dag" let stem = opt let ext = "dot" end)
+
+(* \thocwmodulesection{Command Line Parsing} *)
+
+type processes =
+ | Scatterings of string list
+ | Decays of string list
+
+type command_ref =
+ { processes_ref : processes ref;
+ restrictions_rev_ref : string list ref;
+ orders_rev_ref : string list ref;
+ orders2_ref : bool ref;
+ unphysical_ref : int option ref;
+ directory_ref : string option ref;
+ prefix_ref : string ref;
+ amplitude_ref : Amplitude.t ref;
+ log_ref : Log.t ref;
+ parameters_ref : Parameters.t ref;
+ phasespace_ref : Phasespace.t ref;
+ poles_ref : Poles.t ref;
+ whizard_ref : Whizard_Model.t ref;
+ forest_ref : Forest.t ref;
+ diagrams_ref : Diagrams.t ref;
+ colorflows_ref : Colorflows.t ref;
+ latex_ref : bool ref;
+ dag_ref : DAG.t ref;
+ full_dag_ref : Full_DAG.t ref;
+ template_ref : bool ref }
+
+let default_ref =
+ { processes_ref = ref (Scatterings []);
+ restrictions_rev_ref = ref [];
+ orders_rev_ref = ref [];
+ orders2_ref = ref false;
+ unphysical_ref = ref None;
+ directory_ref = ref None;
+ prefix_ref = ref "omega";
+ amplitude_ref = ref Amplitude.default;
+ log_ref = ref Log.default;
+ parameters_ref = ref Parameters.default;
+ phasespace_ref = ref Phasespace.default;
+ poles_ref = ref Poles.default;
+ whizard_ref = ref Whizard_Model.default;
+ diagrams_ref = ref Diagrams.default;
+ forest_ref = ref Forest.default;
+ colorflows_ref = ref Colorflows.default;
+ latex_ref = ref false;
+ dag_ref = ref DAG.default;
+ full_dag_ref = ref Full_DAG.default;
+ template_ref = ref false }
+
+let add_scatterings command lines =
+ let processes =
+ match !(command.processes_ref) with
+ | Scatterings rev_lines -> Scatterings (lines @ rev_lines)
+ | Decays [] -> Scatterings lines
+ | Decays _ -> invalid_arg "Omega_cli.add_scattering: mixing -scatter and -decay" in
+ command.processes_ref := processes
+
+let add_decays command lines =
+ let processes =
+ match !(command.processes_ref) with
+ | Decays rev_lines -> Decays (lines @ rev_lines)
+ | Scatterings [] -> Decays lines
+ | Scatterings _ -> invalid_arg "Omega_cli.add_decay: mixing -scatter and -decay" in
+ command.processes_ref := processes
+
+let add_restrictions command lines =
+ command.restrictions_rev_ref := lines @ !(command.restrictions_rev_ref)
+
+let add_orders command lines =
+ command.orders_rev_ref := lines @ !(command.orders_rev_ref)
+
+let set_orders2 command yorn =
+ command.orders2_ref := yorn
+
+let set_unphysical command n =
+ command.unphysical_ref := Some n
+
+let set_directory command directory =
+ command.directory_ref := Some directory
+
+let set_prefix command prefix =
+ command.prefix_ref := prefix
+
+type command =
+ { processes : processes;
+ restrictions_rev : string list;
+ orders_rev : string list;
+ orders2 : bool;
+ unphysical : int option;
+ directory : string option;
+ prefix : string;
+ amplitude : Amplitude.t;
+ log : Log.t;
+ parameters : Parameters.t;
+ phasespace : Phasespace.t;
+ poles : Poles.t;
+ whizard : Whizard_Model.t;
+ forest : Forest.t;
+ diagrams : Diagrams.t;
+ colorflows : Colorflows.t;
+ latex : bool;
+ dag : DAG.t;
+ full_dag : Full_DAG.t;
+ template : bool }
+
+let command_of_ref command =
+ { processes = !(command.processes_ref);
+ restrictions_rev = !(command.restrictions_rev_ref);
+ orders_rev = !(command.orders_rev_ref);
+ orders2 = !(command.orders2_ref);
+ unphysical = !(command.unphysical_ref);
+ directory = !(command.directory_ref);
+ prefix = !(command.prefix_ref);
+ amplitude = !(command.amplitude_ref);
+ log = !(command.log_ref);
+ parameters = !(command.parameters_ref);
+ poles = !(command.poles_ref);
+ phasespace = !(command.phasespace_ref);
+ whizard = !(command.whizard_ref);
+ forest = !(command.forest_ref);
+ diagrams = !(command.diagrams_ref);
+ colorflows = !(command.colorflows_ref);
+ latex = !(command.latex_ref);
+ dag = !(command.dag_ref);
+ full_dag = !(command.full_dag_ref);
+ template = !(command.template_ref) }
+
+(* \thocwmodulesection{Combining [Target], [Topology], and [Model.T]} *)
+
+(* \begin{dubious}
+ The [Target] module is not in the \verb+omega_core+ library
+ and we can not reference implementations here, only interfaces
+ like [Target_Maker].
+ \end{dubious} *)
+
+module type T =
+ sig
+ val main : ?current:int ref -> ?argv:string array -> unit -> unit
+ end
+
+module P = Momentum.Default
+module P_Whizard = Momentum.DefaultW
+
+let obsolete_UFO_options =
+ Sets.String.of_list [ "UFO_dir"; "Majorana"; "dump"; "write_WHIZARD"; "exec" ]
+
+let purge_ufo_options options =
+ Options.exclude (fun o -> Sets.String.mem o obsolete_UFO_options) options
+
+module Make (FM : Fusion.Maker) (PHS_Maker : Fusion.Maker) (TM : Target.Maker) (M : Model.Mutable) =
+ struct
+
+ type flavor = M.flavor
+
+ module Proc = Process.Make(M)
+ module C = Cascade.Make(M)(P)
+ module Coupling_Orders = Orders.Conditions(Colorize.It(M))
+
+ module CM = Colorize.It(M)
+ module SCM = Orders.Slice(Colorize.It(M))
+
+ module F = FM(P)(M)
+ module CF = Fusion.Multi(FM)(P)(M)
+ module T = TM(FM)(P)(M)
+
+ module VSet = Set.Make (struct type t = F.constant Coupling.t let compare = compare end)
+ module W = Whizard.Make(FM)(P)(P_Whizard)(M)
+ module MT = Modeltools.Topology3(M)
+ module PHS = PHS_Maker(P)(MT)
+ module CT = Cascade.Make(MT)(P)
+ module FMP = Feynmp.Make(FM)(P)(M)
+
+ let parse_processes processes =
+ try
+ ThoList.uniq
+ (List.sort compare
+ (match processes with
+ | Scatterings lines -> Proc.expand_scatterings (List.rev_map Proc.parse_scattering lines)
+ | Decays lines -> Proc.expand_decays (List.rev_map Proc.parse_decay lines)))
+ with
+ | Invalid_argument s ->
+ invalid_arg (Printf.sprintf "Omega_cli: invalid process specification: %s!\n" s)
+
+ let parse_restrictions processes restrictions =
+ match processes with
+ | [] -> C.no_cascades
+ | (fin, fout) :: _ ->
+ begin match restrictions with
+ | [] -> C.no_cascades
+ | restrictions ->
+ C.to_selectors (C.of_string_list (List.length fin + List.length fout) restrictions)
+ end
+
+ (* Once more with only triple vertices for the phasespace.
+ This could be functorized over [CT]: *)
+ let parse_restrictions_phs processes restrictions =
+ match processes with
+ | [] -> CT.no_cascades
+ | (fin, fout) :: _ ->
+ begin match restrictions with
+ | [] -> CT.no_cascades
+ | restrictions ->
+ CT.to_selectors (CT.of_string_list (List.length fin + List.length fout) restrictions)
+ end
+
+ let parse_orders = function
+ | [] -> None
+ | lines -> Some (Coupling_Orders.of_strings lines)
+
+ let flavors_to_string_all_orders flavors =
+ String.concat " " (List.map (fun f -> CM.flavor_to_string (SCM.flavor_all_orders f)) flavors)
+
+ let process_to_string_all_orders amplitude =
+ flavors_to_string_all_orders (F.incoming amplitude) ^ " -> " ^
+ flavors_to_string_all_orders (F.outgoing amplitude)
+
+ let log_to_channel cmdline amplitudes channel =
+ let open Printf in
+ fprintf channel "%s\n" cmdline;
+ List.iter
+ (fun amplitude ->
+ fprintf channel "%s: %d fusions, %d propagators, %d diagrams\n"
+ (process_to_string_all_orders amplitude)
+ (F.count_fusions amplitude)
+ (F.count_propagators amplitude)
+ (F.count_diagrams amplitude))
+ (CF.processes amplitudes);
+ let couplings =
+ List.fold_left
+ (fun acc p ->
+ let brakets = ThoList.flatmap snd (F.brakets p) in
+ let fusions = ThoList.flatmap F.rhs (F.fusions p)
+ and brakets = ThoList.flatmap F.ket brakets in
+ let couplings = VSet.of_list (List.map F.coupling (fusions @ brakets)) in
+ VSet.union acc couplings)
+ VSet.empty (CF.processes amplitudes) in
+ fprintf channel "%d vertices\n" (VSet.cardinal couplings);
+ let ufo_couplings =
+ VSet.fold
+ (fun v acc ->
+ match v with
+ | Coupling.Vn (Coupling.UFO (_, v, _, _, _), _, _) -> Sets.String.add v acc
+ | _ -> acc)
+ couplings Sets.String.empty in
+ if not (Sets.String.is_empty ufo_couplings) then
+ fprintf channel "%d UFO vertices: %s\n"
+ (Sets.String.cardinal ufo_couplings)
+ (String.concat ", " (Sets.String.elements ufo_couplings))
+
+ let phasespace_to_channel restrictions processes channel =
+ let selectors = parse_restrictions_phs processes restrictions in
+ List.iter
+ (fun (fin, fout) ->
+ Printf.fprintf channel "%s -> %s ::\n"
+ (String.concat " " (List.map M.flavor_to_string fin))
+ (String.concat " " (List.map M.flavor_to_string fout));
+ match fin with
+ | [_] ->
+ PHS.phase_space_channels channel (PHS.amplitude_sans_color false selectors fin fout)
+ | [f1; f2] ->
+ PHS.phase_space_channels channel (PHS.amplitude_sans_color false selectors fin fout);
+ PHS.phase_space_channels_flipped channel (PHS.amplitude_sans_color false selectors [f2; f1] fout)
+ | _ ->
+ failwith (Printf.sprintf "Omega_cli.phasespace_to_channel: impossible: % incoming particles"
+ (List.length fin)))
+ processes
+
+ (* \begin{dubious}
+ [Whizard.Make().write] has been disabled for a while now. Don't show this option.
+ \end{dubious} *)
+ let poles_to_channel amplitudes channel =
+ List.iter
+ (fun amplitude -> W.write channel "omega" (W.merge (W.trees amplitude)))
+ (CF.processes amplitudes)
+
+ let p2s p =
+ if p >= 0 && p <= 9 then
+ string_of_int p
+ else if p <= 36 then
+ String.make 1 (Char.chr (Char.code 'A' + p - 10))
+ else
+ "_"
+
+ let format_p wf =
+ String.concat "" (List.map p2s (F.momentum_list wf))
+
+ let variable wf =
+ M.flavor_to_string (F.flavor_sans_color wf) ^ "[" ^ format_p wf ^ "]"
+
+ let forest_to_channel amplitudes channel =
+ List.iter
+ (fun amplitude ->
+ List.iter
+ (fun tree ->
+ Printf.fprintf channel "%s\n"
+ (Tree.to_string (Tree.map (fun (wf, _) -> variable wf) (fun _ -> "") tree)))
+ (F.forest (List.hd (F.externals amplitude)) amplitude))
+ (CF.processes amplitudes)
+
+ let debug (str, descr, opt, var) =
+ [ "--warning:" ^ str, Arg.Unit (fun () -> var := (opt, false):: !var),
+ " check " ^ descr ^ " and warn";
+ "--error:" ^ str, Arg.Unit (fun () -> var := (opt, true):: !var),
+ " check " ^ descr ^ " and terminate" ]
+
+ let rec include_goldstones = function
+ | [] -> false
+ | (T.Gauge, _) :: _ -> true
+ | _ :: rest -> include_goldstones rest
+
+ let read_lines_rev file =
+ let ic = open_in file in
+ let rev_lines = ref [] in
+ let rec slurp () =
+ rev_lines := input_line ic :: !rev_lines;
+ slurp () in
+ try
+ slurp ()
+ with
+ | End_of_file ->
+ close_in ic;
+ !rev_lines
+
+ let read_lines file =
+ List.rev (read_lines_rev file)
+
+ let list_flavors () =
+ List.iter
+ (fun (group, flavors) ->
+ Printf.printf "%s:\n" group;
+ List.iter (fun f -> Printf.printf " %s\n" (M.flavor_to_string f)) flavors)
+ (M.external_flavors ())
+
+ let main ?current ?(argv=Sys.argv) () =
+ let my_name = Filename.basename argv.(0)
+ and cmdline = String.concat " " (List.map ThoString.quote (Array.to_list Sys.argv)) in
+ let usage = Printf.sprintf "usage: %s [-help] [options]" my_name in
+ let command = default_ref
+ and arg_head_rev = ref [] in
+ let checks = ref [] in
+
+ let specs_lists =
+ [ [ ("-f", Arg.Unit (fun () -> list_flavors (); exit 0),
+ " list all flavors and exit");
+ ("--flavors", Arg.Unit (fun () -> list_flavors (); exit 0),
+ " list all flavors and exit");
+
+ ("-s", Arg.String (fun s -> add_scatterings command [s]),
+ "process add a scattering 'i1 i2 -> o1 o2 ...'");
+ ("--scatter", Arg.String (fun s -> add_scatterings command [s]),
+ "process add a scattering 'i1 i2 -> o1 o2 ...'");
+ ("--scatter_file", Arg.String (fun s -> add_scatterings command (read_lines_rev s)),
+ "name add scattering lines 'i1 i2 -> o1 o2 ...'");
+
+ ("-d", Arg.String (fun s -> add_decays command [s]),
+ "process add a decay 'i -> o1 o2 ...'");
+ ("--decay", Arg.String (fun s -> add_decays command [s]),
+ "process add a decay 'i -> o1 o2 ...'");
+ ("--decay_file", Arg.String (fun s -> add_decays command (read_lines_rev s)),
+ "name add decay lines 'i -> o1 o2 ...'");
+
+ ("-r", Arg.String (fun s -> add_restrictions command [s]),
+ "restriction add a restriction");
+ ("--restrictions", Arg.String (fun s -> add_restrictions command [s]),
+ "restriction add a restriction");
+ ("--restrictions_file", Arg.String (fun s -> add_restrictions command (read_lines_rev s)),
+ "name add restrictions");
+
+ ("-o", Arg.String (fun s -> add_orders command [s]),
+ "condition add a coupling order condition on amplitude");
+ ("--orders", Arg.String (fun s -> add_orders command [s]),
+ "condition add a coupling order condition on amplitude");
+ ("--orders_file", Arg.String (fun s -> add_orders command (read_lines_rev s)),
+ "name add coupling order conditions on amplitude");
+
+ ("-O", Arg.Bool (set_orders2 command),
+ "true|false coupling orders of |M|^2 (default=" ^ string_of_bool !(command.orders2_ref) ^ ")");
+ ("--orders2", Arg.Bool (set_orders2 command),
+ "true|false coupling orders of |M|^2 (default=" ^ string_of_bool !(command.orders2_ref) ^ ")");
+
+ ("-u", Arg.Int (set_unphysical command),
+ "n unphysical polarization vector for particle n");
+ ("--unphysical", Arg.Int (set_unphysical command),
+ "n unphysical polarization vector for particle n");
+
+ ("-p", Arg.String (set_prefix command),
+ "pfx prefix for output files (default='" ^ !(command.prefix_ref) ^ "')");
+ ("--prefix", Arg.String (set_prefix command),
+ "pfx prefix for output files (default='" ^ !(command.prefix_ref) ^ "')");
+ ("--directory", Arg.String (set_directory command),
+ "dir directory for output files (default='" ^ Filename.current_dir_name ^ "')") ];
+
+ Amplitude.specs command.amplitude_ref;
+
+ Options.cmdline "--model:" (purge_ufo_options M.options);
+ Options.cmdline "--fusion:" CF.options;
+ Options.cmdline "--target:" T.options;
+
+ ThoList.flatmap debug
+ [ ("a", "arguments", T.All, checks);
+ ("n", "# of input arguments", T.Arguments, checks);
+ ("m", "input momenta", T.Momenta, checks);
+ ("g", "internal Ward identities", T.Gauge, checks) ];
+
+ Log.specs command.log_ref;
+ Parameters.specs command.parameters_ref;
+ Phasespace.specs command.phasespace_ref;
+
+ (* [Poles.specs command.poles_ref;] *)
+ Whizard_Model.specs command.whizard_ref;
+ Forest.specs command.forest_ref;
+ Diagrams.specs command.diagrams_ref;
+ Colorflows.specs command.colorflows_ref;
+ [ ("--latex", Arg.Set command.latex_ref, " wrap diagrams in minimal LaTeX") ];
+
+ DAG.specs command.dag_ref;
+ Full_DAG.specs command.full_dag_ref;
+
+ (* [ [ ("--template", Arg.Set command.template_ref,
+ " empty wrapper for a handcoded amplitudes")] ] *) ] in
+
+ (* There is no default action if the command line is empty after
+ [Omega3] has consumed the model loading options. *)
+ if Array.length argv <= 1 then
+ begin
+ prerr_endline usage;
+ exit 2
+ end;
+
+ (* Parse the command line. *)
+ begin
+ try
+ Arg.parse_argv ?current argv
+ (Arg.align (List.concat specs_lists))
+ (fun s -> arg_head_rev := s :: !arg_head_rev)
+ usage
+ with
+ | Arg.Bad msg ->
+ prerr_endline msg;
+ exit 2
+ | Arg.Help msg ->
+ print_endline msg;
+ exit 0
+ end;
+
+ (* Collect options. *)
+ let command = command_of_ref command in
+
+ let to_output_channel ?logging write file f =
+ if write then
+ with_output_channel ?logging command.directory command.prefix file f in
+
+ (* Process dependent outputs make only sense if the list of
+ processes is not empty. *)
+ begin match parse_processes command.processes with
+ | [] -> ()
+ | processes ->
+
+ let selectors = parse_restrictions processes (List.rev command.restrictions_rev)
+ and orders = parse_orders (List.rev command.orders_rev) in
+
+ let amplitudes =
+ CF.amplitudes (include_goldstones !checks) command.unphysical selectors orders processes in
+
+ to_output_channel command.amplitude.write command.amplitude.file
+ (fun channel -> T.amplitudes_to_channel cmdline channel !checks amplitudes);
+
+ to_output_channel command.log.write command.log.file
+ (log_to_channel cmdline amplitudes);
+
+ to_output_channel command.phasespace.write command.phasespace.file
+ (phasespace_to_channel (List.rev command.restrictions_rev) processes);
+
+ to_output_channel command.poles.write command.poles.file
+ (poles_to_channel amplitudes);
+
+ to_output_channel command.forest.write command.forest.file
+ (forest_to_channel amplitudes);
+
+ to_output_channel command.diagrams.write command.diagrams.file
+ (FMP.amplitudes_sans_color_to_channel command.latex amplitudes);
+
+ to_output_channel command.colorflows.write command.colorflows.file
+ (FMP.amplitudes_color_only_to_channel command.latex amplitudes);
+
+ to_output_channel command.dag.write command.dag.file
+ (fun channel -> List.iter (F.amplitude_to_dot channel) (CF.processes amplitudes));
+
+ to_output_channel command.full_dag.write command.full_dag.file
+ (fun channel -> List.iter (F.tower_to_dot channel) (CF.processes amplitudes))
+
+ end;
+
+ (* The model dependent outputs can be written in any case. *)
+ to_output_channel command.parameters.write command.parameters.file T.parameters_to_channel;
+ to_output_channel command.whizard.write command.whizard.file M.write_whizard;
+ ()
+
+ end
+
Index: trunk/omega/src/vertex_syntax.ml
===================================================================
--- trunk/omega/src/vertex_syntax.ml (revision 8899)
+++ trunk/omega/src/vertex_syntax.ml (revision 8900)
@@ -1,633 +1,629 @@
(* vertex_syntax.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-(* Avoid refering to [Pervasives.compare], because [Pervasives] will
- become [Stdlib.Pervasives] in O'Caml 4.07 and [Stdlib] in O'Caml 4.08. *)
-let pcompare = compare
-
(* \thocwmodulesection{Abstract Syntax} *)
exception Syntax_Error of string * Lexing.position * Lexing.position
module Token =
struct
type t =
| Digit of int
| Token of string
| Scripted of scripted
| List of t list
and scripted =
{ stem : t;
prefix : prefix list;
super : t list;
sub : t list }
and prefix =
| Bar | Hat | Tilde
| Dagger | Star
| Prime
let prefix_of_string = function
| "\\bar" | "\\overline" -> Bar
| "\\hat" | "\\widehat" -> Hat
| "\\tilde" | "\\widetilde" -> Tilde
| "\\dagger" -> Dagger
| "*" | "\\ast" -> Star
| "\\prime" -> Prime
| _ -> invalid_arg "Vertex_Syntax.Token.string_to_prefix"
let prefix_to_string = function
| Bar -> "\\bar"
| Hat -> "\\hat"
| Tilde -> "\\tilde"
| Dagger -> "\\dagger"
| Star -> "*"
| Prime -> "\\prime"
let wrap_scripted = function
| Scripted st -> st
| t -> { stem = t; prefix = []; super = []; sub = [] }
let wrap_list = function
| List tl -> tl
| _ as t -> [t]
let digit i =
if i >= 0 && i <= 9 then
Digit i
else
invalid_arg ("Vertex_Syntax.Token.digit: " ^ string_of_int i)
let token s =
Token s
let list = function
| [] -> List []
| [Scripted {stem = t; prefix = []; super = []; sub = []}] -> t
| [t] -> t
| tl -> List tl
let optional = function
| None -> []
| Some t -> wrap_list t
let scripted prefix token (super, sub) =
match token, prefix, super, sub with
| _, [], None, None -> token
| (Digit _ | Token _ | List _) as t, _, _, _ ->
Scripted { stem = t;
prefix = List.map prefix_of_string prefix;
super = optional super;
sub = optional sub }
| Scripted st, _, _, _ ->
Scripted { stem = st.stem;
prefix = List.map prefix_of_string prefix @ st.prefix;
super = st.super @ optional super;
sub = st.sub @ optional sub }
let rec stem = function
| Digit _ | Token _ as t -> t
| Scripted { stem = t } -> stem t
| List tl ->
begin match List.rev tl with
| [] -> List []
| t :: _ -> stem t
end
(* Strip superfluous [List] and [Scripted] constructors. *)
(* NB: This might be unnecessary, if we used smart constructors. *)
let rec strip = function
| Digit _ | Token _ as t -> t
| Scripted { stem = t; prefix = []; super = []; sub = [] } -> strip t
| Scripted { stem = t; prefix = prefix; super = super; sub = sub } ->
Scripted { stem = strip t;
prefix = prefix;
super = List.map strip super;
sub = List.map strip sub }
| List tl ->
begin match List.map strip tl with
| [] -> List []
| [t] -> t
| tl -> List tl
end
(* Recursively merge nested [List] and [Scripted] constructors. *)
(* NB: This might be unnecessary, if we used smart constructors. *)
let rec flatten = function
| Digit _ | Token _ as t -> t
| List tl -> flatten_list tl
| Scripted st -> flatten_scripted st
and flatten_list tl =
match List.map flatten tl with
| [] -> List []
| [t] -> t
| tl -> List tl
and flatten_scripted = function
| { stem = t; prefix = []; super = []; sub = [] } -> t
| { stem = t; prefix = prefix; super = super; sub = sub } ->
let super = List.map flatten super
and sub = List.map flatten sub in
begin match flatten t with
| Digit _ | Token _ | List _ as t ->
Scripted { stem = t;
prefix = prefix;
super = super;
sub = sub }
| Scripted st ->
Scripted { stem = st.stem;
prefix = prefix @ st.prefix;
super = st.super @ super;
sub = st.sub @ sub }
end
let ascii_A = Char.code 'A'
let ascii_Z = Char.code 'Z'
let ascii_a = Char.code 'a'
let ascii_z = Char.code 'z'
let is_char c =
let a = Char.code c in
(ascii_A <= a && a <= ascii_Z) || (ascii_a <= a && a <= ascii_z)
let is_backslash c =
c = '\\'
let first_char s =
s.[0]
let last_char s =
s.[String.length s - 1]
let rec to_string = function
| Digit i -> string_of_int i
| Token s -> s
| Scripted t -> scripted_to_string t
| List tl -> "{" ^ list_to_string tl ^ "}"
and list_to_string = function
| [] -> ""
| [Scripted { stem = t; super = []; sub = [] }] -> to_string t
| [Scripted _ as t] -> "{" ^ to_string t ^ "}"
| [t] -> to_string t
| tl -> "{" ^ concat_tokens tl ^ "}"
and scripted_to_string t =
let super =
match t.super with
| [] -> ""
| tl -> "^" ^ list_to_string tl
and sub =
match t.sub with
| [] -> ""
| tl -> "_" ^ list_to_string tl in
String.concat "" (List.map prefix_to_string t.prefix) ^
to_string t.stem ^ super ^ sub
and required_space t1 t2 =
let required_space' s1 s2 =
if is_backslash (first_char s2) then
[]
else if is_backslash (first_char s1) && is_char (last_char s1) then
[Token " "]
else
[] in
match t1, t2 with
| Token s1, Token s2 -> required_space' s1 s2
| Scripted s1, Token s2 -> required_space' (scripted_to_string s1) s2
| Token s1, Scripted s2 -> required_space' s1 (scripted_to_string s2)
| Scripted s1, Scripted s2 ->
required_space' (scripted_to_string s1) (scripted_to_string s2)
| List _, _ | _, List _ | _, Digit _ | Digit _, _ -> []
and interleave_spaces tl =
ThoList.interleave_nearest required_space tl
and concat_tokens tl =
String.concat "" (List.map to_string (interleave_spaces tl))
let compare t1 t2 =
- pcompare t1 t2
+ Stdlib.compare t1 t2
end
module Expr =
struct
type t =
| Integer of int
| Sum of t list | Diff of t * t
| Product of t list | Ratio of t * t
| Function of Token.t * t list
let integer i = Integer i
let rec add a b =
match a, b with
| Integer a, Integer b -> Integer (a + b)
| Sum a, Sum b -> Sum (a @ b)
| Sum a, b -> Sum (a @ [b])
| a, Sum b -> Sum (a :: b)
| a, b -> Sum ([a; b])
(* (a1 - a2) - (b1 - b2) = (a1 + b2) - (a2 + b1) *)
(* (a1 - a2) - b = a1 - (a2 + b) *)
(* a - (b1 - b2) = (a + b2) - b1 *)
and sub a b =
match a, b with
| Integer a, Integer b -> Integer (a - b)
| Diff (a1, a2), Diff (b1, b2) -> Diff (add a1 b2, add a2 b1)
| Diff (a1, a2), b -> Diff (a1, add a2 b)
| a, Diff (b1, b2) -> Diff (add a b2, b1)
| a, b -> Diff (a, b)
and mult a b =
match a, b with
| Integer a, Integer b -> Integer (a * b)
| Product a, Product b -> Product (a @ b)
| Product a, b -> Product (a @ [b])
| a, Product b -> Product (a :: b)
| a, b -> Product ([a; b])
and div a b =
match a, b with
| Ratio (a1, a2), Ratio (b1, b2) -> Ratio (mult a1 b2, mult a2 b1)
| Ratio (a1, a2), b -> Ratio (a1, mult a2 b)
| a, Ratio (b1, b2) -> Ratio (mult a b2, b1)
| a, b -> Ratio (a, b)
let apply f args =
Function (f, args)
let rec to_string = function
| Integer i -> string_of_int i
| Sum ts -> String.concat "+" (List.map to_string ts)
| Diff (t1, t2) -> to_string t1 ^ "-" ^ to_string t2
| Product ts -> String.concat "*" (List.map to_string ts)
| Ratio (t1, t2) -> to_string t1 ^ "/" ^ to_string t2
| Function (f, args) ->
Token.to_string f ^
String.concat ""
(List.map (fun arg -> "{" ^ to_string arg ^ "}") args)
end
(*i module TLSet = Set.Make (struct type t = Token.t list let compare = compare end) i*)
module Particle =
struct
type name =
| Neutral of Token.t
| Charged of Token.t * Token.t
type attr =
| TeX of Token.t list | TeX_Anti of Token.t list
| Alias of Token.t list | Alias_Anti of Token.t list
| Fortran of Token.t list | Fortran_Anti of Token.t list
| Spin of Expr.t | Charge of Expr.t
| Color of Token.t list * Token.t list
| Mass of Token.t list | Width of Token.t list
(*i
(* Combine the sets of aliases and use the
rightmost version of the other attributes. *)
let rec cons_attr a = function
| [] -> [a]
| a' :: alist ->
match a, a' with
| TeX tl, TeX tl' -> a' :: alist
| TeX_Anti tl, TeX_Anti tl' -> a' :: alist
| Aliases tl, Aliases tl' ->
Aliases (TLSet.union tl tl') :: alist
| Aliases_Anti tl, Aliases_Anti tl' ->
Aliases_Anti (TLSet.union tl tl') :: alist
| Fortran tl, Fortran tl' -> a' :: alist
| Fortran_Anti tl, Fortran_Anti tl' -> a' :: alist
| Spin tl, Spin tl' -> a' :: alist
| Color tl, Color tl' -> a' :: alist
| Charge tl, Charge tl' -> a' :: alist
| Mass tl, Mass tl' -> a' :: alist
| Width tl, Width tl' -> a' :: alist
| _, _ -> a' :: cons_attr a alist
i*)
type t =
{ name : name;
attr : attr list }
let name_to_string = function
| Neutral p ->
"\\neutral{" ^ Token.to_string p ^ "}"
| Charged (p, ap) ->
"\\charged{" ^ Token.to_string p ^ "}{" ^ Token.to_string ap ^ "}"
let attr_to_string = function
| TeX tl -> "\\tex{" ^ Token.list_to_string tl ^ "}"
| TeX_Anti tl -> "\\anti\\tex{" ^ Token.list_to_string tl ^ "}"
| Alias tl -> "\\alias{" ^ Token.list_to_string tl ^ "}"
| Alias_Anti tl -> "\\anti\\alias{" ^ Token.list_to_string tl ^ "}"
| Fortran tl -> "\\fortran{" ^ Token.list_to_string tl ^ "}"
| Fortran_Anti tl -> "\\anti\\fortran{" ^ Token.list_to_string tl ^ "}"
| Spin e -> "\\spin{" ^ Expr.to_string e ^ "}"
| Color ([], rep) -> "\\color{" ^ Token.list_to_string rep ^ "}"
| Color (group, rep) ->
"\\color[" ^ Token.list_to_string group ^ "]{" ^
Token.list_to_string rep ^ "}"
| Charge e -> "\\charge{" ^ Expr.to_string e ^ "}"
| Mass tl -> "\\mass{" ^ Token.list_to_string tl ^ "}"
| Width tl -> "\\width{" ^ Token.list_to_string tl ^ "}"
let to_string p =
name_to_string p.name ^
String.concat "" (List.map attr_to_string (List.sort compare p.attr))
end
module Parameter =
struct
type attr =
| TeX of Token.t list
| Alias of Token.t list
| Fortran of Token.t list
type t' =
{ name : Token.t;
value : Expr.t;
attr : attr list}
(*i
let rec cons_attr a = function
| [] -> [a]
| a' :: alist ->
match a, a' with
| TeX tl, TeX tl' -> a' :: alist
| Aliases tl, Aliases tl' ->
Aliases (TLSet.union tl tl') :: alist
| Fortran tl, Fortran tl' -> a' :: alist
| _, _ -> a' :: cons_attr a alist
i*)
type t =
| Parameter of t'
| Derived of t'
let attr_to_string = function
| TeX tl -> "\\tex{" ^ Token.list_to_string tl ^ "}"
| Alias tl -> "\\alias{" ^ Token.list_to_string tl ^ "}"
| Fortran tl -> "\\fortran{" ^ Token.list_to_string tl ^ "}"
let to_string' p =
"{" ^ Token.to_string p.name ^ "}{" ^ Expr.to_string p.value ^ "}" ^
String.concat "" (List.map attr_to_string p.attr)
let to_string = function
| Parameter p -> "\\parameter" ^ to_string' p
| Derived p -> "\\derived" ^ to_string' p
end
module Lie =
struct
type group =
| SU of int | U of int
| SO of int | O of int
| Sp of int
| E6 | E7 | E8 | F4 | G2
module T = Token
let default_group = SU 3
let invalid_group s =
invalid_arg ("Vertex.Lie.group_of_string: " ^ s)
let series s name n =
match name, n with
| "SU", n when n > 1 -> SU n
| "U", n when n >= 1 -> U n
| "SO", n when n > 1 -> SO n
| "O", n when n >= 1 -> O n
| "Sp", n when n >= 2 -> Sp n
| _ -> invalid_group s
let exceptional s name n =
match name, n with
| "E", 6 -> E6
| "E", 7 -> E7
| "E", 8 -> E8
| "F", 4 -> F4
| "G", 2 -> G2
| _ -> invalid_group s
let group_of_string s =
try
Scanf.sscanf s "%_[{]%[SUOp](%d)%_[}]%!" (series s)
with
| _ ->
try
Scanf.sscanf s "%_[{]%[EFG]_%d%_[}]%!" (exceptional s)
with
| _ -> invalid_group s
let group_to_string = function
| SU n -> "SU(" ^ string_of_int n ^ ")"
| U n -> "U(" ^ string_of_int n ^ ")"
| SO n -> "SO(" ^ string_of_int n ^ ")"
| O n -> "O(" ^ string_of_int n ^ ")"
| Sp n -> "Sp(" ^ string_of_int n ^ ")"
| E6 -> "E6"
| E7 -> "E7"
| E8 -> "E8"
| F4 -> "F4"
| G2 -> "G2"
type rep = int
let rep_of_string group rep =
match group with
| SU 3 ->
begin
match rep with
| "3" -> 3
| "\\bar 3" -> -3
| "8" -> 8
| _ ->
invalid_arg ("Vertex.Lie.rep_of_string:" ^
" unsupported representation " ^ rep ^
" of " ^ group_to_string group)
end
| _ -> invalid_arg ("Vertex.Lie.rep_of_string:" ^
" unsupported group " ^ group_to_string group)
let rep_to_string r =
string_of_int r
type t = group * rep
end
module Lorentz =
struct
type rep =
| Scalar | Vector
| Dirac | ConjDirac | Majorana
| Weyl | ConjWeyl
end
module Index =
struct
type attr =
| Color of Token.t list * Token.t list
| Flavor of Token.t list * Token.t list
| Lorentz of Token.t list
type t =
{ name : Token.t;
attr : attr list }
let attr_to_string = function
| Color ([], rep) -> "\\color{" ^ Token.list_to_string rep ^ "}"
| Color (group, rep) ->
"\\color[" ^ Token.list_to_string group ^ "]{" ^
Token.list_to_string rep ^ "}"
| Flavor ([], rep) -> "\\flavor{" ^ Token.list_to_string rep ^ "}"
| Flavor (group, rep) ->
"\\flavor[" ^ Token.list_to_string group ^ "]{" ^
Token.list_to_string rep ^ "}"
| Lorentz tl -> "\\lorentz{" ^ Token.list_to_string tl ^ "}"
let to_string i =
"\\index{" ^ Token.to_string i.name ^ "}" ^
String.concat "" (List.map attr_to_string i.attr)
end
module Tensor =
struct
type attr =
| Color of Token.t list * Token.t list
| Flavor of Token.t list * Token.t list
| Lorentz of Token.t list
type t =
{ name : Token.t;
attr : attr list }
let attr_to_string = function
| Color ([], rep) -> "\\color{" ^ Token.list_to_string rep ^ "}"
| Color (group, rep) ->
"\\color[" ^ Token.list_to_string group ^ "]{" ^
Token.list_to_string rep ^ "}"
| Flavor ([], rep) -> "\\flavor{" ^ Token.list_to_string rep ^ "}"
| Flavor (group, rep) ->
"\\flavor[" ^ Token.list_to_string group ^ "]{" ^
Token.list_to_string rep ^ "}"
| Lorentz tl -> "\\lorentz{" ^ Token.list_to_string tl ^ "}"
let to_string t =
"\\tensor{" ^ Token.to_string t.name ^ "}" ^
String.concat "" (List.map attr_to_string t.attr)
end
module File_Tree =
struct
type declaration =
| Particle of Particle.t
| Parameter of Parameter.t
| Index of Index.t
| Tensor of Tensor.t
| Vertex of Expr.t * Token.t
| Include of string
type t = declaration list
let empty = []
end
module File =
struct
type declaration =
| Particle of Particle.t
| Parameter of Parameter.t
| Index of Index.t
| Tensor of Tensor.t
| Vertex of Expr.t * Token.t
type t = declaration list
let empty = []
(* We allow to include a file more than once, but we don't
optimize by memoization, because we assume that this will
be rare. However to avoid infinite loops when including
a child, we make sure that it has not yet been included as
a parent. *)
let expand_includes parser unexpanded =
let rec expand_includes' parents unexpanded expanded =
List.fold_right (fun decl decls ->
match decl with
| File_Tree.Particle p -> Particle p :: decls
| File_Tree.Parameter p -> Parameter p :: decls
| File_Tree.Index i -> Index i :: decls
| File_Tree.Tensor t -> Tensor t :: decls
| File_Tree.Vertex (e, v) -> Vertex (e, v) :: decls
| File_Tree.Include f ->
if List.mem f parents then
invalid_arg ("cyclic \\include{" ^ f ^ "}")
else
expand_includes' (f:: parents) (parser f) decls)
unexpanded expanded in
expand_includes' [] unexpanded []
let to_strings decls =
List.map
(function
| Particle p -> Particle.to_string p
| Parameter p -> Parameter.to_string p
| Index i -> Index.to_string i
| Tensor t -> Tensor.to_string t
| Vertex (Expr.Integer 1, t) ->
"\\vertex{" ^ Token.to_string t ^ "}"
| Vertex (e, t) ->
"\\vertex[" ^ Expr.to_string e ^ "]{" ^
Token.to_string t ^ "}")
decls
end
Index: trunk/omega/src/omega_SM_CKM_VM.ml
===================================================================
--- trunk/omega/src/omega_SM_CKM_VM.ml (revision 8899)
+++ trunk/omega/src/omega_SM_CKM_VM.ml (revision 8900)
@@ -1,35 +1,26 @@
(* omega_SM_CKM_VM.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
cf. main AUTHORS file
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.VM)
- (Modellib_SM.SM(Modellib_SM.SM_no_anomalous_ckm))
+module O = Omega.Mixed23(Target_VM.Make)(Modellib_SM.SM(Modellib_SM.SM_no_anomalous_ckm))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/modellib_SM.ml
===================================================================
--- trunk/omega/src/modellib_SM.ml (revision 8899)
+++ trunk/omega/src/modellib_SM.ml (revision 8900)
@@ -1,2924 +1,2938 @@
(* modellib_SM.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
Fabian Bach <fabian.bach@t-online.de> (only parts of this file)
So Young Shim <soyoung.shim@desy.de> (only parts of this file)
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
(* \thocwmodulesection{$\phi^3$} *)
module Phi3 =
struct
open Coupling
let options = Options.empty
let caveats () = []
type flavor = Phi
let external_flavors () = [ "", [Phi]]
let flavors () = ThoList.flatmap snd (external_flavors ())
type gauge = unit
type constant = G
- type orders = unit
- let orders = function
- | _ -> ()
+ type coupling_order = unit
+ let all_coupling_orders () = [()]
+ let coupling_order_to_string () = ""
+ let coupling_orders = function
+ | G -> [((), 1)]
let lorentz _ = Scalar
let color _ = Color.Singlet
let nc () = 0
let propagator _ = Prop_Scalar
let width _ = Timelike
let goldstone _ = None
let conjugate f = f
let fermion _ = 0
module Ch = Charges.Null
let charges _ = ()
module F = Modeltools.Fusions (struct
type f = flavor
type c = constant
let compare = compare
let conjugate = conjugate
end)
let vertices () =
([(Phi, Phi, Phi), Scalar_Scalar_Scalar 1, G], [], [])
let table = F.of_vertices (vertices ())
let fuse2 = F.fuse2 table
let fuse3 = F.fuse3 table
let fuse = F.fuse table
let max_degree () = 3
let parameters () = { input = [G, 1.0]; derived = []; derived_arrays = [] }
let flavor_of_string = function
| "p" -> Phi
| _ -> invalid_arg "Modellib.Phi3.flavor_of_string"
let flavor_to_string Phi = "phi"
let flavor_to_TeX Phi = "\\phi"
let flavor_symbol Phi = "phi"
let gauge_symbol () =
failwith "Modellib.Phi3.gauge_symbol: internal error"
let pdg _ = 1
let mass_symbol _ = "m"
let width_symbol _ = "w"
let constant_symbol G = "g"
end
(* \thocwmodulesection{$\lambda_3\phi^3+\lambda_4\phi^4$} *)
module Phi4 =
struct
open Coupling
let options = Options.empty
let caveats () = []
type flavor = Phi
let external_flavors () = [ "", [Phi]]
let flavors () = ThoList.flatmap snd (external_flavors ())
type gauge = unit
type constant = G3 | G4
- type orders = unit
- let orders = function
- | _ -> ()
+ type coupling_order = unit
+ let all_coupling_orders () = [()]
+ let coupling_order_to_string () = ""
+ let coupling_orders = function
+ | G3 | G4 -> [((), 1)]
let lorentz _ = Scalar
let color _ = Color.Singlet
let nc () = 0
let propagator _ = Prop_Scalar
let width _ = Timelike
let goldstone _ = None
let conjugate f = f
let fermion _ = 0
module Ch = Charges.Null
let charges _ = ()
module F = Modeltools.Fusions (struct
type f = flavor
type c = constant
let compare = compare
let conjugate = conjugate
end)
let vertices () =
([(Phi, Phi, Phi), Scalar_Scalar_Scalar 1, G3],
[(Phi, Phi, Phi, Phi), Scalar4 1, G4], [])
- let fuse2 _ = failwith "Modellib.Phi4.fuse2"
- let fuse3 _ = failwith "Modellib.Phi4.fuse3"
- let fuse = function
- | [] | [_] -> invalid_arg "Modellib.Phi4.fuse"
- | [_; _] -> [Phi, V3 (Scalar_Scalar_Scalar 1, F23, G3)]
- | [_; _; _] -> [Phi, V4 (Scalar4 1, F234, G4)]
- | _ -> []
+ let table = F.of_vertices (vertices ())
+ let fuse2 = F.fuse2 table
+ let fuse3 = F.fuse3 table
+ let fuse = F.fuse table
let max_degree () = 4
let parameters () =
{ input = [G3, 1.0; G4, 1.0]; derived = []; derived_arrays = [] }
let flavor_of_string = function
| "p" -> Phi
| _ -> invalid_arg "Modellib.Phi4.flavor_of_string"
let flavor_to_string Phi = "phi"
let flavor_to_TeX Phi = "\\phi"
let flavor_symbol Phi = "phi"
let gauge_symbol () =
failwith "Modellib.Phi4.gauge_symbol: internal error"
let pdg _ = 1
let mass_symbol _ = "m"
let width_symbol _ = "w"
let constant_symbol = function
| G3 -> "g3"
| G4 -> "g4"
end
(* \thocwmodulesection{Quantum Electro Dynamics} *)
module QED =
struct
open Coupling
let options = Options.empty
let caveats () = []
type flavor =
| Electron | Positron
| Muon | AntiMuon
| Tau | AntiTau
| Photon
let external_flavors () =
[ "Leptons", [Electron; Positron; Muon; AntiMuon; Tau; AntiTau];
"Gauge Bosons", [Photon] ]
let flavors () = ThoList.flatmap snd (external_flavors ())
type gauge = unit
type constant = Q
- type orders = unit
- let orders = function
- | _ -> ()
+ type coupling_order = unit
+ let all_coupling_orders () = [()]
+ let coupling_order_to_string () = ""
+ let coupling_orders = function
+ | Q -> [((), 1)]
let lorentz = function
| Electron | Muon | Tau -> Spinor
| Positron | AntiMuon | AntiTau -> ConjSpinor
| Photon -> Vector
let color _ = Color.Singlet
let nc () = 0
let propagator = function
| Electron | Muon | Tau -> Prop_Spinor
| Positron | AntiMuon | AntiTau -> Prop_ConjSpinor
| Photon -> Prop_Feynman
let width _ = Timelike
let goldstone _ =
None
let conjugate = function
| Electron -> Positron | Positron -> Electron
| Muon -> AntiMuon | AntiMuon -> Muon
| Tau -> AntiTau | AntiTau -> Tau
| Photon -> Photon
let fermion = function
| Electron | Muon | Tau -> 1
| Positron | AntiMuon | AntiTau -> -1
| Photon -> 0
(* Taking generation numbers makes electric charge redundant. *)
module Ch = Charges.ZZ
let charges = function
| Electron -> [1; 0; 0]
| Muon -> [0; 1; 0]
| Tau -> [0; 0; 1]
| Positron -> [-1;0; 0]
| AntiMuon -> [0;-1; 0]
| AntiTau -> [0; 0;-1]
| Photon -> [0; 0; 0]
module F = Modeltools.Fusions (struct
type f = flavor
type c = constant
let compare = compare
let conjugate = conjugate
end)
let vertices () =
([(Positron, Photon, Electron), FBF (1, Psibar, V, Psi), Q;
(AntiMuon, Photon, Muon), FBF (1, Psibar, V, Psi), Q;
(AntiTau, Photon, Tau), FBF (1, Psibar, V, Psi), Q], [], [])
let table = F.of_vertices (vertices ())
let fuse2 = F.fuse2 table
let fuse3 = F.fuse3 table
let fuse = F.fuse table
let max_degree () = 3
let parameters () = { input = [Q, 1.0]; derived = []; derived_arrays = [] }
let flavor_of_string = function
| "e-" -> Electron | "e+" -> Positron
| "m-" -> Muon | "m+" -> AntiMuon
| "t-" -> Tau | "t+" -> AntiTau
| "A" -> Photon
| _ -> invalid_arg "Modellib.QED.flavor_of_string"
let flavor_to_string = function
| Electron -> "e-" | Positron -> "e+"
| Muon -> "m-" | AntiMuon -> "m+"
| Tau -> "t-" | AntiTau -> "t+"
| Photon -> "A"
let flavor_to_TeX = function
| Electron -> "e^-" | Positron -> "e^+"
| Muon -> "\\mu^-" | AntiMuon -> "\\mu^+"
| Tau -> "^\\tau^-" | AntiTau -> "\\tau+^"
| Photon -> "\\gamma"
let flavor_symbol = function
| Electron -> "ele" | Positron -> "pos"
| Muon -> "muo" | AntiMuon -> "amu"
| Tau -> "tau" | AntiTau -> "ata"
| Photon -> "gam"
let gauge_symbol () =
failwith "Modellib.QED.gauge_symbol: internal error"
let pdg = function
| Electron -> 11 | Positron -> -11
| Muon -> 13 | AntiMuon -> -13
| Tau -> 15 | AntiTau -> -15
| Photon -> 22
let mass_symbol f =
"mass(" ^ string_of_int (abs (pdg f)) ^ ")"
let width_symbol f =
"width(" ^ string_of_int (abs (pdg f)) ^ ")"
let constant_symbol = function
| Q -> "qlep"
end
(* \thocwmodulesection{Quantum Chromo Dynamics} *)
module QCD =
struct
open Coupling
let options = Options.empty
let caveats () = []
type flavor =
| U | Ubar | D | Dbar
| C | Cbar | S | Sbar
| T | Tbar | B | Bbar
| Gl
let external_flavors () =
[ "Quarks", [U; D; C; S; T; B; Ubar; Dbar; Cbar; Sbar; Tbar; Bbar];
"Gauge Bosons", [Gl]]
let flavors () = ThoList.flatmap snd (external_flavors ())
type gauge = unit
type constant = Gs | G2 | I_Gs
- type orders = unit
- let orders = function
- | _ -> ()
+ type coupling_order = unit
+ let all_coupling_orders () = [()]
+ let coupling_order_to_string () = ""
+ let coupling_orders = function
+ | Gs | I_Gs -> [((), 1)]
+ | G2 -> [((), 2)]
let lorentz = function
| U | D | C | S | T | B -> Spinor
| Ubar | Dbar | Cbar | Sbar | Tbar | Bbar -> ConjSpinor
| Gl -> Vector
- let color = function
+ let color = function
| U | D | C | S | T | B -> Color.SUN 3
| Ubar | Dbar | Cbar | Sbar | Tbar | Bbar -> Color.SUN (-3)
| Gl -> Color.AdjSUN 3
let nc () = 3
let propagator = function
| U | D | C | S | T | B -> Prop_Spinor
| Ubar | Dbar | Cbar | Sbar | Tbar | Bbar -> Prop_ConjSpinor
| Gl -> Prop_Feynman
let width _ = Timelike
let goldstone _ =
None
let conjugate = function
| U -> Ubar
| D -> Dbar
| C -> Cbar
| S -> Sbar
| T -> Tbar
| B -> Bbar
| Ubar -> U
| Dbar -> D
| Cbar -> C
| Sbar -> S
| Tbar -> T
| Bbar -> B
| Gl -> Gl
let fermion = function
| U | D | C | S | T | B -> 1
| Ubar | Dbar | Cbar | Sbar | Tbar | Bbar -> -1
| Gl -> 0
module Ch = Charges.ZZ
let charges = function
| D -> [1; 0; 0; 0; 0; 0]
| U -> [0; 1; 0; 0; 0; 0]
| S -> [0; 0; 1; 0; 0; 0]
| C -> [0; 0; 0; 1; 0; 0]
| B -> [0; 0; 0; 0; 1; 0]
| T -> [0; 0; 0; 0; 0; 1]
| Dbar -> [-1; 0; 0; 0; 0; 0]
| Ubar -> [0; -1; 0; 0; 0; 0]
| Sbar -> [0; 0; -1; 0; 0; 0]
| Cbar -> [0; 0; 0; -1; 0; 0]
| Bbar -> [0; 0; 0; 0; -1; 0]
| Tbar -> [0; 0; 0; 0; 0; -1]
| Gl -> [0; 0; 0; 0; 0; 0]
module F = Modeltools.Fusions (struct
type f = flavor
type c = constant
let compare = compare
let conjugate = conjugate
end)
(* This is compatible with CD+. *)
let color_current =
[ ((Dbar, Gl, D), FBF ((-1), Psibar, V, Psi), Gs);
((Ubar, Gl, U), FBF ((-1), Psibar, V, Psi), Gs);
((Cbar, Gl, C), FBF ((-1), Psibar, V, Psi), Gs);
((Sbar, Gl, S), FBF ((-1), Psibar, V, Psi), Gs);
((Tbar, Gl, T), FBF ((-1), Psibar, V, Psi), Gs);
((Bbar, Gl, B), FBF ((-1), Psibar, V, Psi), Gs)]
let three_gluon =
[ ((Gl, Gl, Gl), Gauge_Gauge_Gauge 1, I_Gs)]
let gauge4 = Vector4 [(2, C_13_42); (-1, C_12_34); (-1, C_14_23)]
let four_gluon =
[ ((Gl, Gl, Gl, Gl), gauge4, G2)]
let vertices3 =
(color_current @ three_gluon)
let vertices4 = four_gluon
let vertices () =
(vertices3, vertices4, [])
let table = F.of_vertices (vertices ())
let fuse2 = F.fuse2 table
let fuse3 = F.fuse3 table
let fuse = F.fuse table
let max_degree () = 4
let parameters () = { input = [Gs, 1.0]; derived = []; derived_arrays = [] }
let flavor_of_string = function
| "u" -> U
| "d" -> D
| "c" -> C
| "s" -> S
| "t" -> T
| "b" -> B
| "ubar" -> Ubar
| "dbar" -> Dbar
| "cbar" -> Cbar
| "sbar" -> Sbar
| "tbar" -> Tbar
| "bbar" -> Bbar
| "gl" -> Gl
| _ -> invalid_arg "Modellib.QCD.flavor_of_string"
let flavor_to_string = function
| U -> "u"
| Ubar -> "ubar"
| D -> "d"
| Dbar -> "dbar"
| C -> "c"
| Cbar -> "cbar"
| S -> "s"
| Sbar -> "sbar"
| T -> "t"
| Tbar -> "tbar"
| B -> "b"
| Bbar -> "bbar"
| Gl -> "gl"
let flavor_to_TeX = function
| U -> "u"
| Ubar -> "\\bar{u}"
| D -> "d"
| Dbar -> "\\bar{d}"
| C -> "c"
| Cbar -> "\\bar{c}"
| S -> "s"
| Sbar -> "\\bar{s}"
| T -> "t"
| Tbar -> "\\bar{t}"
| B -> "b"
| Bbar -> "\\bar{b}"
| Gl -> "g"
let flavor_symbol = function
| U -> "u"
| Ubar -> "ubar"
| D -> "d"
| Dbar -> "dbar"
| C -> "c"
| Cbar -> "cbar"
| S -> "s"
| Sbar -> "sbar"
| T -> "t"
| Tbar -> "tbar"
| B -> "b"
| Bbar -> "bbar"
| Gl -> "gl"
let gauge_symbol () =
failwith "Modellib.QCD.gauge_symbol: internal error"
let pdg = function
| D -> 1 | Dbar -> -1
| U -> 2 | Ubar -> -2
| S -> 3 | Sbar -> -3
| C -> 4 | Cbar -> -4
| B -> 5 | Bbar -> -5
| T -> 6 | Tbar -> -6
| Gl -> 21
let mass_symbol f =
"mass(" ^ string_of_int (abs (pdg f)) ^ ")"
let width_symbol f =
"width(" ^ string_of_int (abs (pdg f)) ^ ")"
let constant_symbol = function
| I_Gs -> "(0,1)*gs"
| Gs -> "gs"
| G2 -> "gs**2"
end
(* \thocwmodulesection{Complete Minimal Standard Model (Unitarity Gauge)} *)
module type SM_flags =
sig
val higgs_triangle : bool (* $H\gamma\gamma$, $Hg\gamma$ and $Hgg$ couplings *)
val higgs_hmm : bool (* $H\mu^+\mu^-$ and $He^+e^-$ couplings *)
val triple_anom : bool
val quartic_anom : bool
val higgs_anom : bool
val dim6 : bool
val k_matrix : bool
val ckm_present : bool
val top_anom : bool
val top_anom_4f : bool
val tt_threshold : bool
end
module SM_no_anomalous : SM_flags =
struct
let higgs_triangle = false
let higgs_hmm = false
let triple_anom = false
let quartic_anom = false
let higgs_anom = false
let dim6 = false
let k_matrix = false
let ckm_present = false
let top_anom = false
let top_anom_4f = false
let tt_threshold = false
end
module SM_no_anomalous_ckm : SM_flags =
struct
let higgs_triangle = false
let higgs_hmm = false
let triple_anom = false
let quartic_anom = false
let higgs_anom = false
let dim6 = false
let k_matrix = false
let ckm_present = true
let top_anom = false
let top_anom_4f = false
let tt_threshold = false
end
module SM_anomalous : SM_flags =
struct
let higgs_triangle = false
let higgs_hmm = false
let triple_anom = true
let quartic_anom = true
let higgs_anom = true
let dim6 = false
let k_matrix = false
let ckm_present = false
let top_anom = false
let top_anom_4f = false
let tt_threshold = false
end
module SM_anomalous_ckm : SM_flags =
struct
let higgs_triangle = false
let higgs_hmm = false
let triple_anom = true
let quartic_anom = true
let higgs_anom = true
let dim6 = false
let k_matrix = false
let ckm_present = true
let top_anom = false
let top_anom_4f = false
let tt_threshold = false
end
module SM_k_matrix : SM_flags =
struct
let higgs_triangle = false
let higgs_hmm = false
let triple_anom = false
let quartic_anom = true
let higgs_anom = false
let dim6 = false
let k_matrix = true
let ckm_present = false
let top_anom = false
let top_anom_4f = false
let tt_threshold = false
end
module SM_Higgs : SM_flags =
struct
let higgs_triangle = true
let higgs_hmm = true
let triple_anom = false
let quartic_anom = false
let higgs_anom = false
let dim6 = false
let k_matrix = false
let ckm_present = false
let top_anom = false
let top_anom_4f = false
let tt_threshold = false
end
module SM_Higgs_CKM : SM_flags =
struct
let higgs_triangle = true
let higgs_hmm = true
let triple_anom = false
let quartic_anom = false
let higgs_anom = false
let dim6 = false
let k_matrix = false
let ckm_present = true
let top_anom = false
let top_anom_4f = false
let tt_threshold = false
end
module SM_anomalous_top : SM_flags =
struct
let higgs_triangle = false
let higgs_hmm = false
let triple_anom = false
let quartic_anom = false
let higgs_anom = false
let dim6 = false
let k_matrix = false
let ckm_present = false
let top_anom = true
let top_anom_4f = true
let tt_threshold = false
end
module SM_tt_threshold : SM_flags =
struct
let higgs_triangle = false
let higgs_hmm = false
let triple_anom = false
let quartic_anom = false
let higgs_anom = false
let dim6 = false
let k_matrix = false
let ckm_present = true
let top_anom = false
let top_anom_4f = false
let tt_threshold = true
end
module SM_dim6 : SM_flags =
struct
let higgs_triangle = false
let higgs_hmm = false
let triple_anom = false
let quartic_anom = false
let higgs_anom = false
let dim6 = true
let k_matrix = false
let ckm_present = false
let top_anom = false
let top_anom_4f = false
let tt_threshold = false
end
(* \thocwmodulesection{Complete Minimal Standard Model (including some extensions)} *)
module SM (Flags : SM_flags) =
struct
open Coupling
let default_width = ref Timelike
let use_fudged_width = ref false
let options = Options.create
[ "constant_width", Arg.Unit (fun () -> default_width := Constant),
- "use constant width (also in t-channel)";
+ " use constant width (also in t-channel)";
"fudged_width", Arg.Set use_fudged_width,
- "use fudge factor for charge particle width";
+ " use fudge factor for charge particle width";
"custom_width", Arg.String (fun f -> default_width := Custom f),
- "use custom width";
+ "width use custom width";
"cancel_widths", Arg.Unit (fun () -> default_width := Vanishing),
- "use vanishing width";
+ " use vanishing width";
"cms_width", Arg.Unit (fun () -> default_width := Complex_Mass),
- "use complex mass scheme";
+ " use complex mass scheme";
"running_width", Arg.Unit (fun () -> default_width := Running),
- "use running width" ]
+ " use running width" ]
let caveats () = []
type f_aux_top = TTGG | TBWA | TBWZ | TTWW | BBWW
| TCGG | TUGG (*i top auxiliary field "flavors" i*)
| QGUG | QBUB | QW | DL | DR
| QUQD1L | QUQD1R | QUQD8L | QUQD8R
type matter_field = L of int | N of int | U of int | D of int
type gauge_boson = Ga | Wp | Wm | Z | Gl
type other = Phip | Phim | Phi0 | H
| Aux_top of int*int*int*bool*f_aux_top (*i lorentz*color*charge*top-side*flavor i*)
type flavor = M of matter_field | G of gauge_boson | O of other
let matter_field f = M f
let gauge_boson f = G f
let other f = O f
type field =
| Matter of matter_field
| Gauge of gauge_boson
| Other of other
let field = function
| M f -> Matter f
| G f -> Gauge f
| O f -> Other f
type gauge = unit
let gauge_symbol () =
failwith "Modellib.SM.gauge_symbol: internal error"
let family n = List.map matter_field [ L n; N n; U n; D n ]
let rec aux_top_flavors (f,l,co,ch) = List.append
( List.map other [ Aux_top (l,co,ch/2,true,f);
Aux_top (l,co,ch/2,false,f) ] )
( if ch > 1 then List.append
( List.map other [ Aux_top (l,co,-ch/2,true,f);
Aux_top (l,co,-ch/2,false,f) ] )
( aux_top_flavors (f,l,co,(ch-2)) )
else [] )
let external_flavors () =
[ "1st Generation", ThoList.flatmap family [1; -1];
"2nd Generation", ThoList.flatmap family [2; -2];
"3rd Generation", ThoList.flatmap family [3; -3];
"Gauge Bosons", List.map gauge_boson [Ga; Z; Wp; Wm; Gl];
"Higgs", List.map other [H];
"Goldstone Bosons", List.map other [Phip; Phim; Phi0] ]
let flavors () = List.append
( ThoList.flatmap snd (external_flavors ()) )
( ThoList.flatmap aux_top_flavors
[ (TTGG,2,1,1); (TCGG,2,1,1); (TUGG,2,1,1); (TBWA,2,0,2); (TBWZ,2,0,2);
(TTWW,2,0,1); (BBWW,2,0,1);
(QGUG,1,1,1); (QBUB,1,0,1); (QW,1,0,3); (DL,0,0,3); (DR,0,0,3);
(QUQD1L,0,0,3); (QUQD1R,0,0,3); (QUQD8L,0,1,3); (QUQD8R,0,1,3) ] )
let spinor n =
if n >= 0 then
Spinor
else
ConjSpinor
let lorentz_aux = function
| 2 -> Tensor_1
| 1 -> Vector
| 0 -> Scalar
| _ -> invalid_arg ("SM.lorentz_aux: wrong value")
let lorentz = function
| M f ->
begin match f with
| L n -> spinor n | N n -> spinor n
| U n -> spinor n | D n -> spinor n
end
| G f ->
begin match f with
| Ga | Gl -> Vector
| Wp | Wm | Z -> Massive_Vector
end
| O f ->
begin match f with
| Aux_top (l,_,_,_,_) -> lorentz_aux l
| _ -> Scalar
end
- let color = function
+ let color = function
| M (U n) -> Color.SUN (if n > 0 then 3 else -3)
| M (D n) -> Color.SUN (if n > 0 then 3 else -3)
| G Gl -> Color.AdjSUN 3
| O (Aux_top (_,co,_,_,_)) -> if co == 0 then Color.Singlet else Color.AdjSUN 3
| _ -> Color.Singlet
let nc () = 3
let prop_spinor n =
if n >= 0 then
Prop_Spinor
else
Prop_ConjSpinor
let prop_aux = function
| 2 -> Aux_Tensor_1
| 1 -> Aux_Vector
| 0 -> Aux_Scalar
| _ -> invalid_arg ("SM.prop_aux: wrong value")
let propagator = function
| M f ->
begin match f with
| L n -> prop_spinor n | N n -> prop_spinor n
| U n -> prop_spinor n | D n -> prop_spinor n
end
| G f ->
begin match f with
| Ga | Gl -> Prop_Feynman
| Wp | Wm | Z -> Prop_Unitarity
end
| O f ->
begin match f with
| Phip | Phim | Phi0 -> Only_Insertion
| H -> Prop_Scalar
| Aux_top (l,_,_,_,_) -> prop_aux l
end
(* Optionally, ask for the fudge factor treatment for the widths of
charged particles. Currently, this only applies to $W^\pm$ and top. *)
let width f =
if !use_fudged_width then
match f with
| G Wp | G Wm | M (U 3) | M (U (-3)) -> Fudged
| _ -> !default_width
else
!default_width
let goldstone = function
| G f ->
begin match f with
| Wp -> Some (O Phip, Coupling.Integer 1)
| Wm -> Some (O Phim, Coupling.Integer 1)
| Z -> Some (O Phi0, Coupling.Integer 1)
| _ -> None
end
| _ -> None
let conjugate = function
| M f ->
M (begin match f with
| L n -> L (-n) | N n -> N (-n)
| U n -> U (-n) | D n -> D (-n)
end)
| G f ->
G (begin match f with
| Gl -> Gl | Ga -> Ga | Z -> Z
| Wp -> Wm | Wm -> Wp
end)
| O f ->
O (begin match f with
| Phip -> Phim | Phim -> Phip | Phi0 -> Phi0
| H -> H
| Aux_top (l,co,ch,n,f) -> Aux_top (l,co,(-ch),(not n),f)
end)
let fermion = function
| M f ->
begin match f with
| L n -> if n > 0 then 1 else -1
| N n -> if n > 0 then 1 else -1
| U n -> if n > 0 then 1 else -1
| D n -> if n > 0 then 1 else -1
end
| G f ->
begin match f with
| Gl | Ga | Z | Wp | Wm -> 0
end
| O _ -> 0
(* Electrical charge, lepton number, baryon number. We could avoid the
rationals altogether by multiplying the first and last by 3 \ldots *)
module Ch = Charges.QQ
let ( // ) = Algebra.Small_Rational.make
let generation' = function
| 1 -> [ 1//1; 0//1; 0//1]
| 2 -> [ 0//1; 1//1; 0//1]
| 3 -> [ 0//1; 0//1; 1//1]
| -1 -> [-1//1; 0//1; 0//1]
| -2 -> [ 0//1; -1//1; 0//1]
| -3 -> [ 0//1; 0//1; -1//1]
| n -> invalid_arg ("SM.generation': " ^ string_of_int n)
(* Generation is not a good quantum number for models with flavor mixing,
i.e. if CKM mixing is present. Also, for the FCNC vertices implemented
in the SM variant with anomalous top couplings it is not a valid
symmetry. *)
let generation f =
if (Flags.ckm_present || Flags.top_anom) then
[]
else
match f with
| M (L n | N n | U n | D n) -> generation' n
| G _ | O _ -> [0//1; 0//1; 0//1]
let charge = function
| M f ->
begin match f with
| L n -> if n > 0 then -1//1 else 1//1
| N n -> 0//1
| U n -> if n > 0 then 2//3 else -2//3
| D n -> if n > 0 then -1//3 else 1//3
end
| G f ->
begin match f with
| Gl | Ga | Z -> 0//1
| Wp -> 1//1
| Wm -> -1//1
end
| O f ->
begin match f with
| H | Phi0 -> 0//1
| Phip -> 1//1
| Phim -> -1//1
| Aux_top (_,_,ch,_,_) -> ch//1
end
let lepton = function
| M f ->
begin match f with
| L n | N n -> if n > 0 then 1//1 else -1//1
| U _ | D _ -> 0//1
end
| G _ | O _ -> 0//1
let baryon = function
| M f ->
begin match f with
| L _ | N _ -> 0//1
| U n | D n -> if n > 0 then 1//1 else -1//1
end
| G _ | O _ -> 0//1
let charges f =
[ charge f; lepton f; baryon f] @ generation f
type constant =
| Unit | Half | Pi | Alpha_QED | Sin2thw
| Sinthw | Costhw | E | G_weak | I_G_weak | Vev
| Q_lepton | Q_up | Q_down | G_CC | G_CCQ of int*int
| G_NC_neutrino | G_NC_lepton | G_NC_up | G_NC_down
| G_TVA_ttA | G_TVA_bbA | G_TVA_tuA
| G_TVA_tcA | G_TVA_tcZ | G_TVA_tuZ | G_TVA_bbZ
| G_VLR_ttZ | G_TVA_ttZ | G_VLR_tcZ | G_VLR_tuZ
| VA_ILC_ttA | VA_ILC_ttZ
| G_VLR_btW | G_VLR_tbW
| G_TLR_btW | G_TRL_tbW
| G_TLR_btWZ | G_TRL_tbWZ
| G_TLR_btWA | G_TRL_tbWA
| G_TVA_ttWW | G_TVA_bbWW
| G_TVA_ttG | G_TVA_ttGG | G_TVA_tcG | G_TVA_tcGG
| G_TVA_tuG | G_TVA_tuGG | G_SP_ttH
| G_VLR_qGuG | G_VLR_qBuB
| G_VLR_qBuB_u | G_VLR_qBuB_d | G_VLR_qBuB_e | G_VL_qBuB_n
| G_VL_qW | G_VL_qW_u | G_VL_qW_d
| G_SL_DttR | G_SR_DttR | G_SL_DttL | G_SLR_DbtR | G_SL_DbtL
| C_quqd1R_bt | C_quqd1R_tb | C_quqd1L_bt | C_quqd1L_tb
| C_quqd8R_bt | C_quqd8R_tb | C_quqd8L_bt | C_quqd8L_tb
| I_Q_W | I_G_ZWW
| G_WWWW | G_ZZWW | G_AZWW | G_AAWW
| I_G1_AWW | I_G1_ZWW
| I_G1_plus_kappa_plus_G4_AWW
| I_G1_plus_kappa_plus_G4_ZWW
| I_G1_plus_kappa_minus_G4_AWW
| I_G1_plus_kappa_minus_G4_ZWW
| I_G1_minus_kappa_plus_G4_AWW
| I_G1_minus_kappa_plus_G4_ZWW
| I_G1_minus_kappa_minus_G4_AWW
| I_G1_minus_kappa_minus_G4_ZWW
| I_lambda_AWW | I_lambda_ZWW
| G5_AWW | G5_ZWW
| I_kappa5_AWW | I_kappa5_ZWW
| I_lambda5_AWW | I_lambda5_ZWW
| Alpha_WWWW0 | Alpha_ZZWW1 | Alpha_WWWW2
| Alpha_ZZWW0 | Alpha_ZZZZ
| D_Alpha_ZZWW0_S | D_Alpha_ZZWW0_T | D_Alpha_ZZWW1_S
| D_Alpha_ZZWW1_T | D_Alpha_ZZWW1_U | D_Alpha_WWWW0_S
| D_Alpha_WWWW0_T | D_Alpha_WWWW0_U | D_Alpha_WWWW2_S
| D_Alpha_WWWW2_T | D_Alpha_ZZZZ_S | D_Alpha_ZZZZ_T
| G_HWW | G_HHWW | G_HZZ | G_HHZZ
| G_Htt | G_Hbb | G_Hcc | G_Hss | G_Hmm | G_Hee
| G_Htautau | G_H3 | G_H4
| G_HGaZ | G_HGaGa | G_Hgg
| G_HGaZ_anom | G_HGaGa_anom | G_HZZ_anom | G_HWW_anom
| G_HGaZ_u | G_HZZ_u | G_HWW_u
| Gs | I_Gs | G2
| Mass of flavor | Width of flavor
| K_Matrix_Coeff of int | K_Matrix_Pole of int
| I_Dim6_AWW_Gauge | I_Dim6_AWW_GGG | I_Dim6_AWW_DP | I_Dim6_AWW_DW
| I_Dim6_WWZ_W | I_Dim6_WWZ_DPWDW | I_Dim6_WWZ_DW | I_Dim6_WWZ_D
(*i | I_Dim6_GGG_G | I_Dim6_GGG_CG i*)
| G_HZZ6_V3 | G_HZZ6_D | G_HZZ6_DP | G_HZZ6_PB
| G_HWW_6_D | G_HWW_6_DP
| G_HGaZ6_D | G_HGaZ6_DP | G_HGaZ6_PB
| G_HGaGa6
| Dim6_vev3 | Dim6_Cphi | Anom_Dim6_AAWW_DW | Anom_Dim6_AAWW_W
| Anom_Dim6_H4_v2 | Anom_Dim6_H4_P2
| Anom_Dim6_AHWW_DPB | Anom_Dim6_AHWW_DPW | Anom_Dim6_AHWW_DW
| Anom_Dim6_HHWW_DW | Anom_Dim6_HHWW_DPW
| Anom_Dim6_HWWZ_DW | Anom_Dim6_HWWZ_DDPW | Anom_Dim6_HWWZ_DPW
| Anom_Dim6_HWWZ_DPB
| Anom_Dim6_AHHZ_D | Anom_Dim6_AHHZ_DP | Anom_Dim6_AHHZ_PB
| Anom_Dim6_AZWW_W | Anom_Dim6_AZWW_DWDPW
| Anom_Dim6_WWWW_W | Anom_Dim6_WWWW_DWDPW | Anom_Dim6_WWZZ_W
| Anom_Dim6_WWZZ_DWDPW
| Anom_Dim6_HHAA | Anom_Dim6_HHZZ_D | Anom_Dim6_HHZZ_DP
| Anom_Dim6_HHZZ_PB | Anom_Dim6_HHZZ_T
(* Two integer counters for the QCD and EW order of the couplings. *)
- type orders = int * int
-
- let orders = function
+ type coupling_order = QCD | EW
+ let all_coupling_orders () = [QCD; EW]
+ let coupling_order_to_string = function
+ | QCD -> "QCD"
+ | EW -> "EW"
+ let coupling_orders = function
| Q_lepton | Q_up | Q_down | G_NC_lepton | G_NC_neutrino
| G_NC_up | G_NC_down | G_CC | G_CCQ _ | G_Htt | G_H3
| G_Hbb | G_Hcc | G_Hss | G_Htautau | G_Hmm | G_Hee | I_Q_W
| I_G_ZWW | I_G1_AWW | I_G1_ZWW | I_G_weak
| G_HWW | G_HZZ | G_HWW_u | G_HZZ_u | G_HGaZ_u
| G_HWW_anom | G_HZZ_anom | G_HGaZ | G_HGaGa | G_HGaZ_anom
| G_HGaGa_anom | Half | Unit
| I_G1_plus_kappa_plus_G4_AWW
| I_G1_plus_kappa_plus_G4_ZWW
| I_G1_minus_kappa_plus_G4_AWW
| I_G1_minus_kappa_plus_G4_ZWW
| I_G1_plus_kappa_minus_G4_AWW
| I_G1_plus_kappa_minus_G4_ZWW
| I_G1_minus_kappa_minus_G4_AWW
| I_G1_minus_kappa_minus_G4_ZWW | I_kappa5_AWW
| I_kappa5_ZWW | G5_AWW | G5_ZWW
| I_lambda_AWW | I_lambda_ZWW | I_lambda5_AWW
| I_lambda5_ZWW | G_TVA_ttA | G_TVA_bbA | G_TVA_tcA | G_TVA_tuA
| G_VLR_ttZ | G_TVA_ttZ | G_VLR_tcZ | G_TVA_tcZ | G_TVA_bbZ
| VA_ILC_ttA | VA_ILC_ttZ | G_VLR_tuZ | G_TVA_tuZ
| G_VLR_btW | G_VLR_tbW | G_TLR_btW | G_TRL_tbW
| G_TLR_btWA | G_TRL_tbWA | G_TLR_btWZ | G_TRL_tbWZ
| G_VLR_qBuB | G_VLR_qBuB_u | G_VLR_qBuB_d
| G_VLR_qBuB_e | G_VL_qBuB_n | G_VL_qW | G_VL_qW_u | G_VL_qW_d
| G_SL_DttR | G_SR_DttR | G_SL_DttL | G_SLR_DbtR | G_SL_DbtL
| G_HZZ6_V3 | G_HZZ6_D | G_HZZ6_DP | G_HZZ6_PB
| G_HGaZ6_D | G_HGaZ6_DP | G_HGaZ6_PB
| G_HWW_6_D | G_HWW_6_DP
| G_HGaGa6
| I_Dim6_AWW_Gauge | I_Dim6_AWW_GGG | I_Dim6_AWW_DP | I_Dim6_AWW_DW
| I_Dim6_WWZ_W | I_Dim6_WWZ_DPWDW | I_Dim6_WWZ_DW | I_Dim6_WWZ_D
(*i | I_Dim6_GGG_G | I_Dim6_GGG_CG i*)
| Dim6_vev3 | Dim6_Cphi
| Anom_Dim6_H4_v2 | Anom_Dim6_H4_P2 | Anom_Dim6_AAWW_DW
| Anom_Dim6_AAWW_W
| Anom_Dim6_AHWW_DPB | Anom_Dim6_AHWW_DPW | Anom_Dim6_AHWW_DW
| Anom_Dim6_HHWW_DW | Anom_Dim6_HHWW_DPW
| Anom_Dim6_HWWZ_DW | Anom_Dim6_HWWZ_DDPW | Anom_Dim6_HWWZ_DPW
| Anom_Dim6_HWWZ_DPB
| Anom_Dim6_AHHZ_D | Anom_Dim6_AHHZ_DP | Anom_Dim6_AHHZ_PB
| Anom_Dim6_AZWW_W | Anom_Dim6_AZWW_DWDPW
| Anom_Dim6_WWWW_W | Anom_Dim6_WWWW_DWDPW | Anom_Dim6_WWZZ_W
| Anom_Dim6_WWZZ_DWDPW
| Anom_Dim6_HHAA | Anom_Dim6_HHZZ_D | Anom_Dim6_HHZZ_DP
| Anom_Dim6_HHZZ_PB | Anom_Dim6_HHZZ_T
- | G_TVA_ttWW | G_TVA_bbWW | G_SP_ttH -> (0,1)
+ | G_TVA_ttWW | G_TVA_bbWW | G_SP_ttH -> [(EW, 1)]
| G_HHWW | G_HHZZ | G_H4
| G_WWWW | G_ZZWW | G_AZWW | G_AAWW
| Alpha_WWWW0 | Alpha_WWWW2 | Alpha_ZZWW0
| Alpha_ZZWW1 | Alpha_ZZZZ
| D_Alpha_WWWW0_S | D_Alpha_WWWW0_T | D_Alpha_WWWW0_U
| D_Alpha_WWWW2_S | D_Alpha_WWWW2_T | D_Alpha_ZZWW0_S
| D_Alpha_ZZWW0_T | D_Alpha_ZZWW1_S | D_Alpha_ZZWW1_T
- | D_Alpha_ZZWW1_U | D_Alpha_ZZZZ_S | D_Alpha_ZZZZ_T -> (0,2)
+ | D_Alpha_ZZWW1_U | D_Alpha_ZZZZ_S | D_Alpha_ZZZZ_T -> [(EW, 2)]
| Gs | I_Gs | G_TVA_ttG | G_TVA_ttGG | G_TVA_tcG | G_TVA_tcGG
| G_TVA_tuG | G_TVA_tuGG | G_VLR_qGuG
| C_quqd1R_bt | C_quqd1R_tb | C_quqd1L_bt | C_quqd1L_tb
- | C_quqd8R_bt | C_quqd8R_tb | C_quqd8L_bt | C_quqd8L_tb -> (1,0)
- | G2 | G_Hgg -> (2,0)
+ | C_quqd8R_bt | C_quqd8R_tb | C_quqd8L_bt | C_quqd8L_tb -> [(QCD, 1)]
+ | G2 | G_Hgg -> [(QCD, 2)]
(* These constants are not used, hence initialized to zero. *)
| Sinthw | Sin2thw | Costhw | Pi
| Alpha_QED | G_weak | K_Matrix_Coeff _
- | K_Matrix_Pole _ | Mass _ | Width _ | Vev | E -> (0,0)
+ | K_Matrix_Pole _ | Mass _ | Width _ | Vev | E -> []
(* \begin{dubious}
The current abstract syntax for parameter dependencies is admittedly
tedious. Later, there will be a parser for a convenient concrete syntax
as a part of a concrete syntax for models. But as these examples show,
it should include simple functions.
\end{dubious} *)
(* \begin{subequations}
\begin{align}
\alpha_{\text{QED}} &= \frac{1}{137.0359895} \\
\sin^2\theta_w &= 0.23124
\end{align}
\end{subequations} *)
let input_parameters =
[ Alpha_QED, 1. /. 137.0359895;
Sin2thw, 0.23124;
Mass (G Z), 91.187;
Mass (M (N 1)), 0.0; Mass (M (L 1)), 0.51099907e-3;
Mass (M (N 2)), 0.0; Mass (M (L 2)), 0.105658389;
Mass (M (N 3)), 0.0; Mass (M (L 3)), 1.77705;
Mass (M (U 1)), 5.0e-3; Mass (M (D 1)), 3.0e-3;
Mass (M (U 2)), 1.2; Mass (M (D 2)), 0.1;
Mass (M (U 3)), 174.0; Mass (M (D 3)), 4.2 ]
(* \begin{subequations}
\begin{align}
e &= \sqrt{4\pi\alpha} \\
\sin\theta_w &= \sqrt{\sin^2\theta_w} \\
\cos\theta_w &= \sqrt{1-\sin^2\theta_w} \\
g &= \frac{e}{\sin\theta_w} \\
m_W &= \cos\theta_w m_Z \\
v &= \frac{2m_W}{g} \\
g_{CC} =
-\frac{g}{2\sqrt2} &= -\frac{e}{2\sqrt2\sin\theta_w} \\
Q_{\text{lepton}} =
-q_{\text{lepton}}e &= e \\
Q_{\text{up}} =
-q_{\text{up}}e &= -\frac{2}{3}e \\
Q_{\text{down}} =
-q_{\text{down}}e &= \frac{1}{3}e \\
\ii q_We =
\ii g_{\gamma WW} &= \ii e \\
\ii g_{ZWW} &= \ii g \cos\theta_w \\
\ii g_{WWW} &= \ii g
\end{align}
\end{subequations} *)
(* \begin{dubious}
\ldots{} to be continued \ldots{}
The quartic couplings can't be correct, because the dimensions are wrong!
\begin{subequations}
\begin{align}
g_{HWW} &= g m_W = 2 \frac{m_W^2}{v}\\
g_{HHWW} &= 2 \frac{m_W^2}{v^2} = \frac{g^2}{2} \\
g_{HZZ} &= \frac{g}{\cos\theta_w}m_Z \\
g_{HHZZ} &= 2 \frac{m_Z^2}{v^2} = \frac{g^2}{2\cos\theta_w} \\
g_{Htt} &= \lambda_t \\
g_{Hbb} &= \lambda_b=\frac{m_b}{m_t}\lambda_t \\
g_{H^3} &= - \frac{3g}{2}\frac{m_H^2}{m_W} = - 3 \frac{m_H^2}{v}
g_{H^4} &= - \frac{3g^2}{4} \frac{m_W^2}{v^2} = -3 \frac{m_H^2}{v^2}
\end{align}
\end{subequations}
\end{dubious} *)
let derived_parameters =
[ Real E, Sqrt (Prod [Integer 4; Atom Pi; Atom Alpha_QED]);
Real Sinthw, Sqrt (Atom Sin2thw);
Real Costhw, Sqrt (Diff (Integer 1, Atom Sin2thw));
Real G_weak, Quot (Atom E, Atom Sinthw);
Real (Mass (G Wp)), Prod [Atom Costhw; Atom (Mass (G Z))];
Real Vev, Quot (Prod [Integer 2; Atom (Mass (G Wp))], Atom G_weak);
Real Q_lepton, Atom E;
Real Q_up, Prod [Quot (Integer (-2), Integer 3); Atom E];
Real Q_down, Prod [Quot (Integer 1, Integer 3); Atom E];
Real G_CC, Neg (Quot (Atom G_weak, Prod [Integer 2; Sqrt (Integer 2)]));
Complex I_Q_W, Prod [I; Atom E];
Complex I_G_weak, Prod [I; Atom G_weak];
Complex I_G_ZWW, Prod [I; Atom G_weak; Atom Costhw] ]
(* \begin{equation}
- \frac{g}{2\cos\theta_w}
\end{equation} *)
let g_over_2_costh =
Quot (Neg (Atom G_weak), Prod [Integer 2; Atom Costhw])
(* \begin{subequations}
\begin{align}
- \frac{g}{2\cos\theta_w} g_V
&= - \frac{g}{2\cos\theta_w} (T_3 - 2 q \sin^2\theta_w) \\
- \frac{g}{2\cos\theta_w} g_A
&= - \frac{g}{2\cos\theta_w} T_3
\end{align}
\end{subequations} *)
let nc_coupling c t3 q =
(Real_Array c,
[Prod [g_over_2_costh; Diff (t3, Prod [Integer 2; q; Atom Sin2thw])];
Prod [g_over_2_costh; t3]])
let half = Quot (Integer 1, Integer 2)
let derived_parameter_arrays =
[ nc_coupling G_NC_neutrino half (Integer 0);
nc_coupling G_NC_lepton (Neg half) (Integer (-1));
nc_coupling G_NC_up half (Quot (Integer 2, Integer 3));
nc_coupling G_NC_down (Neg half) (Quot (Integer (-1), Integer 3)) ]
let parameters () =
{ input = input_parameters;
derived = derived_parameters;
derived_arrays = derived_parameter_arrays }
module F = Modeltools.Fusions (struct
type f = flavor
type c = constant
let compare = compare
let conjugate = conjugate
end)
(* \begin{equation}
\mathcal{L}_{\textrm{EM}} =
- e \sum_i q_i \bar\psi_i\fmslash{A}\psi_i
\end{equation} *)
let mgm ((m1, g, m2), fbf, c) = ((M m1, G g, M m2), fbf, c)
let mom ((m1, o, m2), fbf, c) = ((M m1, O o, M m2), fbf, c)
let electromagnetic_currents n =
List.map mgm
[ ((L (-n), Ga, L n), FBF (1, Psibar, V, Psi), Q_lepton);
((U (-n), Ga, U n), FBF (1, Psibar, V, Psi), Q_up);
((D (-n), Ga, D n), FBF (1, Psibar, V, Psi), Q_down) ]
let color_currents n =
List.map mgm
[ ((U (-n), Gl, U n), FBF ((-1), Psibar, V, Psi), Gs);
((D (-n), Gl, D n), FBF ((-1), Psibar, V, Psi), Gs) ]
(* \begin{equation}
\mathcal{L}_{\textrm{NC}} =
- \frac{g}{2\cos\theta_W}
\sum_i \bar\psi_i\fmslash{Z}(g_V^i-g_A^i\gamma_5)\psi_i
\end{equation} *)
let neutral_currents n =
List.map mgm
[ ((L (-n), Z, L n), FBF (1, Psibar, VA, Psi), G_NC_lepton);
((N (-n), Z, N n), FBF (1, Psibar, VA, Psi), G_NC_neutrino);
((U (-n), Z, U n), FBF (1, Psibar, VA, Psi), G_NC_up);
((D (-n), Z, D n), FBF (1, Psibar, VA, Psi), G_NC_down) ]
(* \begin{equation}
\mathcal{L}_{\textrm{CC}} =
- \frac{g}{2\sqrt2} \sum_i \bar\psi_i
(T^+\fmslash{W}^+ + T^-\fmslash{W}^-)(1-\gamma_5)\psi_i
\end{equation} *)
let charged_currents' n =
List.map mgm
[ ((L (-n), Wm, N n), FBF (1, Psibar, VL, Psi), G_CC);
((N (-n), Wp, L n), FBF (1, Psibar, VL, Psi), G_CC) ]
let charged_currents'' n =
List.map mgm
[ ((D (-n), Wm, U n), FBF (1, Psibar, VL, Psi), G_CC);
((U (-n), Wp, D n), FBF (1, Psibar, VL, Psi), G_CC) ]
let charged_currents_triv =
ThoList.flatmap charged_currents' [1;2;3] @
ThoList.flatmap charged_currents'' [1;2;3]
let charged_currents_ckm =
let charged_currents_2 n1 n2 =
List.map mgm
[ ((D (-n1), Wm, U n2), FBF (1, Psibar, VL, Psi), G_CCQ (n2,n1));
((U (-n1), Wp, D n2), FBF (1, Psibar, VL, Psi), G_CCQ (n1,n2)) ] in
ThoList.flatmap charged_currents' [1;2;3] @
List.flatten (Product.list2 charged_currents_2 [1;2;3] [1;2;3])
let yukawa =
[ ((M (U (-3)), O H, M (U 3)), FBF (1, Psibar, S, Psi), G_Htt);
((M (D (-3)), O H, M (D 3)), FBF (1, Psibar, S, Psi), G_Hbb);
((M (U (-2)), O H, M (U 2)), FBF (1, Psibar, S, Psi), G_Hcc);
((M (L (-3)), O H, M (L 3)), FBF (1, Psibar, S, Psi), G_Htautau) ] @
if Flags.higgs_hmm then
[ ((M (D (-2)), O H, M (D 2)), FBF (1, Psibar, S, Psi), G_Hss);
((M (L (-2)), O H, M (L 2)), FBF (1, Psibar, S, Psi), G_Hmm);
((M (L (-1)), O H, M (L 1)), FBF (1, Psibar, S, Psi), G_Hee) ]
else
[]
(* \begin{equation}
\mathcal{L}_{\textrm{TGC}} =
- e \partial_\mu A_\nu W_+^\mu W_-^\nu + \ldots
- e \cot\theta_w \partial_\mu Z_\nu W_+^\mu W_-^\nu + \ldots
\end{equation} *)
let tgc ((g1, g2, g3), t, c) = ((G g1, G g2, G g3), t, c)
let standard_triple_gauge =
List.map tgc
[ ((Ga, Wm, Wp), Gauge_Gauge_Gauge 1, I_Q_W);
((Z, Wm, Wp), Gauge_Gauge_Gauge 1, I_G_ZWW);
((Gl, Gl, Gl), Gauge_Gauge_Gauge 1, I_Gs)]
(* \begin{multline}
\mathcal{L}_{\textrm{TGC}}(g_1,\kappa)
= g_1 \mathcal{L}_T(V,W^+,W^-) \\
+ \frac{\kappa+g_1}{2} \Bigl(\mathcal{L}_T(W^-,V,W^+)
- \mathcal{L}_T(W^+,V,W^-)\Bigr)\\
+ \frac{\kappa-g_1}{2} \Bigl(\mathcal{L}_L(W^-,V,W^+)
- \mathcal{L}_T(W^+,V,W^-)\Bigr)
\end{multline} *)
(* \begin{dubious}
The whole thing in the LEP2 workshop notation:
\begin{multline}
\ii\mathcal{L}_{\textrm{TGC},V} / g_{WWV} = \\
g_1^V V^\mu (W^-_{\mu\nu}W^{+,\nu}-W^+_{\mu\nu}W^{-,\nu})
+ \kappa_V W^+_\mu W^-_\nu V^{\mu\nu}
+ \frac{\lambda_V}{m_W^2} V_{\mu\nu}
W^-_{\rho\mu} W^{+,\hphantom{\nu}\rho}_{\hphantom{+,}\nu} \\
+ \ii g_5^V \epsilon_{\mu\nu\rho\sigma}
\left( (\partial^\rho W^{-,\mu}) W^{+,\nu}
- W^{-,\mu}(\partial^\rho W^{+,\nu}) \right) V^\sigma \\
+ \ii g_4^V W^-_\mu W^+_\nu (\partial^\mu V^\nu + \partial^\nu V^\mu)
- \frac{\tilde\kappa_V}{2} W^-_\mu W^+_\nu \epsilon^{\mu\nu\rho\sigma}
V_{\rho\sigma}
- \frac{\tilde\lambda_V}{2m_W^2}
W^-_{\rho\mu} W^{+,\mu}_{\hphantom{+,\mu}\nu} \epsilon^{\nu\rho\alpha\beta}
V_{\alpha\beta}
\end{multline}
using the conventions of Itzykson and Zuber with $\epsilon^{0123} = +1$.
\end{dubious} *)
(* \begin{dubious}
This is equivalent to the notation of Hagiwara et al.~\cite{HPZH87}, if we
remember that they have opposite signs for~$g_{WWV}$:
\begin{multline}
\mathcal{L}_{WWV} / (-g_{WWV}) = \\
\ii g_1^V \left( W^\dagger_{\mu\nu} W^\mu
- W^\dagger_\mu W^\mu_{\hphantom{\mu}\nu} \right) V^\nu
+ \ii \kappa_V W^\dagger_\mu W_\nu V^{\mu\nu}
+ \ii \frac{\lambda_V}{m_W^2}
W^\dagger_{\lambda\mu} W^\mu_{\hphantom{\mu}\nu} V^{\nu\lambda} \\
- g_4^V W^\dagger_\mu W_\nu
\left(\partial^\mu V^\nu + \partial^\nu V^\mu \right)
+ g_5^V \epsilon^{\mu\nu\lambda\sigma}
\left( W^\dagger_\mu \stackrel{\leftrightarrow}{\partial_\lambda}
W_\nu \right) V_\sigma\\
+ \ii \tilde\kappa_V W^\dagger_\mu W_\nu \tilde{V}^{\mu\nu}
+ \ii\frac{\tilde\lambda_V}{m_W^2}
W^\dagger_{\lambda\mu} W^\mu_{\hphantom{\mu}\nu} \tilde{V}^{\nu\lambda}
\end{multline}
Here $V^\mu$ stands for either the photon or the~$Z$ field, $W^\mu$ is the
$W^-$ field, $W_{\mu\nu} = \partial_\mu W_\nu - \partial_\nu W_\mu$,
$V_{\mu\nu} = \partial_\mu V_\nu - \partial_\nu V_\mu$, and
$\tilde{V}_{\mu\nu} = \frac{1}{2} \epsilon_{\mu\nu\lambda\sigma}
V^{\lambda\sigma}$.
\end{dubious} *)
let anomalous_triple_gauge =
List.map tgc
[ ((Ga, Wm, Wp), Dim4_Vector_Vector_Vector_T (-1),
I_G1_AWW);
((Z, Wm, Wp), Dim4_Vector_Vector_Vector_T (-1),
I_G1_ZWW);
((Wm, Ga, Wp), Dim4_Vector_Vector_Vector_T 1,
I_G1_plus_kappa_minus_G4_AWW);
((Wm, Z, Wp), Dim4_Vector_Vector_Vector_T 1,
I_G1_plus_kappa_minus_G4_ZWW);
((Wp, Ga, Wm), Dim4_Vector_Vector_Vector_T (-1),
I_G1_plus_kappa_plus_G4_AWW);
((Wp, Z, Wm), Dim4_Vector_Vector_Vector_T (-1),
I_G1_plus_kappa_plus_G4_ZWW);
((Wm, Ga, Wp), Dim4_Vector_Vector_Vector_L (-1),
I_G1_minus_kappa_plus_G4_AWW);
((Wm, Z, Wp), Dim4_Vector_Vector_Vector_L (-1),
I_G1_minus_kappa_plus_G4_ZWW);
((Wp, Ga, Wm), Dim4_Vector_Vector_Vector_L 1,
I_G1_minus_kappa_minus_G4_AWW);
((Wp, Z, Wm), Dim4_Vector_Vector_Vector_L 1,
I_G1_minus_kappa_minus_G4_ZWW);
((Ga, Wm, Wp), Dim4_Vector_Vector_Vector_L5 (-1),
I_kappa5_AWW);
((Z, Wm, Wp), Dim4_Vector_Vector_Vector_L5 (-1),
I_kappa5_ZWW);
((Ga, Wm, Wp), Dim4_Vector_Vector_Vector_T5 (-1),
G5_AWW);
((Z, Wm, Wp), Dim4_Vector_Vector_Vector_T5 (-1),
G5_ZWW);
((Ga, Wp, Wm), Dim6_Gauge_Gauge_Gauge (-1),
I_lambda_AWW);
((Z, Wp, Wm), Dim6_Gauge_Gauge_Gauge (-1),
I_lambda_ZWW);
((Ga, Wp, Wm), Dim6_Gauge_Gauge_Gauge_5 (-1),
I_lambda5_AWW);
((Z, Wp, Wm), Dim6_Gauge_Gauge_Gauge_5 (-1),
I_lambda5_ZWW) ]
let anomalous_dim6_triple_gauge =
List.map tgc
[ ((Ga, Wm, Wp), Dim6_Gauge_Gauge_Gauge_i 1,
I_Dim6_AWW_GGG);
((Ga, Wm, Wp), Dim6_AWW_DP 1,
I_Dim6_AWW_DP);
((Ga, Wm, Wp), Dim6_AWW_DW 1,
I_Dim6_AWW_DW);
((Wm, Wp, Z), Dim6_Gauge_Gauge_Gauge_i 1,
I_Dim6_WWZ_W);
((Wm, Wp, Z), Dim6_WWZ_DPWDW 1,
I_Dim6_WWZ_DPWDW);
((Wm, Wp, Z), Dim6_WWZ_DW 1,
I_Dim6_WWZ_DW);
((Wm, Wp, Z), Dim6_WWZ_D 1,
I_Dim6_WWZ_D)(*i ;
((G, G, G), Dim6_Glu_Glu_Glu 1,
I_Dim6_GGG_G);
((G, G, G), Gauge_Gauge_Gauge_I 1,
I_Dim6_GGG_CG) i*)
]
let triple_gauge =
if Flags.triple_anom then
anomalous_triple_gauge
else if Flags.dim6 then
standard_triple_gauge @ anomalous_dim6_triple_gauge
else
standard_triple_gauge
(* \begin{equation}
\mathcal{L}_{\textrm{QGC}} =
- g^2 W_{+,\mu} W_{-,\nu} W_+^\mu W_-^\nu + \ldots
\end{equation} *)
(* Actually, quartic gauge couplings are a little bit more straightforward
using auxiliary fields. Here we have to impose the antisymmetry manually:
\begin{subequations}
\begin{multline}
(W^{+,\mu}_1 W^{-,\nu}_2 - W^{+,\nu}_1 W^{-,\mu}_2)
(W^+_{3,\mu} W^-_{4,\nu} - W^+_{3,\nu} W^-_{4,\mu}) \\
= 2(W^+_1W^+_3)(W^-_2W^-_4) - 2(W^+_1W^-_4)(W^-_2W^+_3)
\end{multline}
also ($V$ can be $A$ or $Z$)
\begin{multline}
(W^{+,\mu}_1 V^\nu_2 - W^{+,\nu}_1 V^\mu_2)
(W^-_{3,\mu} V_{4,\nu} - W^-_{3,\nu} V_{4,\mu}) \\
= 2(W^+_1W^-_3)(V_2V_4) - 2(W^+_1V_4)(V_2W^-_3)
\end{multline}
\end{subequations} *)
(* \begin{subequations}
\begin{multline}
W^{+,\mu} W^{-,\nu} W^+_\mu W^-_\nu
\end{multline}
\end{subequations} *)
let qgc ((g1, g2, g3, g4), t, c) = ((G g1, G g2, G g3, G g4), t, c)
let gauge4 = Vector4 [(2, C_13_42); (-1, C_12_34); (-1, C_14_23)]
let minus_gauge4 = Vector4 [(-2, C_13_42); (1, C_12_34); (1, C_14_23)]
let standard_quartic_gauge =
List.map qgc
[ (Wm, Wp, Wm, Wp), gauge4, G_WWWW;
(Wm, Z, Wp, Z), minus_gauge4, G_ZZWW;
(Wm, Z, Wp, Ga), minus_gauge4, G_AZWW;
(Wm, Ga, Wp, Ga), minus_gauge4, G_AAWW;
(Gl, Gl, Gl, Gl), gauge4, G2 ]
(* \begin{subequations}
\begin{align}
\mathcal{L}_4
&= \alpha_4 \left( \frac{g^4}{2}\left( (W^+_\mu W^{-,\mu})^2
+ W^+_\mu W^{+,\mu} W^-_\mu W^{-,\mu}
\right)\right.\notag \\
&\qquad\qquad\qquad \left.
+ \frac{g^4}{\cos^2\theta_w} W^+_\mu Z^\mu W^-_\nu Z^\nu
+ \frac{g^4}{4\cos^4\theta_w} (Z_\mu Z^\mu)^2 \right) \\
\mathcal{L}_5
&= \alpha_5 \left( g^4 (W^+_\mu W^{-,\mu})^2
+ \frac{g^4}{\cos^2\theta_w} W^+_\mu W^{-,\mu} Z_\nu Z^\nu
+ \frac{g^4}{4\cos^4\theta_w} (Z_\mu Z^\mu)^2 \right)
\end{align}
\end{subequations}
or
\begin{multline}
\mathcal{L}_4 + \mathcal{L}_5
= (\alpha_4+2\alpha_5) g^4 \frac{1}{2} (W^+_\mu W^{-,\mu})^2 \\
+ 2\alpha_4 g^4 \frac{1}{4} W^+_\mu W^{+,\mu} W^-_\mu W^{-,\mu}
+ \alpha_4 \frac{g^4}{\cos^2\theta_w} W^+_\mu Z^\mu W^-_\nu Z^\nu \\
+ 2\alpha_5 \frac{g^4}{\cos^2\theta_w} \frac{1}{2} W^+_\mu W^{-,\mu} Z_\nu Z^\nu
+ (2\alpha_4 + 2\alpha_5) \frac{g^4}{\cos^4\theta_w} \frac{1}{8} (Z_\mu Z^\mu)^2
\end{multline}
and therefore
\begin{subequations}
\begin{align}
\alpha_{(WW)_0} &= (\alpha_4+2\alpha_5) g^4 \\
\alpha_{(WW)_2} &= 2\alpha_4 g^4 \\
\alpha_{(WZ)_0} &= 2\alpha_5 \frac{g^4}{\cos^2\theta_w} \\
\alpha_{(WZ)_1} &= \alpha_4 \frac{g^4}{\cos^2\theta_w} \\
\alpha_{ZZ} &= (2\alpha_4 + 2\alpha_5) \frac{g^4}{\cos^4\theta_w}
\end{align}
\end{subequations} *)
let anomalous_quartic_gauge =
if Flags.quartic_anom then
List.map qgc
[ ((Wm, Wm, Wp, Wp),
Vector4 [(1, C_13_42); (1, C_14_23)], Alpha_WWWW0);
((Wm, Wm, Wp, Wp),
Vector4 [1, C_12_34], Alpha_WWWW2);
((Wm, Wp, Z, Z),
Vector4 [1, C_12_34], Alpha_ZZWW0);
((Wm, Wp, Z, Z),
Vector4 [(1, C_13_42); (1, C_14_23)], Alpha_ZZWW1);
((Z, Z, Z, Z),
Vector4 [(1, C_12_34); (1, C_13_42); (1, C_14_23)], Alpha_ZZZZ) ]
else
[]
let anomalous_dim6_quartic_gauge =
if Flags.dim6 then
List.map qgc
[ ((Ga, Ga, Wm, Wp),
Dim6_Vector4_DW 1, Anom_Dim6_AAWW_DW);
((Ga, Ga, Wm, Wp),
Dim6_Vector4_W 1, Anom_Dim6_AAWW_W);
((Ga, Z, Wm, Wp),
Dim6_Vector4_W 1, Anom_Dim6_AZWW_W);
((Ga, Z, Wm, Wp),
Dim6_Vector4_DW 1, Anom_Dim6_AZWW_DWDPW);
((Wm, Wp, Wm, Wp),
Dim6_Vector4_W 1, Anom_Dim6_WWWW_W);
((Wm, Wp, Wm, Wp),
Dim6_Vector4_DW 1, Anom_Dim6_WWWW_DWDPW);
((Z, Z, Wm, Wp),
Dim6_Vector4_W 1, Anom_Dim6_WWZZ_W);
((Z, Z, Wm, Wp),
Dim6_Vector4_DW 1, Anom_Dim6_WWZZ_DWDPW)
]
else
[]
(* In any diagonal channel~$\chi$, the scattering amplitude~$a_\chi(s)$ is
unitary iff\footnote{%
Trivial proof:
\begin{equation}
-1 = \textrm{Im}\left(\frac{1}{a_\chi(s)}\right)
= \frac{\textrm{Im}(a_\chi^*(s))}{ |a_\chi(s)|^2 }
= - \frac{\textrm{Im}(a_\chi(s))}{ |a_\chi(s)|^2 }
\end{equation}
i.\,e.~$\textrm{Im}(a_\chi(s)) = |a_\chi(s)|^2$.}
\begin{equation}
\textrm{Im}\left(\frac{1}{a_\chi(s)}\right) = -1
\end{equation}
For a real perturbative scattering amplitude~$r_\chi(s)$ this can be
enforced easily--and arbitrarily--by
\begin{equation}
\frac{1}{a_\chi(s)} = \frac{1}{r_\chi(s)} - \mathrm{i}
\end{equation}
*)
let k_matrix_quartic_gauge =
if Flags.k_matrix then
List.map qgc
[ ((Wm, Wp, Wm, Wp), Vector4_K_Matrix_jr (0,
[(1, C_12_34)]), D_Alpha_WWWW0_S);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_jr (0,
[(1, C_14_23)]), D_Alpha_WWWW0_T);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_jr (0,
[(1, C_13_42)]), D_Alpha_WWWW0_U);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_jr (0,
[(1, C_12_34)]), D_Alpha_WWWW0_S);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_jr (0,
[(1, C_14_23)]), D_Alpha_WWWW0_T);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_jr (0,
[(1, C_13_42)]), D_Alpha_WWWW0_U);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_jr (0,
[(1, C_12_34)]), D_Alpha_WWWW2_S);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_jr (0,
[(1, C_13_42); (1, C_14_23)]), D_Alpha_WWWW2_T);
((Wm, Wp, Z, Z), Vector4_K_Matrix_jr (0,
[(1, C_12_34)]), D_Alpha_ZZWW0_S);
((Wm, Wp, Z, Z), Vector4_K_Matrix_jr (0,
[(1, C_13_42); (1, C_14_23)]), D_Alpha_ZZWW0_T);
((Wm, Z, Wp, Z), Vector4_K_Matrix_jr (0,
[(1, C_12_34)]), D_Alpha_ZZWW1_S);
((Wm, Z, Wp, Z), Vector4_K_Matrix_jr (0,
[(1, C_13_42)]), D_Alpha_ZZWW1_T);
((Wm, Z, Wp, Z), Vector4_K_Matrix_jr (0,
[(1, C_14_23)]), D_Alpha_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_jr (1,
[(1, C_12_34)]), D_Alpha_ZZWW1_S);
((Wp, Z, Z, Wm), Vector4_K_Matrix_jr (1,
[(1, C_13_42)]), D_Alpha_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_jr (1,
[(1, C_14_23)]), D_Alpha_ZZWW1_T);
((Z, Wp, Wm, Z), Vector4_K_Matrix_jr (2,
[(1, C_12_34)]), D_Alpha_ZZWW1_S);
((Z, Wp, Wm, Z), Vector4_K_Matrix_jr (2,
[(1, C_13_42)]), D_Alpha_ZZWW1_U);
((Z, Wp, Wm, Z), Vector4_K_Matrix_jr (2,
[(1, C_14_23)]), D_Alpha_ZZWW1_T);
((Z, Z, Z, Z), Vector4_K_Matrix_jr (0,
[(1, C_12_34)]), D_Alpha_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_jr (0,
[(1, C_13_42); (1, C_14_23)]), D_Alpha_ZZZZ_T);
((Z, Z, Z, Z), Vector4_K_Matrix_jr (3,
[(1, C_14_23)]), D_Alpha_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_jr (3,
[(1, C_13_42); (1, C_12_34)]), D_Alpha_ZZZZ_T)]
else
[]
(*i Thorsten's original implementation of the K matrix, which we keep since
it still might be usefull for the future.
let k_matrix_quartic_gauge =
if Flags.k_matrix then
List.map qgc
[ ((Wm, Wp, Wm, Wp), Vector4_K_Matrix_tho (0, [K_Matrix_Coeff 0,
K_Matrix_Pole 0]), Alpha_WWWW0);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_tho (0, [K_Matrix_Coeff 2,
K_Matrix_Pole 2]), Alpha_WWWW2);
((Wm, Wp, Z, Z), Vector4_K_Matrix_tho (0, [(K_Matrix_Coeff 0,
K_Matrix_Pole 0); (K_Matrix_Coeff 2,
K_Matrix_Pole 2)]), Alpha_ZZWW0);
((Wm, Z, Wp, Z), Vector4_K_Matrix_tho (0, [K_Matrix_Coeff 1,
K_Matrix_Pole 1]), Alpha_ZZWW1);
((Z, Z, Z, Z), Vector4_K_Matrix_tho (0, [K_Matrix_Coeff 0,
K_Matrix_Pole 0]), Alpha_ZZZZ) ]
else
[]
i*)
let quartic_gauge =
standard_quartic_gauge @ anomalous_quartic_gauge @
anomalous_dim6_quartic_gauge @ k_matrix_quartic_gauge
let standard_gauge_higgs =
[ ((O H, G Wp, G Wm), Scalar_Vector_Vector 1, G_HWW);
((O H, G Z, G Z), Scalar_Vector_Vector 1, G_HZZ) ]
let standard_gauge_higgs4 =
[ (O H, O H, G Wp, G Wm), Scalar2_Vector2 1, G_HHWW;
(O H, O H, G Z, G Z), Scalar2_Vector2 1, G_HHZZ ]
let standard_higgs =
[ (O H, O H, O H), Scalar_Scalar_Scalar 1, G_H3 ]
let standard_higgs4 =
[ (O H, O H, O H, O H), Scalar4 1, G_H4 ]
(* WK's couplings (apparently, he still intends to divide by
$\Lambda^2_{\text{EWSB}}=16\pi^2v_{\mathrm{F}}^2$):
\begin{subequations}
\begin{align}
\mathcal{L}^{\tau}_4 &=
\left\lbrack (\partial_{\mu}H)(\partial^{\mu}H)
+ \frac{g^2v_{\mathrm{F}}^2}{4} V_{\mu} V^{\mu} \right\rbrack^2 \\
\mathcal{L}^{\tau}_5 &=
\left\lbrack (\partial_{\mu}H)(\partial_{\nu}H)
+ \frac{g^2v_{\mathrm{F}}^2}{4} V_{\mu} V_{\nu} \right\rbrack^2
\end{align}
\end{subequations}
with
\begin{equation}
V_{\mu} V_{\nu} =
\frac{1}{2} \left( W^+_{\mu} W^-_{\nu} + W^+_{\nu} W^-_{\mu} \right)
+ \frac{1}{2\cos^2\theta_{w}} Z_{\mu} Z_{\nu}
\end{equation}
(note the symmetrization!), i.\,e.
\begin{subequations}
\begin{align}
\mathcal{L}_4 &= \alpha_4 \frac{g^4v_{\mathrm{F}}^4}{16} (V_{\mu} V_{\nu})^2 \\
\mathcal{L}_5 &= \alpha_5 \frac{g^4v_{\mathrm{F}}^4}{16} (V_{\mu} V^{\mu})^2
\end{align}
\end{subequations} *)
(* Breaking thinks up
\begin{subequations}
\begin{align}
\mathcal{L}^{\tau,H^4}_4 &=
\left\lbrack (\partial_{\mu}H)(\partial^{\mu}H) \right\rbrack^2 \\
\mathcal{L}^{\tau,H^4}_5 &=
\left\lbrack (\partial_{\mu}H)(\partial^{\mu}H) \right\rbrack^2
\end{align}
\end{subequations}
and
\begin{subequations}
\begin{align}
\mathcal{L}^{\tau,H^2V^2}_4 &= \frac{g^2v_{\mathrm{F}}^2}{2}
(\partial_{\mu}H)(\partial^{\mu}H) V_{\mu}V^{\mu} \\
\mathcal{L}^{\tau,H^2V^2}_5 &= \frac{g^2v_{\mathrm{F}}^2}{2}
(\partial_{\mu}H)(\partial_{\nu}H) V_{\mu}V_{\nu}
\end{align}
\end{subequations}
i.\,e.
\begin{subequations}
\begin{align}
\mathcal{L}^{\tau,H^2V^2}_4 &=
\frac{g^2v_{\mathrm{F}}^2}{2}
\left\lbrack
(\partial_{\mu}H)(\partial^{\mu}H) W^+_{\nu}W^{-,\nu}
+ \frac{1}{2\cos^2\theta_{w}} (\partial_{\mu}H)(\partial^{\mu}H) Z_{\nu} Z^{\nu}
\right\rbrack \\
\mathcal{L}^{\tau,H^2V^2}_5 &=
\frac{g^2v_{\mathrm{F}}^2}{2}
\left\lbrack
(W^{+,\mu}\partial_{\mu}H) (W^{-,\nu}\partial_{\nu}H)
+ \frac{1}{2\cos^2\theta_{w}} (Z^{\mu}\partial_{\mu}H)(Z^{\nu}\partial_{\nu}H)
\right\rbrack
\end{align}
\end{subequations} *)
(* \begin{multline}
\tau^4_8 \mathcal{L}^{\tau,H^2V^2}_4 + \tau^5_8 \mathcal{L}^{\tau,H^2V^2}_5 = \\
- \frac{g^2v_{\mathrm{F}}^2}{2} \Biggl\lbrack
2\tau^4_8
\frac{1}{2}(\ii\partial_{\mu}H)(\ii\partial^{\mu}H) W^+_{\nu}W^{-,\nu}
+ \tau^5_8
(W^{+,\mu}\ii\partial_{\mu}H) (W^{-,\nu}\ii\partial_{\nu}H) \\
+ \frac{2\tau^4_8}{\cos^2\theta_{w}}
\frac{1}{4} (\ii\partial_{\mu}H)(\ii\partial^{\mu}H) Z_{\nu} Z^{\nu}
+ \frac{\tau^5_8}{\cos^2\theta_{w}}
\frac{1}{2} (Z^{\mu}\ii\partial_{\mu}H)(Z^{\nu}\ii\partial_{\nu}H)
\Biggr\rbrack
\end{multline}
where the two powers of $\ii$ make the sign conveniently negative,
i.\,e.
\begin{subequations}
\begin{align}
\alpha_{(\partial H)^2W^2}^2 &= \tau^4_8 g^2v_{\mathrm{F}}^2\\
\alpha_{(\partial HW)^2}^2 &= \frac{\tau^5_8 g^2v_{\mathrm{F}}^2}{2} \\
\alpha_{(\partial H)^2Z^2}^2 &= \frac{\tau^4_8 g^2v_{\mathrm{F}}^2}{\cos^2\theta_{w}} \\
\alpha_{(\partial HZ)^2}^2 &=\frac{\tau^5_8 g^2v_{\mathrm{F}}^2}{2\cos^2\theta_{w}}
\end{align}
\end{subequations} *)
let anomalous_gauge_higgs =
[ (O H, G Ga, G Ga), Dim5_Scalar_Gauge2 1, G_HGaGa_anom;
(O H, G Ga, G Z), Dim5_Scalar_Gauge2 1, G_HGaZ_anom;
(O H, G Z, G Z), Dim5_Scalar_Gauge2 1, G_HZZ_anom;
(O H, G Wp, G Wm), Dim5_Scalar_Gauge2 1, G_HWW_anom;
(O H, G Ga, G Z), Dim5_Scalar_Vector_Vector_TU 1, G_HGaZ_u;
(O H, G Z, G Z), Dim5_Scalar_Vector_Vector_U 1, G_HZZ_u;
(O H, G Wp, G Wm), Dim5_Scalar_Vector_Vector_U 1, G_HWW_u
]
let anomalous_dim6_gauge_higgs =
[ (O H, G Z, G Z), Scalar_Vector_Vector 1, G_HZZ6_V3;
(O H, G Z, G Z), Dim6_Scalar_Vector_Vector_D 1, G_HZZ6_D;
(O H, G Z, G Z), Dim6_Scalar_Vector_Vector_DP 1, G_HZZ6_DP;
(O H, G Z, G Z), Scalar_Vector_Vector_t 1, G_HZZ6_PB;
(O H, G Ga, G Z), Dim6_HAZ_D 1, G_HGaZ6_D;
(O H, G Ga, G Z), Dim6_HAZ_DP 1, G_HGaZ6_DP;
(O H, G Ga, G Z), Scalar_Vector_Vector_t 1, G_HGaZ6_PB;
(O H, G Ga, G Ga), Scalar_Vector_Vector_t 1, G_HGaGa6;
(O H, G Wm, G Wp), Dim6_Scalar_Vector_Vector_D 1, G_HWW_6_D;
(O H, G Wm, G Wp), Dim6_Scalar_Vector_Vector_DP 1, G_HWW_6_DP
]
let anomalous_gauge_higgs4 =
[]
let anomalous_dim6_gauge_higgs4 =
[(G Ga, O H, G Wm, G Wp), Dim6_AHWW_DPB 1, Anom_Dim6_AHWW_DPB;
(G Ga, O H, G Wm, G Wp), Dim6_AHWW_DPW 1, Anom_Dim6_AHWW_DPW;
(G Ga, O H, G Wm, G Wp), Dim6_AHWW_DW 1, Anom_Dim6_AHWW_DW;
(O H, G Wm, G Wp, G Z), Dim6_HWWZ_DW 1, Anom_Dim6_HWWZ_DW;
(O H, G Wm, G Wp, G Z), Dim6_HWWZ_DDPW 1, Anom_Dim6_HWWZ_DDPW;
(O H, G Wm, G Wp, G Z), Dim6_HWWZ_DPW 1, Anom_Dim6_HWWZ_DPW;
(O H, G Wm, G Wp, G Z), Dim6_HWWZ_DPB 1, Anom_Dim6_HWWZ_DPB;
(G Ga, O H, O H, G Z), Dim6_AHHZ_D 1, Anom_Dim6_AHHZ_D;
(G Ga, O H, O H, G Z), Dim6_AHHZ_DP 1, Anom_Dim6_AHHZ_DP;
(G Ga, O H, O H, G Z), Dim6_AHHZ_PB 1, Anom_Dim6_AHHZ_PB;
(O H, O H, G Ga, G Ga), Dim6_Scalar2_Vector2_PB 1, Anom_Dim6_HHAA;
(O H, O H, G Wm, G Wp), Dim6_Scalar2_Vector2_D 1, Anom_Dim6_HHWW_DW;
(O H, O H, G Wm, G Wp), Dim6_Scalar2_Vector2_DP 1, Anom_Dim6_HHWW_DPW;
(O H, O H, G Z, G Z), Dim6_HHZZ_T 1, Anom_Dim6_HHZZ_T;
(O H, O H, G Z, G Z), Dim6_Scalar2_Vector2_D 1, Anom_Dim6_HHZZ_D;
(O H, O H, G Z, G Z), Dim6_Scalar2_Vector2_DP 1, Anom_Dim6_HHZZ_DP;
(O H, O H, G Z, G Z), Dim6_Scalar2_Vector2_PB 1, Anom_Dim6_HHZZ_PB
]
let anomalous_higgs =
[]
let anomalous_dim6_higgs =
[(O H, O H, O H), Scalar_Scalar_Scalar 1, Dim6_vev3;
(O H, O H, O H), Dim6_HHH 1, Dim6_Cphi ]
let higgs_triangle_vertices =
if Flags.higgs_triangle then
[ (O H, G Ga, G Ga), Dim5_Scalar_Gauge2 1, G_HGaGa;
(O H, G Ga, G Z), Dim5_Scalar_Gauge2 1, G_HGaZ;
(O H, G Gl, G Gl), Dim5_Scalar_Gauge2 1, G_Hgg ]
else
[]
let anomalous_higgs4 =
[]
let anomalous_dim6_higgs4 =
[(O H, O H, O H, O H), Scalar4 1, Anom_Dim6_H4_v2;
(O H, O H, O H, O H), Dim6_H4_P2 1, Anom_Dim6_H4_P2]
let gauge_higgs =
if Flags.higgs_anom then
standard_gauge_higgs @ anomalous_gauge_higgs
else if Flags.dim6 then
standard_gauge_higgs @ anomalous_dim6_gauge_higgs
else
standard_gauge_higgs
let gauge_higgs4 =
if Flags.higgs_anom then
standard_gauge_higgs4 @ anomalous_gauge_higgs4
else if Flags.dim6 then
standard_gauge_higgs4 @ anomalous_dim6_gauge_higgs4
else
standard_gauge_higgs4
let higgs =
if Flags.higgs_anom then
standard_higgs @ anomalous_higgs
else if Flags.dim6 then
standard_higgs @ anomalous_dim6_higgs
else
standard_higgs
let higgs4 =
if Flags.higgs_anom then
standard_higgs4 @ anomalous_higgs4
else if Flags.dim6 then
standard_higgs4 @ anomalous_dim6_higgs4
else
standard_higgs4
let goldstone_vertices =
[ ((O Phi0, G Wm, G Wp), Scalar_Vector_Vector 1, I_G_ZWW);
((O Phip, G Ga, G Wm), Scalar_Vector_Vector 1, I_Q_W);
((O Phip, G Z, G Wm), Scalar_Vector_Vector 1, I_G_ZWW);
((O Phim, G Wp, G Ga), Scalar_Vector_Vector 1, I_Q_W);
((O Phim, G Wp, G Z), Scalar_Vector_Vector 1, I_G_ZWW) ]
(* Anomalous trilinear interactions $f_i f_j V$ and $ttH$:
\begin{equation}
\Delta\mathcal{L}_{tt\gamma} =
- e \frac{\upsilon}{\Lambda^2}
\bar{t} i\sigma^{\mu\nu} k_\nu (d_V(k^2) + i d_A(k^2) \gamma_5) t A_\mu
\end{equation}
\begin{equation}
\Delta\mathcal{L}_{tc\gamma} =
- e \frac{\upsilon}{\Lambda^2}
\bar{t} i\sigma^{\mu\nu} k_\nu (d_V(k^2) + i d_A(k^2) \gamma_5) c A_\mu \,\text{+\,h.c.}
\end{equation}
*)
let anomalous_ttA =
if Flags.top_anom then
[ ((M (U (-3)), G Ga, M (U 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_ttA);
((M (U (-3)), G Ga, M (U 2)), FBF (1, Psibar, TVAM, Psi), G_TVA_tcA);
((M (U (-2)), G Ga, M (U 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_tcA);
((M (U (-3)), G Ga, M (U 1)), FBF (1, Psibar, TVAM, Psi), G_TVA_tuA);
((M (U (-1)), G Ga, M (U 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_tuA)]
else
[]
let tt_threshold_ttA =
if Flags.tt_threshold then
[ ((M (U (-3)), G Ga, M (U 3)), FBF (1, Psibar, VAM, Psi), VA_ILC_ttA) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{bb\gamma} =
- e \frac{\upsilon}{\Lambda^2}
\bar{b} i\sigma^{\mu\nu} k_\nu (d_V(k^2) + i d_A(k^2) \gamma_5) b A_\mu
\end{equation} *)
let anomalous_bbA =
if Flags.top_anom then
[ ((M (D (-3)), G Ga, M (D 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_bbA) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{ttg} =
- g_s \frac{\upsilon}{\Lambda^2}
\bar{t}\lambda^a i\sigma^{\mu\nu}k_\nu
(d_V(k^2)+id_A(k^2)\gamma_5)tG^a_\mu
\end{equation}
\begin{equation}
\Delta\mathcal{L}_{tcg} =
- g_s \frac{\upsilon}{\Lambda^2}
\bar{t}\lambda^a i\sigma^{\mu\nu}k_\nu
(d_V(k^2)+id_A(k^2)\gamma_5)cG^a_\mu\,\text{+\,h.c.}
\end{equation}
*)
let anomalous_ttG =
if Flags.top_anom then
[ ((M (U (-3)), G Gl, M (U 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_ttG);
((M (U (-3)), G Gl, M (U 2)), FBF (1, Psibar, TVAM, Psi), G_TVA_tcG);
((M (U (-2)), G Gl, M (U 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_tcG);
((M (U (-3)), G Gl, M (U 1)), FBF (1, Psibar, TVAM, Psi), G_TVA_tuG);
((M (U (-1)), G Gl, M (U 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_tuG)]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{ttZ} =
- \frac{g}{2 c_W} \frac{\upsilon^2}{\Lambda^2}\left\lbrack
\bar{t} \fmslash{Z} (X_L(k^2) P_L + X_R(k^2) P_R) t
+ \bar{t}\frac{i\sigma^{\mu\nu}k_\nu}{m_Z}
(d_V(k^2)+id_A(k^2)\gamma_5)tZ_\mu\right\rbrack
\end{equation}
\begin{equation}
\Delta\mathcal{L}_{tcZ} =
- \frac{g}{2 c_W} \frac{\upsilon^2}{\Lambda^2}\left\lbrack
\bar{t} \fmslash{Z} (X_L(k^2) P_L + X_R(k^2) P_R) c
+ \bar{t}\frac{i\sigma^{\mu\nu}k_\nu}{m_Z}
(d_V(k^2)+id_A(k^2)\gamma_5)cZ_\mu\right\rbrack
\,\text{+\,h.c.}
\end{equation} *)
let anomalous_ttZ =
if Flags.top_anom then
[ ((M (U (-3)), G Z, M (U 3)), FBF (1, Psibar, VLRM, Psi), G_VLR_ttZ);
((M (U (-3)), G Z, M (U 2)), FBF (1, Psibar, VLRM, Psi), G_VLR_tcZ);
((M (U (-2)), G Z, M (U 3)), FBF (1, Psibar, VLRM, Psi), G_VLR_tcZ);
((M (U (-3)), G Z, M (U 1)), FBF (1, Psibar, VLRM, Psi), G_VLR_tuZ);
((M (U (-1)), G Z, M (U 3)), FBF (1, Psibar, VLRM, Psi), G_VLR_tuZ);
((M (U (-3)), G Z, M (U 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_ttZ);
((M (U (-2)), G Z, M (U 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_tcZ);
((M (U (-3)), G Z, M (U 2)), FBF (1, Psibar, TVAM, Psi), G_TVA_tcZ);
((M (U (-1)), G Z, M (U 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_tuZ);
((M (U (-3)), G Z, M (U 1)), FBF (1, Psibar, TVAM, Psi), G_TVA_tuZ)]
else
[]
let tt_threshold_ttZ =
if Flags.tt_threshold then
[ ((M (U (-3)), G Z, M (U 3)), FBF (1, Psibar, VAM, Psi), VA_ILC_ttZ) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{bbZ} =
- \frac{g}{2 c_W} \frac{\upsilon^2}{\Lambda^2}
\bar{b}\frac{i\sigma^{\mu\nu}k_\nu}{m_Z}
(d_V(k^2)+id_A(k^2)\gamma_5)bZ_\mu
\end{equation} *)
let anomalous_bbZ =
if Flags.top_anom then
[ ((M (D (-3)), G Z, M (D 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_bbZ) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{tbW} =
- \frac{g}{\sqrt{2}} \frac{\upsilon^2}{\Lambda^2}\left\lbrack
\bar{b}\fmslash{W}^-(V_L(k^2) P_L+V_R(k^2) P_R) t
+ \bar{b}\frac{i\sigma^{\mu\nu}k_\nu}{m_W}
(g_L(k^2)P_L+g_R(k^2)P_R)tW^-_\mu\right\rbrack
\,\text{+\,h.c.}
\end{equation} *)
let anomalous_tbW =
if Flags.top_anom then
[ ((M (D (-3)), G Wm, M (U 3)), FBF (1, Psibar, VLRM, Psi), G_VLR_btW);
((M (U (-3)), G Wp, M (D 3)), FBF (1, Psibar, VLRM, Psi), G_VLR_tbW);
((M (D (-3)), G Wm, M (U 3)), FBF (1, Psibar, TLRM, Psi), G_TLR_btW);
((M (U (-3)), G Wp, M (D 3)), FBF (1, Psibar, TRLM, Psi), G_TRL_tbW) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{ttH} =
- \frac{1}{\sqrt{2}} \bar{t} (Y_V(k^2)+iY_A(k^2)\gamma_5)t H
\end{equation} *)
let anomalous_ttH =
if Flags.top_anom then
[ ((M (U (-3)), O H, M (U 3)), FBF (1, Psibar, SPM, Psi), G_SP_ttH) ]
else
[]
(* quartic fermion-gauge interactions $f_i f_j V_1 V_2$ emerging from gauge-invariant
effective operators:
\begin{equation}
\Delta\mathcal{L}_{ttgg} =
- \frac{g_s^2}{2} f_{abc} \frac{\upsilon}{\Lambda^2}
\bar{t} \lambda^a \sigma^{\mu\nu}
(d_V(k^2)+id_A(k^2)\gamma_5)t G^b_\mu G^c_\nu
\end{equation}
\begin{equation}
\Delta\mathcal{L}_{tcgg} =
- \frac{g_s^2}{2} f_{abc} \frac{\upsilon}{\Lambda^2}
\bar{t} \lambda^a \sigma^{\mu\nu}
(d_V(k^2)+id_A(k^2)\gamma_5)c G^b_\mu G^c_\nu
\,\text{+\,h.c.}
\end{equation}
*)
let anomalous_ttGG =
if Flags.top_anom then
[ ((M (U (-3)), O (Aux_top (2,1,0,true,TTGG)), M (U 3)),
FBF (1, Psibar, TVA, Psi), G_TVA_ttGG);
((M (U (-3)), O (Aux_top (2,1,0,true,TCGG)), M (U 2)),
FBF (1, Psibar, TVA, Psi), G_TVA_tcGG);
((M (U (-2)), O (Aux_top (2,1,0,true,TCGG)), M (U 3)),
FBF (1, Psibar, TVA, Psi), G_TVA_tcGG);
((M (U (-3)), O (Aux_top (2,1,0,true,TUGG)), M (U 1)),
FBF (1, Psibar, TVA, Psi), G_TVA_tuGG);
((M (U (-1)), O (Aux_top (2,1,0,true,TUGG)), M (U 3)),
FBF (1, Psibar, TVA, Psi), G_TVA_tuGG);
((O (Aux_top (2,1,0,false,TTGG)), G Gl, G Gl),
Aux_Gauge_Gauge 1, I_Gs);
((O (Aux_top (2,1,0,false,TCGG)), G Gl, G Gl),
Aux_Gauge_Gauge 1, I_Gs);
((O (Aux_top (2,1,0,false,TUGG)), G Gl, G Gl),
Aux_Gauge_Gauge 1, I_Gs)]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{tbWA} =
- i\sin\theta_w \frac{g^2}{2\sqrt{2}} \frac{\upsilon^2}{\Lambda^2}\left\lbrack
\bar{b}\frac{\sigma^{\mu\nu}}{m_W}
(g_L(k^2)P_L+g_R(k^2)P_R)t A_\mu W^-_\nu \right\rbrack
\,\text{+\,h.c.}
\end{equation} *)
let anomalous_tbWA =
if Flags.top_anom then
[ ((M (D (-3)), O (Aux_top (2,0,-1,true,TBWA)), M (U 3)), FBF (1, Psibar, TLR, Psi), G_TLR_btWA);
((O (Aux_top (2,0,1,false,TBWA)), G Ga, G Wm), Aux_Gauge_Gauge 1, I_G_weak);
((M (U (-3)), O (Aux_top (2,0,1,true,TBWA)), M (D 3)), FBF (1, Psibar, TRL, Psi), G_TRL_tbWA);
((O (Aux_top (2,0,-1,false,TBWA)), G Wp, G Ga), Aux_Gauge_Gauge 1, I_G_weak) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{tbWZ} =
- i\cos\theta_w \frac{g^2}{2\sqrt{2}} \frac{\upsilon^2}{\Lambda^2}\left\lbrack
\bar{b}\frac{\sigma^{\mu\nu}}{m_W}
(g_L(k^2)P_L+g_R(k^2)P_R)t Z_\mu W^-_\nu \right\rbrack
\,\text{+\,h.c.}
\end{equation} *)
let anomalous_tbWZ =
if Flags.top_anom then
[ ((M (D (-3)), O (Aux_top (2,0,-1,true,TBWZ)), M (U 3)),
FBF (1, Psibar, TLR, Psi), G_TLR_btWZ);
((O (Aux_top (2,0,1,false,TBWZ)), G Z, G Wm),
Aux_Gauge_Gauge 1, I_G_weak);
((M (U (-3)), O (Aux_top (2,0,1,true,TBWZ)), M (D 3)),
FBF (1, Psibar, TRL, Psi), G_TRL_tbWZ);
((O (Aux_top (2,0,-1,false,TBWZ)), G Wp, G Z),
Aux_Gauge_Gauge 1, I_G_weak) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{ttWW} =
- i \frac{g^2}{2} \frac{\upsilon^2}{\Lambda^2}
\bar{t} \frac{\sigma^{\mu\nu}}{m_W}
(d_V(k^2)+id_A(k^2)\gamma_5)t W^-_\mu W^+_\nu
\end{equation} *)
let anomalous_ttWW =
if Flags.top_anom then
[ ((M (U (-3)), O (Aux_top (2,0,0,true,TTWW)), M (U 3)), FBF (1, Psibar, TVA, Psi), G_TVA_ttWW);
((O (Aux_top (2,0,0,false,TTWW)), G Wm, G Wp), Aux_Gauge_Gauge 1, I_G_weak) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{bbWW} =
- i \frac{g^2}{2} \frac{\upsilon^2}{\Lambda^2}
\bar{b} \frac{\sigma^{\mu\nu}}{m_W}
(d_V(k^2)+id_A(k^2)\gamma_5)b W^-_\mu W^+_\nu
\end{equation} *)
let anomalous_bbWW =
if Flags.top_anom then
[ ((M (D (-3)), O (Aux_top (2,0,0,true,BBWW)), M (D 3)), FBF (1, Psibar, TVA, Psi), G_TVA_bbWW);
((O (Aux_top (2,0,0,false,BBWW)), G Wm, G Wp), Aux_Gauge_Gauge 1, I_G_weak) ]
else
[]
(* 4-fermion contact terms emerging from operator rewriting: *)
let anomalous_top_qGuG_tt =
[ ((M (U (-3)), O (Aux_top (1,1,0,true,QGUG)), M (U 3)), FBF (1, Psibar, VLR, Psi), G_VLR_qGuG) ]
let anomalous_top_qGuG_ff n =
List.map mom
[ ((U (-n), Aux_top (1,1,0,false,QGUG), U n), FBF (1, Psibar, V, Psi), Unit);
((D (-n), Aux_top (1,1,0,false,QGUG), D n), FBF (1, Psibar, V, Psi), Unit) ]
let anomalous_top_qGuG =
if Flags.top_anom_4f then
anomalous_top_qGuG_tt @ ThoList.flatmap anomalous_top_qGuG_ff [1;2;3]
else
[]
let anomalous_top_qBuB_tt =
[ ((M (U (-3)), O (Aux_top (1,0,0,true,QBUB)), M (U 3)), FBF (1, Psibar, VLR, Psi), G_VLR_qBuB) ]
let anomalous_top_qBuB_ff n =
List.map mom
[ ((U (-n), Aux_top (1,0,0,false,QBUB), U n), FBF (1, Psibar, VLR, Psi), G_VLR_qBuB_u);
((D (-n), Aux_top (1,0,0,false,QBUB), D n), FBF (1, Psibar, VLR, Psi), G_VLR_qBuB_d);
((L (-n), Aux_top (1,0,0,false,QBUB), L n), FBF (1, Psibar, VLR, Psi), G_VLR_qBuB_e);
((N (-n), Aux_top (1,0,0,false,QBUB), N n), FBF (1, Psibar, VL, Psi), G_VL_qBuB_n) ]
let anomalous_top_qBuB =
if Flags.top_anom_4f then
anomalous_top_qBuB_tt @ ThoList.flatmap anomalous_top_qBuB_ff [1;2;3]
else
[]
let anomalous_top_qW_tq =
[ ((M (U (-3)), O (Aux_top (1,0,0,true,QW)), M (U 3)), FBF (1, Psibar, VL, Psi), G_VL_qW);
((M (D (-3)), O (Aux_top (1,0,-1,true,QW)), M (U 3)), FBF (1, Psibar, VL, Psi), G_VL_qW);
((M (U (-3)), O (Aux_top (1,0,1,true,QW)), M (D 3)), FBF (1, Psibar, VL, Psi), G_VL_qW) ]
let anomalous_top_qW_ff n =
List.map mom
[ ((U (-n), Aux_top (1,0,0,false,QW), U n), FBF (1, Psibar, VL, Psi), G_VL_qW_u);
((D (-n), Aux_top (1,0,0,false,QW), D n), FBF (1, Psibar, VL, Psi), G_VL_qW_d);
((N (-n), Aux_top (1,0,0,false,QW), N n), FBF (1, Psibar, VL, Psi), G_VL_qW_u);
((L (-n), Aux_top (1,0,0,false,QW), L n), FBF (1, Psibar, VL, Psi), G_VL_qW_d);
((D (-n), Aux_top (1,0,-1,false,QW), U n), FBF (1, Psibar, VL, Psi), Half);
((U (-n), Aux_top (1,0,1,false,QW), D n), FBF (1, Psibar, VL, Psi), Half);
((L (-n), Aux_top (1,0,-1,false,QW), N n), FBF (1, Psibar, VL, Psi), Half);
((N (-n), Aux_top (1,0,1,false,QW), L n), FBF (1, Psibar, VL, Psi), Half) ]
let anomalous_top_qW =
if Flags.top_anom_4f then
anomalous_top_qW_tq @ ThoList.flatmap anomalous_top_qW_ff [1;2;3]
else
[]
let anomalous_top_DuDd =
if Flags.top_anom_4f then
[ ((M (U (-3)), O (Aux_top (0,0,0,true,DR)), M (U 3)), FBF (1, Psibar, SR, Psi), Half);
((M (U (-3)), O (Aux_top (0,0,0,false,DR)), M (U 3)), FBF (1, Psibar, SL, Psi), G_SL_DttR);
((M (D (-3)), O (Aux_top (0,0,0,false,DR)), M (D 3)), FBF (1, Psibar, SR, Psi), G_SR_DttR);
((M (U (-3)), O (Aux_top (0,0,0,true,DL)), M (U 3)), FBF (1, Psibar, SL, Psi), Half);
((M (D (-3)), O (Aux_top (0,0,0,false,DL)), M (D 3)), FBF (1, Psibar, SL, Psi), G_SL_DttL);
((M (D (-3)), O (Aux_top (0,0,-1,true,DR)), M (U 3)), FBF (1, Psibar, SR, Psi), Half);
((M (U (-3)), O (Aux_top (0,0,1,false,DR)), M (D 3)), FBF (1, Psibar, SLR, Psi), G_SLR_DbtR);
((M (D (-3)), O (Aux_top (0,0,-1,true,DL)), M (U 3)), FBF (1, Psibar, SL, Psi), Half);
((M (U (-3)), O (Aux_top (0,0,1,false,DL)), M (D 3)), FBF (1, Psibar, SL, Psi), G_SL_DbtL) ]
else
[]
let anomalous_top_quqd1_tq =
[ ((M (D (-3)), O (Aux_top (0,0,-1,true,QUQD1R)), M (U 3)), FBF (1, Psibar, SR, Psi), C_quqd1R_bt);
((M (U (-3)), O (Aux_top (0,0, 1,true,QUQD1R)), M (D 3)), FBF (1, Psibar, SL, Psi), C_quqd1R_tb);
((M (D (-3)), O (Aux_top (0,0,-1,true,QUQD1L)), M (U 3)), FBF (1, Psibar, SL, Psi), C_quqd1L_bt);
((M (U (-3)), O (Aux_top (0,0, 1,true,QUQD1L)), M (D 3)), FBF (1, Psibar, SR, Psi), C_quqd1L_tb) ]
let anomalous_top_quqd1_ff n =
List.map mom
[ ((U (-n), Aux_top (0,0, 1,false,QUQD1R), D n), FBF (1, Psibar, SR, Psi), Half);
((D (-n), Aux_top (0,0,-1,false,QUQD1R), U n), FBF (1, Psibar, SL, Psi), Half);
((U (-n), Aux_top (0,0, 1,false,QUQD1L), D n), FBF (1, Psibar, SL, Psi), Half);
((D (-n), Aux_top (0,0,-1,false,QUQD1L), U n), FBF (1, Psibar, SR, Psi), Half) ]
let anomalous_top_quqd1 =
if Flags.top_anom_4f then
anomalous_top_quqd1_tq @ ThoList.flatmap anomalous_top_quqd1_ff [1;2;3]
else
[]
let anomalous_top_quqd8_tq =
[ ((M (D (-3)), O (Aux_top (0,1,-1,true,QUQD8R)), M (U 3)), FBF (1, Psibar, SR, Psi), C_quqd8R_bt);
((M (U (-3)), O (Aux_top (0,1, 1,true,QUQD8R)), M (D 3)), FBF (1, Psibar, SL, Psi), C_quqd8R_tb);
((M (D (-3)), O (Aux_top (0,1,-1,true,QUQD8L)), M (U 3)), FBF (1, Psibar, SL, Psi), C_quqd8L_bt);
((M (U (-3)), O (Aux_top (0,1, 1,true,QUQD8L)), M (D 3)), FBF (1, Psibar, SR, Psi), C_quqd8L_tb) ]
let anomalous_top_quqd8_ff n =
List.map mom
[ ((U (-n), Aux_top (0,1, 1,false,QUQD8R), D n), FBF (1, Psibar, SR, Psi), Half);
((D (-n), Aux_top (0,1,-1,false,QUQD8R), U n), FBF (1, Psibar, SL, Psi), Half);
((U (-n), Aux_top (0,1, 1,false,QUQD8L), D n), FBF (1, Psibar, SL, Psi), Half);
((D (-n), Aux_top (0,1,-1,false,QUQD8L), U n), FBF (1, Psibar, SR, Psi), Half) ]
let anomalous_top_quqd8 =
if Flags.top_anom_4f then
anomalous_top_quqd8_tq @ ThoList.flatmap anomalous_top_quqd8_ff [1;2;3]
else
[]
let vertices3 =
(ThoList.flatmap electromagnetic_currents [1;2;3] @
ThoList.flatmap color_currents [1;2;3] @
ThoList.flatmap neutral_currents [1;2;3] @
(if Flags.ckm_present then
charged_currents_ckm
else
charged_currents_triv) @
yukawa @ triple_gauge @
gauge_higgs @ higgs @ higgs_triangle_vertices
@ goldstone_vertices @
tt_threshold_ttA @ tt_threshold_ttZ @
anomalous_ttA @ anomalous_bbA @
anomalous_ttZ @ anomalous_bbZ @
anomalous_tbW @ anomalous_tbWA @ anomalous_tbWZ @
anomalous_ttWW @ anomalous_bbWW @
anomalous_ttG @ anomalous_ttGG @
anomalous_ttH @
anomalous_top_qGuG @ anomalous_top_qBuB @
anomalous_top_qW @ anomalous_top_DuDd @
anomalous_top_quqd1 @ anomalous_top_quqd8)
let vertices4 =
quartic_gauge @ gauge_higgs4 @ higgs4
let vertices () = (vertices3, vertices4, [])
(* For efficiency, make sure that [F.of_vertices vertices] is
evaluated only once. *)
let table = F.of_vertices (vertices ())
let fuse2 = F.fuse2 table
let fuse3 = F.fuse3 table
let fuse = F.fuse table
let max_degree () = 4
let flavor_of_string = function
| "e-" -> M (L 1) | "e+" -> M (L (-1))
| "mu-" -> M (L 2) | "mu+" -> M (L (-2))
| "tau-" -> M (L 3) | "tau+" -> M (L (-3))
| "nue" -> M (N 1) | "nuebar" -> M (N (-1))
| "numu" -> M (N 2) | "numubar" -> M (N (-2))
| "nutau" -> M (N 3) | "nutaubar" -> M (N (-3))
| "u" -> M (U 1) | "ubar" -> M (U (-1))
| "c" -> M (U 2) | "cbar" -> M (U (-2))
| "t" -> M (U 3) | "tbar" -> M (U (-3))
| "d" -> M (D 1) | "dbar" -> M (D (-1))
| "s" -> M (D 2) | "sbar" -> M (D (-2))
| "b" -> M (D 3) | "bbar" -> M (D (-3))
| "g" | "gl" -> G Gl
| "A" -> G Ga | "Z" | "Z0" -> G Z
| "W+" -> G Wp | "W-" -> G Wm
| "H" -> O H
| "phi+" -> O Phip
| "phi0" -> O Phi0
| "phi-" -> O Phim
| "Aux_t_ttGG0" -> O (Aux_top (2,1, 0,true,TTGG))
| "Aux_ttGG0" -> O (Aux_top (2,1, 0,false,TTGG))
| "Aux_t_tcGG0" -> O (Aux_top (2,1, 0,true,TCGG))
| "Aux_tcGG0" -> O (Aux_top (2,1, 0,false,TCGG))
| "Aux_t_tbWA+" -> O (Aux_top (2,0, 1,true,TBWA))
| "Aux_tbWA+" -> O (Aux_top (2,0, 1,false,TBWA))
| "Aux_t_tbWA-" -> O (Aux_top (2,0,-1,true,TBWA))
| "Aux_tbWA-" -> O (Aux_top (2,0,-1,false,TBWA))
| "Aux_t_tbWZ+" -> O (Aux_top (2,0, 1,true,TBWZ))
| "Aux_tbWZ+" -> O (Aux_top (2,0, 1,false,TBWZ))
| "Aux_t_tbWZ-" -> O (Aux_top (2,0,-1,true,TBWZ))
| "Aux_tbWZ-" -> O (Aux_top (2,0,-1,false,TBWZ))
| "Aux_t_ttWW0" -> O (Aux_top (2,0, 0,true,TTWW))
| "Aux_ttWW0" -> O (Aux_top (2,0, 0,false,TTWW))
| "Aux_t_bbWW0" -> O (Aux_top (2,0, 0,true,BBWW))
| "Aux_bbWW0" -> O (Aux_top (2,0, 0,false,BBWW))
| "Aux_t_qGuG0" -> O (Aux_top (1,1, 0,true,QGUG))
| "Aux_qGuG0" -> O (Aux_top (1,1, 0,false,QGUG))
| "Aux_t_qBuB0" -> O (Aux_top (1,0, 0,true,QBUB))
| "Aux_qBuB0" -> O (Aux_top (1,0, 0,false,QBUB))
| "Aux_t_qW0" -> O (Aux_top (1,0, 0,true,QW))
| "Aux_qW0" -> O (Aux_top (1,0, 0,false,QW))
| "Aux_t_qW+" -> O (Aux_top (1,0, 1,true,QW))
| "Aux_qW+" -> O (Aux_top (1,0, 1,false,QW))
| "Aux_t_qW-" -> O (Aux_top (1,0,-1,true,QW))
| "Aux_qW-" -> O (Aux_top (1,0,-1,false,QW))
| "Aux_t_dL0" -> O (Aux_top (0,0, 0,true,DL))
| "Aux_dL0" -> O (Aux_top (0,0, 0,false,DL))
| "Aux_t_dL+" -> O (Aux_top (0,0, 1,true,DL))
| "Aux_dL+" -> O (Aux_top (0,0, 1,false,DL))
| "Aux_t_dL-" -> O (Aux_top (0,0,-1,true,DL))
| "Aux_dL-" -> O (Aux_top (0,0,-1,false,DL))
| "Aux_t_dR0" -> O (Aux_top (0,0, 0,true,DR))
| "Aux_dR0" -> O (Aux_top (0,0, 0,false,DR))
| "Aux_t_dR+" -> O (Aux_top (0,0, 1,true,DR))
| "Aux_dR+" -> O (Aux_top (0,0, 1,false,DR))
| "Aux_t_dR-" -> O (Aux_top (0,0,-1,true,DR))
| "Aux_dR-" -> O (Aux_top (0,0,-1,false,DR))
| "Aux_t_quqd1L+" -> O (Aux_top (0,0, 1,true,QUQD1L))
| "Aux_quqd1L+" -> O (Aux_top (0,0, 1,false,QUQD1L))
| "Aux_t_quqd1L-" -> O (Aux_top (0,0,-1,true,QUQD1L))
| "Aux_quqd1L-" -> O (Aux_top (0,0,-1,false,QUQD1L))
| "Aux_t_quqd1R+" -> O (Aux_top (0,0, 1,true,QUQD1R))
| "Aux_quqd1R+" -> O (Aux_top (0,0, 1,false,QUQD1R))
| "Aux_t_quqd1R-" -> O (Aux_top (0,0,-1,true,QUQD1R))
| "Aux_quqd1R-" -> O (Aux_top (0,0,-1,false,QUQD1R))
| "Aux_t_quqd8L+" -> O (Aux_top (0,1, 1,true,QUQD8L))
| "Aux_quqd8L+" -> O (Aux_top (0,1, 1,false,QUQD8L))
| "Aux_t_quqd8L-" -> O (Aux_top (0,1,-1,true,QUQD8L))
| "Aux_quqd8L-" -> O (Aux_top (0,1,-1,false,QUQD8L))
| "Aux_t_quqd8R+" -> O (Aux_top (0,1, 1,true,QUQD8R))
| "Aux_quqd8R+" -> O (Aux_top (0,1, 1,false,QUQD8R))
| "Aux_t_quqd8R-" -> O (Aux_top (0,1,-1,true,QUQD8R))
| "Aux_quqd8R-" -> O (Aux_top (0,1,-1,false,QUQD8R))
| _ -> invalid_arg "Modellib.SM.flavor_of_string"
let flavor_to_string = function
| M f ->
begin match f with
| L 1 -> "e-" | L (-1) -> "e+"
| L 2 -> "mu-" | L (-2) -> "mu+"
| L 3 -> "tau-" | L (-3) -> "tau+"
| L _ -> invalid_arg
"Modellib.SM.flavor_to_string: invalid lepton"
| N 1 -> "nue" | N (-1) -> "nuebar"
| N 2 -> "numu" | N (-2) -> "numubar"
| N 3 -> "nutau" | N (-3) -> "nutaubar"
| N _ -> invalid_arg
"Modellib.SM.flavor_to_string: invalid neutrino"
| U 1 -> "u" | U (-1) -> "ubar"
| U 2 -> "c" | U (-2) -> "cbar"
| U 3 -> "t" | U (-3) -> "tbar"
| U _ -> invalid_arg
"Modellib.SM.flavor_to_string: invalid up type quark"
| D 1 -> "d" | D (-1) -> "dbar"
| D 2 -> "s" | D (-2) -> "sbar"
| D 3 -> "b" | D (-3) -> "bbar"
| D _ -> invalid_arg
"Modellib.SM.flavor_to_string: invalid down type quark"
end
| G f ->
begin match f with
| Gl -> "gl"
| Ga -> "A" | Z -> "Z"
| Wp -> "W+" | Wm -> "W-"
end
| O f ->
begin match f with
| Phip -> "phi+" | Phim -> "phi-" | Phi0 -> "phi0"
| H -> "H"
| Aux_top (_,_,ch,n,v) -> "Aux_" ^ (if n then "t_" else "") ^ (
begin match v with
| TTGG -> "ttGG" | TBWA -> "tbWA" | TBWZ -> "tbWZ"
| TTWW -> "ttWW" | BBWW -> "bbWW" | TCGG -> "tcgg" | TUGG -> "tugg"
| QGUG -> "qGuG" | QBUB -> "qBuB"
| QW -> "qW" | DL -> "dL" | DR -> "dR"
| QUQD1L -> "quqd1L" | QUQD1R -> "quqd1R"
| QUQD8L -> "quqd8L" | QUQD8R -> "quqd8R"
end ) ^ ( if ch > 0 then "+" else if ch < 0 then "-" else "0" )
end
let flavor_to_TeX = function
| M f ->
begin match f with
| L 1 -> "e^-" | L (-1) -> "e^+"
| L 2 -> "\\mu^-" | L (-2) -> "\\mu^+"
| L 3 -> "\\tau^-" | L (-3) -> "\\tau^+"
| L _ -> invalid_arg
"Modellib.SM.flavor_to_TeX: invalid lepton"
| N 1 -> "\\nu_e" | N (-1) -> "\\bar{\\nu}_e"
| N 2 -> "\\nu_\\mu" | N (-2) -> "\\bar{\\nu}_\\mu"
| N 3 -> "\\nu_\\tau" | N (-3) -> "\\bar{\\nu}_\\tau"
| N _ -> invalid_arg
"Modellib.SM.flavor_to_TeX: invalid neutrino"
| U 1 -> "u" | U (-1) -> "\\bar{u}"
| U 2 -> "c" | U (-2) -> "\\bar{c}"
| U 3 -> "t" | U (-3) -> "\\bar{t}"
| U _ -> invalid_arg
"Modellib.SM.flavor_to_TeX: invalid up type quark"
| D 1 -> "d" | D (-1) -> "\\bar{d}"
| D 2 -> "s" | D (-2) -> "\\bar{s}"
| D 3 -> "b" | D (-3) -> "\\bar{b}"
| D _ -> invalid_arg
"Modellib.SM.flavor_to_TeX: invalid down type quark"
end
| G f ->
begin match f with
| Gl -> "g"
| Ga -> "\\gamma" | Z -> "Z"
| Wp -> "W^+" | Wm -> "W^-"
end
| O f ->
begin match f with
| Phip -> "\\phi^+" | Phim -> "\\phi^-" | Phi0 -> "\\phi^0"
| H -> "H"
| Aux_top (_,_,ch,n,v) ->
"\\textnormal{Aux_" ^ (if n then "t_" else "") ^ (
begin match v with
| TTGG -> "ttGG" | TBWA -> "tbWA" | TBWZ -> "tbWZ"
| TTWW -> "ttWW" | BBWW -> "bbWW" | TCGG -> "tcgg" | TUGG -> "tugg"
| QGUG -> "qGuG" | QBUB -> "qBuB"
| QW -> "qW" | DL -> "dL" | DR -> "dR"
| QUQD1L -> "quqd1L" | QUQD1R -> "quqd1R"
| QUQD8L -> "quqd8L" | QUQD8R -> "quqd8R"
end ) ^
( if ch > 0 then "^+" else if ch < 0 then
"^-" else "^0" ) ^ "}"
end
let flavor_symbol = function
| M f ->
begin match f with
| L n when n > 0 -> "l" ^ string_of_int n
| L n -> "l" ^ string_of_int (abs n) ^ "b"
| N n when n > 0 -> "n" ^ string_of_int n
| N n -> "n" ^ string_of_int (abs n) ^ "b"
| U n when n > 0 -> "u" ^ string_of_int n
| U n -> "u" ^ string_of_int (abs n) ^ "b"
| D n when n > 0 -> "d" ^ string_of_int n
| D n -> "d" ^ string_of_int (abs n) ^ "b"
end
| G f ->
begin match f with
| Gl -> "gl"
| Ga -> "a" | Z -> "z"
| Wp -> "wp" | Wm -> "wm"
end
| O f ->
begin match f with
| Phip -> "pp" | Phim -> "pm" | Phi0 -> "p0"
| H -> "h"
| Aux_top (_,_,ch,n,v) -> "aux_" ^ (if n then "t_" else "") ^ (
begin match v with
| TTGG -> "ttgg" | TBWA -> "tbwa" | TBWZ -> "tbwz"
| TTWW -> "ttww" | BBWW -> "bbww" | TCGG -> "tcgg" | TUGG -> "tugg"
| QGUG -> "qgug" | QBUB -> "qbub"
| QW -> "qw" | DL -> "dl" | DR -> "dr"
| QUQD1L -> "quqd1l" | QUQD1R -> "quqd1r"
| QUQD8L -> "quqd8l" | QUQD8R -> "quqd8r"
end ) ^ "_" ^ ( if ch > 0 then "p" else
if ch < 0 then "m" else "0" )
end
let pdg = function
| M f ->
begin match f with
| L n when n > 0 -> 9 + 2*n
| L n -> - 9 + 2*n
| N n when n > 0 -> 10 + 2*n
| N n -> - 10 + 2*n
| U n when n > 0 -> 2*n
| U n -> 2*n
| D n when n > 0 -> - 1 + 2*n
| D n -> 1 + 2*n
end
| G f ->
begin match f with
| Gl -> 21
| Ga -> 22 | Z -> 23
| Wp -> 24 | Wm -> (-24)
end
| O f ->
begin match f with
| Phip | Phim -> 27 | Phi0 -> 26
| H -> 25
| Aux_top (_,_,ch,t,f) -> let n =
begin match f with
| QW -> 0
| QUQD1R -> 1 | QUQD1L -> 2
| QUQD8R -> 3 | QUQD8L -> 4
| _ -> 5
end
in (602 + 3*n - ch) * ( if t then (1) else (-1) )
end
let mass_symbol f =
if ( Flags.tt_threshold && (abs (pdg f)) == 6 ) then
"ttv_mtpole(p12*p12)"
else
"mass(" ^ string_of_int (abs (pdg f)) ^ ")"
let width_symbol f =
"width(" ^ string_of_int (abs (pdg f)) ^ ")"
let constant_symbol = function
| Unit -> "unit" | Half -> "half" | Pi -> "PI"
| Alpha_QED -> "alpha" | E -> "e" | G_weak -> "g" | Vev -> "vev"
| I_G_weak -> "ig"
| Sin2thw -> "sin2thw" | Sinthw -> "sinthw" | Costhw -> "costhw"
| Q_lepton -> "qlep" | Q_up -> "qup" | Q_down -> "qdwn"
| G_NC_lepton -> "gnclep" | G_NC_neutrino -> "gncneu"
| G_NC_up -> "gncup" | G_NC_down -> "gncdwn"
| G_TVA_ttA -> "gtva_tta" | G_TVA_bbA -> "gtva_bba"
| G_VLR_ttZ -> "gvlr_ttz" | G_TVA_ttZ -> "gtva_ttz"
| G_VLR_tcZ -> "gvlr_tcz" | G_TVA_tcZ -> "gtva_tcz"
| G_VLR_tuZ -> "gvlr_tuz" | G_TVA_tuZ -> "gtva_tuz"
| G_TVA_bbZ -> "gtva_bbz" | G_TVA_tcA -> "gtva_tca"
| G_TVA_tuA -> "gtva_tua"
| VA_ILC_ttA -> "va_ilc_tta" | VA_ILC_ttZ -> "va_ilc_ttz"
| G_VLR_btW -> "gvlr_btw" | G_VLR_tbW -> "gvlr_tbw"
| G_TLR_btW -> "gtlr_btw" | G_TRL_tbW -> "gtrl_tbw"
| G_TLR_btWA -> "gtlr_btwa" | G_TRL_tbWA -> "gtrl_tbwa"
| G_TLR_btWZ -> "gtlr_btwz" | G_TRL_tbWZ -> "gtrl_tbwz"
| G_TVA_ttWW -> "gtva_ttww" | G_TVA_bbWW -> "gtva_bbww"
| G_TVA_ttG -> "gtva_ttg" | G_TVA_ttGG -> "gtva_ttgg"
| G_TVA_tcG -> "gtva_tcg" | G_TVA_tcGG -> "gtva_tcgg"
| G_TVA_tuG -> "gtva_tug" | G_TVA_tuGG -> "gtva_tugg"
| G_SP_ttH -> "gsp_tth"
| G_VLR_qGuG -> "gvlr_qgug"
| G_VLR_qBuB -> "gvlr_qbub"
| G_VLR_qBuB_u -> "gvlr_qbub_u" | G_VLR_qBuB_d -> "gvlr_qbub_d"
| G_VLR_qBuB_e -> "gvlr_qbub_e" | G_VL_qBuB_n -> "gvl_qbub_n"
| G_VL_qW -> "gvl_qw"
| G_VL_qW_u -> "gvl_qw_u" | G_VL_qW_d -> "gvl_qw_d"
| G_SL_DttR -> "gsl_dttr" | G_SR_DttR -> "gsr_dttr"
| G_SL_DttL -> "gsl_dttl"
| G_SLR_DbtR -> "gslr_dbtr" | G_SL_DbtL -> "gsl_dbtl"
| C_quqd1R_bt -> "c_quqd1_1" | C_quqd1R_tb -> "conjg(c_quqd1_1)"
| C_quqd1L_bt -> "conjg(c_quqd1_2)" | C_quqd1L_tb -> "c_quqd1_2"
| C_quqd8R_bt -> "c_quqd8_1" | C_quqd8R_tb -> "conjg(c_quqd8_1)"
| C_quqd8L_bt -> "conjg(c_quqd8_2)" | C_quqd8L_tb -> "c_quqd8_2"
| G_CC -> "gcc"
| G_CCQ (n1,n2) -> "gccq" ^ string_of_int n1 ^ string_of_int n2
| I_Q_W -> "iqw" | I_G_ZWW -> "igzww"
| G_WWWW -> "gw4" | G_ZZWW -> "gzzww"
| G_AZWW -> "gazww" | G_AAWW -> "gaaww"
| I_G1_AWW -> "ig1a" | I_G1_ZWW -> "ig1z"
| I_G1_plus_kappa_plus_G4_AWW -> "ig1pkpg4a"
| I_G1_plus_kappa_plus_G4_ZWW -> "ig1pkpg4z"
| I_G1_plus_kappa_minus_G4_AWW -> "ig1pkmg4a"
| I_G1_plus_kappa_minus_G4_ZWW -> "ig1pkmg4z"
| I_G1_minus_kappa_plus_G4_AWW -> "ig1mkpg4a"
| I_G1_minus_kappa_plus_G4_ZWW -> "ig1mkpg4z"
| I_G1_minus_kappa_minus_G4_AWW -> "ig1mkmg4a"
| I_G1_minus_kappa_minus_G4_ZWW -> "ig1mkmg4z"
| I_lambda_AWW -> "ila"
| I_lambda_ZWW -> "ilz"
| G5_AWW -> "rg5a"
| G5_ZWW -> "rg5z"
| I_kappa5_AWW -> "ik5a"
| I_kappa5_ZWW -> "ik5z"
| I_lambda5_AWW -> "il5a" | I_lambda5_ZWW -> "il5z"
| Alpha_WWWW0 -> "alww0" | Alpha_WWWW2 -> "alww2"
| Alpha_ZZWW0 -> "alzw0" | Alpha_ZZWW1 -> "alzw1"
| Alpha_ZZZZ -> "alzz"
| D_Alpha_ZZWW0_S -> "dalzz0_s(gkm,mkm,"
| D_Alpha_ZZWW0_T -> "dalzz0_t(gkm,mkm,"
| D_Alpha_ZZWW1_S -> "dalzz1_s(gkm,mkm,"
| D_Alpha_ZZWW1_T -> "dalzz1_t(gkm,mkm,"
| D_Alpha_ZZWW1_U -> "dalzz1_u(gkm,mkm,"
| D_Alpha_WWWW0_S -> "dalww0_s(gkm,mkm,"
| D_Alpha_WWWW0_T -> "dalww0_t(gkm,mkm,"
| D_Alpha_WWWW0_U -> "dalww0_u(gkm,mkm,"
| D_Alpha_WWWW2_S -> "dalww2_s(gkm,mkm,"
| D_Alpha_WWWW2_T -> "dalww2_t(gkm,mkm,"
| D_Alpha_ZZZZ_S -> "dalz4_s(gkm,mkm,"
| D_Alpha_ZZZZ_T -> "dalz4_t(gkm,mkm,"
| G_HWW -> "ghww" | G_HZZ -> "ghzz"
| G_HHWW -> "ghhww" | G_HHZZ -> "ghhzz"
| G_Htt -> "ghtt" | G_Hbb -> "ghbb"
| G_Hss -> "ghss" | G_Hee -> "ghee"
| G_Htautau -> "ghtautau" | G_Hcc -> "ghcc" | G_Hmm -> "ghmm"
| G_HGaZ -> "ghgaz" | G_HGaGa -> "ghgaga" | G_Hgg -> "ghgg"
| G_HGaGa_anom -> "ghgaga_ac" | G_HGaZ_anom -> "ghgaz_ac"
| G_HZZ_anom -> "ghzz_ac" | G_HWW_anom -> "ghww_ac"
| G_HGaZ_u -> "ghgaz_u" | G_HZZ_u -> "ghzz_u"
| G_HWW_u -> "ghww_u"
| G_H3 -> "gh3" | G_H4 -> "gh4"
| Gs -> "gs" | I_Gs -> "igs" | G2 -> "gs**2"
| Mass f -> "mass" ^ flavor_symbol f
| Width f -> "width" ^ flavor_symbol f
| K_Matrix_Coeff i -> "kc" ^ string_of_int i
| K_Matrix_Pole i -> "kp" ^ string_of_int i
| G_HZZ6_V3 -> "ghzz6v3" | G_HZZ6_D ->"ghzz6d"
| G_HZZ6_DP ->"ghzz6dp" | G_HZZ6_PB ->"ghzz6pb"
| G_HGaZ6_D -> "ghaz6d" | G_HGaZ6_DP -> "ghaz6dp"
| G_HGaZ6_PB -> "ghaz6pb" | G_HGaGa6 -> "ghgaga6"
| G_HWW_6_D -> "ghww6d" | G_HWW_6_DP ->"ghww6dp"
| I_Dim6_AWW_Gauge -> "dim6awwgauge" | I_Dim6_AWW_GGG -> "dim6awwggg"
| I_Dim6_AWW_DP -> "dim6awwdp" | I_Dim6_AWW_DW -> "dim6awwdw"
| I_Dim6_WWZ_W -> "dim6wwzw" | I_Dim6_WWZ_DPWDW -> "dim6wwzdpwdw"
| I_Dim6_WWZ_DW -> "dim6wwzdw" | I_Dim6_WWZ_D -> "dim6wwzd"
| Dim6_vev3 -> "dim6vev3" | Dim6_Cphi -> "dim6cphi"
(*i | I_Dim6_GGG_G -> "dim6gggg" | I_Dim6_GGG_CG -> "dim6gggcg" i*)
| Anom_Dim6_H4_v2 -> "adim6h4v2" | Anom_Dim6_H4_P2 -> "adim6h4p2"
| Anom_Dim6_AHWW_DPB -> "adim6ahwwdpb"
| Anom_Dim6_AHWW_DPW -> "adim6ahwwdpw"
| Anom_Dim6_AHWW_DW -> "adim6ahwwdw"
| Anom_Dim6_AAWW_DW -> "adim6aawwdw" | Anom_Dim6_AAWW_W -> "adim6aawww"
| Anom_Dim6_HHWW_DW -> "adim6hhwwdw"
| Anom_Dim6_HHWW_DPW -> "adim6hhwwdpw"
| Anom_Dim6_HWWZ_DW -> "adim6hwwzdw"
| Anom_Dim6_HWWZ_DDPW -> "adim6hwwzddpw"
| Anom_Dim6_HWWZ_DPW -> "adim6hwwzdpw"
| Anom_Dim6_HWWZ_DPB -> "adim6hwwzdpb"
| Anom_Dim6_AHHZ_D -> "adim6ahhzd" | Anom_Dim6_AHHZ_DP -> "adim6ahhzdp"
| Anom_Dim6_AHHZ_PB -> "adim6ahhzpb"
| Anom_Dim6_AZWW_W -> "adim6azwww"
| Anom_Dim6_AZWW_DWDPW -> "adim6azwwdwdpw"
| Anom_Dim6_WWWW_W -> "adim6wwwww"
| Anom_Dim6_WWWW_DWDPW -> "adim6wwwwdwdpw"
| Anom_Dim6_WWZZ_W -> "adim6wwzzw"
| Anom_Dim6_WWZZ_DWDPW -> "adim6wwzzdwdpw"
| Anom_Dim6_HHAA -> "adim6hhaa"
| Anom_Dim6_HHZZ_D -> "adim6hhzzd" | Anom_Dim6_HHZZ_DP -> "adim6hhzzdp"
| Anom_Dim6_HHZZ_PB -> "adim6hhzzpb" | Anom_Dim6_HHZZ_T -> "adim6hhzzt"
end
(* \thocwmodulesection{Incomplete Standard Model in $R_\xi$ Gauge} *)
(* \begin{dubious}
At the end of the day, we want a functor mapping from gauge models
in unitarity gauge to $R_\xi$ gauge and vice versa. For this, we
will need a more abstract implementation of (spontaneously broken)
gauge theories.
\end{dubious} *)
module SM_Rxi =
struct
open Coupling
module SM = SM(SM_no_anomalous)
let options = SM.options
let caveats = SM.caveats
type flavor = SM.flavor
let flavors = SM.flavors
let external_flavors = SM.external_flavors
- (* Later: [type orders = SM.orders] *)
type constant = SM.constant
- (* Later: [let orders = SM.orders] *)
+ type coupling_order = SM.coupling_order
+ let all_coupling_orders = SM.all_coupling_orders
+ let coupling_orders = SM.coupling_orders
+ let coupling_order_to_string = SM.coupling_order_to_string
let lorentz = SM.lorentz
let color = SM.color
let nc = SM.nc
let goldstone = SM.goldstone
let conjugate = SM.conjugate
let fermion = SM.fermion
(* \begin{dubious}
Check if it makes sense to have separate gauge fixing parameters
for each vector boson. There's probably only one independent
parameter for each group factor.
\end{dubious} *)
type gauge =
| XiA | XiZ | XiW
let gauge_symbol = function
| XiA -> "xia" | XiZ -> "xi0" | XiW -> "xipm"
(* Change the gauge boson propagators and make the Goldstone bosons
propagating. *)
let propagator = function
| SM.G SM.Ga -> Prop_Gauge XiA
| SM.G SM.Z -> Prop_Rxi XiZ
| SM.G SM.Wp | SM.G SM.Wm -> Prop_Rxi XiW
| SM.O SM.Phip | SM.O SM.Phim | SM.O SM.Phi0 -> Prop_Scalar
| f -> SM.propagator f
let width = SM.width
module Ch = Charges.QQ
let charges = SM.charges
module F = Modeltools.Fusions (struct
type f = flavor
type c = constant
let compare = compare
let conjugate = conjugate
end)
let vertices = SM.vertices
let table = F.of_vertices (vertices ())
let fuse2 = F.fuse2 table
let fuse3 = F.fuse3 table
let fuse = F.fuse table
let max_degree () = 3
let parameters = SM.parameters
let flavor_of_string = SM.flavor_of_string
let flavor_to_string = SM.flavor_to_string
let flavor_to_TeX = SM.flavor_to_TeX
let flavor_symbol = SM.flavor_symbol
let pdg = SM.pdg
let mass_symbol = SM.mass_symbol
let width_symbol = SM.width_symbol
let constant_symbol = SM.constant_symbol
end
(* \thocwmodulesection{Groves} *)
module Groves (M : Model.Gauge) : Model.Gauge with module Ch = M.Ch =
struct
let max_generations = 5
let options = M.options
let caveats = M.caveats
type matter_field = M.matter_field * int
type gauge_boson = M.gauge_boson
type other = M.other
type field =
| Matter of matter_field
| Gauge of gauge_boson
| Other of other
type flavor = M of matter_field | G of gauge_boson | O of other
let matter_field (f, g) = M (f, g)
let gauge_boson f = G f
let other f = O f
let field = function
| M f -> Matter f
| G f -> Gauge f
| O f -> Other f
let project = function
| M (f, _) -> M.matter_field f
| G f -> M.gauge_boson f
| O f -> M.other f
let inject g f =
match M.field f with
| M.Matter f -> M (f, g)
| M.Gauge f -> G f
| M.Other f -> O f
type gauge = M.gauge
let gauge_symbol = M.gauge_symbol
let color f = M.color (project f)
let nc () = 3
let pdg f = M.pdg (project f)
let lorentz f = M.lorentz (project f)
let propagator f = M.propagator (project f)
let fermion f = M.fermion (project f)
let width f = M.width (project f)
let mass_symbol f = M.mass_symbol (project f)
let width_symbol f = M.width_symbol (project f)
let flavor_symbol f = M.flavor_symbol (project f)
type constant = M.constant
- (* Later: [type orders = M.orders] *)
+ type coupling_order = M.coupling_order
+ let all_coupling_orders = M.all_coupling_orders
+ let coupling_orders = M.coupling_orders
let constant_symbol = M.constant_symbol
let max_degree = M.max_degree
let parameters = M.parameters
- (* Later: [let orders = M.orders] *)
+ let coupling_orders = M.coupling_orders
+ let coupling_order_to_string = M.coupling_order_to_string
let conjugate = function
| M (_, g) as f -> inject g (M.conjugate (project f))
| f -> inject 0 (M.conjugate (project f))
let read_generation s =
try
let offset = String.index s '/' in
(int_of_string
(String.sub s (succ offset) (String.length s - offset - 1)),
String.sub s 0 offset)
with
| Not_found -> (1, s)
let format_generation c s =
s ^ "/" ^ string_of_int c
let flavor_of_string s =
let g, s = read_generation s in
inject g (M.flavor_of_string s)
let flavor_to_string = function
| M (_, g) as f -> format_generation g (M.flavor_to_string (project f))
| f -> M.flavor_to_string (project f)
let flavor_to_TeX = function
| M (_, g) as f -> format_generation g (M.flavor_to_TeX (project f))
| f -> M.flavor_to_TeX (project f)
let goldstone = function
| G _ as f ->
begin match M.goldstone (project f) with
| None -> None
| Some (f, c) -> Some (inject 0 f, c)
end
| M _ | O _ -> None
let clone generations flavor =
match M.field flavor with
| M.Matter f -> List.map (fun g -> M (f, g)) generations
| M.Gauge f -> [G f]
| M.Other f -> [O f]
let generations = ThoList.range 1 max_generations
let flavors () =
ThoList.flatmap (clone generations) (M.flavors ())
let external_flavors () =
List.map (fun (s, fl) -> (s, ThoList.flatmap (clone generations) fl))
(M.external_flavors ())
module Ch = M.Ch
let charges f = M.charges (project f)
module F = Modeltools.Fusions (struct
type f = flavor
type c = constant
let compare = compare
let conjugate = conjugate
end)
(* In the following functions, we might replace [_] by [(M.Gauge _ | M.Other _)],
in order to allow the compiler to check completeness. However, this
makes the code much less readable. *)
let clone3 ((f1, f2, f3), v, c) =
match M.field f1, M.field f2, M.field f3 with
| M.Matter _, M.Matter _, M.Matter _ ->
invalid_arg "Modellib.Groves().vertices: three matter fields!"
| M.Matter f1', M.Matter f2', _ ->
List.map (fun g -> ((M (f1', g), M (f2', g), inject 0 f3), v, c))
generations
| M.Matter f1', _, M.Matter f3' ->
List.map (fun g -> ((M (f1', g), inject 0 f2, M (f3', g)), v, c))
generations
| _, M.Matter f2', M.Matter f3' ->
List.map (fun g -> ((inject 0 f1, M (f2', g), M (f3', g)), v, c))
generations
| M.Matter _, _, _ | _, M.Matter _, _ | _, _, M.Matter _ ->
invalid_arg "Modellib.Groves().vertices: lone matter field!"
| _, _, _ ->
[(inject 0 f1, inject 0 f2, inject 0 f3), v, c]
let clone4 ((f1, f2, f3, f4), v, c) =
match M.field f1, M.field f2, M.field f3, M.field f4 with
| M.Matter _, M.Matter _, M.Matter _, M.Matter _ ->
invalid_arg "Modellib.Groves().vertices: four matter fields!"
| M.Matter _, M.Matter _, M.Matter _, _
| M.Matter _, M.Matter _, _, M.Matter _
| M.Matter _, _, M.Matter _, M.Matter _
| _, M.Matter _, M.Matter _, M.Matter _ ->
invalid_arg "Modellib.Groves().vertices: three matter fields!"
| M.Matter f1', M.Matter f2', _, _ ->
List.map (fun g ->
((M (f1', g), M (f2', g), inject 0 f3, inject 0 f4), v, c))
generations
| M.Matter f1', _, M.Matter f3', _ ->
List.map (fun g ->
((M (f1', g), inject 0 f2, M (f3', g), inject 0 f4), v, c))
generations
| M.Matter f1', _, _, M.Matter f4' ->
List.map (fun g ->
((M (f1', g), inject 0 f2, inject 0 f3, M (f4', g)), v, c))
generations
| _, M.Matter f2', M.Matter f3', _ ->
List.map (fun g ->
((inject 0 f1, M (f2', g), M (f3', g), inject 0 f4), v, c))
generations
| _, M.Matter f2', _, M.Matter f4' ->
List.map (fun g ->
((inject 0 f1, M (f2', g), inject 0 f3, M (f4', g)), v, c))
generations
| _, _, M.Matter f3', M.Matter f4' ->
List.map (fun g ->
((inject 0 f1, inject 0 f2, M (f3', g), M (f4', g)), v, c))
generations
| M.Matter _, _, _, _ | _, M.Matter _, _, _
| _, _, M.Matter _, _ | _, _, _, M.Matter _ ->
invalid_arg "Modellib.Groves().vertices: lone matter field!"
| _, _, _, _ ->
[(inject 0 f1, inject 0 f2, inject 0 f3, inject 0 f4), v, c]
let clonen (fl, v, c) =
match List.map M.field fl with
| _ -> failwith "Modellib.Groves().vertices: incomplete"
let vertices () =
let vertices3, vertices4, verticesn = M.vertices () in
(ThoList.flatmap clone3 vertices3,
ThoList.flatmap clone4 vertices4,
ThoList.flatmap clonen verticesn)
let table = F.of_vertices (vertices ())
let fuse2 = F.fuse2 table
let fuse3 = F.fuse3 table
let fuse = F.fuse table
(* \begin{dubious}
The following (incomplete) alternative implementations are
included for illustrative purposes only:
\end{dubious} *)
let injectl g fcl =
List.map (fun (f, c) -> (inject g f, c)) fcl
let alt_fuse2 f1 f2 =
match f1, f2 with
| M (f1', g1'), M (f2', g2') ->
if g1' = g2' then
injectl 0 (M.fuse2 (M.matter_field f1') (M.matter_field f2'))
else
[]
| M (f1', g'), _ -> injectl g' (M.fuse2 (M.matter_field f1') (project f2))
| _, M (f2', g') -> injectl g' (M.fuse2 (project f1) (M.matter_field f2'))
| _, _ -> injectl 0 (M.fuse2 (project f1) (project f2))
let alt_fuse3 f1 f2 f3 =
match f1, f2, f3 with
| M (f1', g1'), M (f2', g2'), M (f3', g3') ->
invalid_arg "Modellib.Groves().fuse3: three matter fields!"
| M (f1', g1'), M (f2', g2'), _ ->
if g1' = g2' then
injectl 0
(M.fuse3 (M.matter_field f1') (M.matter_field f2') (project f3))
else
[]
| M (f1', g1'), _, M (f3', g3') ->
if g1' = g3' then
injectl 0
(M.fuse3 (M.matter_field f1') (project f2) (M.matter_field f3'))
else
[]
| _, M (f2', g2'), M (f3', g3') ->
if g2' = g3' then
injectl 0
(M.fuse3 (project f1) (M.matter_field f2') (M.matter_field f3'))
else
[]
| M (f1', g'), _, _ ->
injectl g' (M.fuse3 (M.matter_field f1') (project f2) (project f3))
| _, M (f2', g'), _ ->
injectl g' (M.fuse3 (project f1) (M.matter_field f2') (project f3))
| _, _, M (f3', g') ->
injectl g' (M.fuse3 (project f1) (project f2) (M.matter_field f3'))
| _, _, _ -> injectl 0 (M.fuse3 (project f1) (project f2) (project f3))
end
(* \thocwmodulesection{MSM With Cloned Families} *)
module SM_clones = Groves(SM(SM_no_anomalous))
Index: trunk/omega/src/UFOx_lexer.mll
===================================================================
--- trunk/omega/src/UFOx_lexer.mll (revision 8899)
+++ trunk/omega/src/UFOx_lexer.mll (revision 8900)
@@ -1,76 +1,78 @@
(* vertex_lexer.mll --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
{
open Lexing
open UFOx_parser
let string_of_char c =
String.make 1 c
let init_position fname lexbuf =
let curr_p = lexbuf.lex_curr_p in
lexbuf.lex_curr_p <-
{ curr_p with
pos_fname = fname;
pos_lnum = 1;
pos_bol = curr_p.pos_cnum };
lexbuf
}
let digit = ['0'-'9']
let upper = ['A'-'Z']
let lower = ['a'-'z']
let char = upper | lower
let word = char | digit | '_'
let white = [' ' '\t' '\n']
rule token = parse
white { token lexbuf } (* skip blanks *)
| '(' { LPAREN }
| ')' { RPAREN }
+ | '[' { LBRACKET }
+ | ']' { RBRACKET }
| ',' { COMMA }
| '*' '*' { POWER }
| '*' { TIMES }
| '/' { DIV }
| '+' { PLUS }
| '-' { MINUS }
| ( digit+ as i ) ( '.' '0'* )?
{ INT (int_of_string i) }
| ( digit | digit* '.' digit+
| digit+ '.' digit* ) ( ['E''e'] '-'? digit+ )? as x
{ FLOAT (float_of_string x) }
| '\'' (char word* as s) '\''
{ QUOTED s }
| char word* ('.' char word+ )? as s
{ ID s }
| '\\' '[' (word+ as stem) ']' (word* as suffix)
{ ID (UFO_tools.mathematica_symbol stem suffix) }
| _ as c { raise (UFO_tools.Lexical_Error
("invalid character `" ^ string_of_char c ^ "'",
lexbuf.lex_start_p, lexbuf.lex_curr_p)) }
| eof { END }
Index: trunk/omega/src/modellib_WZW.ml
===================================================================
--- trunk/omega/src/modellib_WZW.ml (revision 8899)
+++ trunk/omega/src/modellib_WZW.ml (revision 8900)
@@ -1,631 +1,635 @@
(* modellib_WZW.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
(* \thocwmodulesection{SM with WZW-type pseudoscalars} *)
module type SM_flags =
sig
val include_anomalous : bool
val k_matrix : bool
end
module SM_no_anomalous : SM_flags =
struct
let include_anomalous = false
let k_matrix = false
end
module WZW (Flags : SM_flags) =
struct
open Coupling
let default_width = ref Timelike
let use_fudged_width = ref false
let options = Options.create
[ "constant_width", Arg.Unit (fun () -> default_width := Constant),
"use constant width (also in t-channel)";
"fudged_width", Arg.Set use_fudged_width,
"use fudge factor for charge particle width";
"custom_width", Arg.String (fun f -> default_width := Custom f),
"use custom width";
"cancel_widths", Arg.Unit (fun () -> default_width := Vanishing),
"use vanishing width";
"cms_width", Arg.Unit (fun () -> default_width := Complex_Mass),
"use complex mass scheme";
"running_width", Arg.Unit (fun () -> default_width := Running),
"use running width"]
let caveats () = []
(* We do not introduce the Goldstones for the heavy vectors here. *)
type matter_field = L of int | N of int | U of int | D of int
type gauge_boson = Ga | Wp | Wm | Z | Gl
type other = Phip | Phim | Phi0 | H | Psi0 | Eta
type flavor = M of matter_field | G of gauge_boson | O of other
let matter_field f = M f
let gauge_boson f = G f
let other f = O f
type field =
| Matter of matter_field
| Gauge of gauge_boson
| Other of other
let field = function
| M f -> Matter f
| G f -> Gauge f
| O f -> Other f
type gauge = unit
let gauge_symbol () =
failwith "Models.WZW.gauge_symbol: internal error"
let family n = List.map matter_field [ L n; N n; U n; D n ]
let external_flavors () =
[ "1st Generation", ThoList.flatmap family [1; -1];
"2nd Generation", ThoList.flatmap family [2; -2];
"3rd Generation", ThoList.flatmap family [3; -3];
"Gauge Bosons", List.map gauge_boson [Ga; Z; Wp; Wm; Gl];
"Higgs", [O H; O Psi0; O Eta];
"Goldstone Bosons", List.map other [Phip; Phim; Phi0] ]
let flavors () = ThoList.flatmap snd (external_flavors ())
let spinor n =
if n >= 0 then
Spinor
else
ConjSpinor
let lorentz = function
| M f ->
begin match f with
| L n -> spinor n | N n -> spinor n
| U n -> spinor n | D n -> spinor n
end
| G f ->
begin match f with
| Ga | Gl -> Vector
| Wp | Wm | Z -> Massive_Vector
end
| O f ->
Scalar
let color = function
| M (U n) -> Color.SUN (if n > 0 then 3 else -3)
| M (D n) -> Color.SUN (if n > 0 then 3 else -3)
| G Gl -> Color.AdjSUN 3
| _ -> Color.Singlet
let nc () = 3
let prop_spinor n =
if n >= 0 then
Prop_Spinor
else
Prop_ConjSpinor
let propagator = function
| M f ->
begin match f with
| L n -> prop_spinor n | N n -> prop_spinor n
| U n -> prop_spinor n | D n -> prop_spinor n
end
| G f ->
begin match f with
| Ga | Gl -> Prop_Feynman
| Wp | Wm | Z -> Prop_Unitarity
end
| O f ->
begin match f with
| Phip | Phim | Phi0 -> Only_Insertion
| H | Psi0 | Eta -> Prop_Scalar
end
(* Optionally, ask for the fudge factor treatment for the widths of
charged particles. Currently, this only applies to $W^\pm$ and top. *)
let width f =
if !use_fudged_width then
match f with
| G Wp | G Wm | M (U 3) | M (U (-3))
| _ -> !default_width
else
!default_width
let goldstone = function
| G f ->
begin match f with
| Wp -> Some (O Phip, Coupling.Integer 1)
| Wm -> Some (O Phim, Coupling.Integer 1)
| Z -> Some (O Phi0, Coupling.Integer 1)
| _ -> None
end
| _ -> None
let conjugate = function
| M f ->
M (begin match f with
| L n -> L (-n) | N n -> N (-n)
| U n -> U (-n) | D n -> D (-n)
end)
| G f ->
G (begin match f with
| Gl -> Gl | Ga -> Ga | Z -> Z
| Wp -> Wm | Wm -> Wp
end)
| O f ->
O (begin match f with
| Phip -> Phim | Phim -> Phip | Phi0 -> Phi0
| H -> H | Psi0 -> Psi0 | Eta -> Eta
end)
let fermion = function
| M f ->
begin match f with
| L n -> if n > 0 then 1 else -1
| N n -> if n > 0 then 1 else -1
| U n -> if n > 0 then 1 else -1
| D n -> if n > 0 then 1 else -1
end
| G f ->
begin match f with
| Gl | Ga | Z | Wp | Wm -> 0
end
| O _ -> 0
(* Electrical charge, lepton number, baryon number. We could avoid the
rationals altogether by multiplying the first and last by 3 \ldots *)
module Ch = Charges.QQ
let ( // ) = Algebra.Small_Rational.make
let generation' = function
| 1 -> [ 1//1; 0//1; 0//1]
| 2 -> [ 0//1; 1//1; 0//1]
| 3 -> [ 0//1; 0//1; 1//1]
| -1 -> [-1//1; 0//1; 0//1]
| -2 -> [ 0//1; -1//1; 0//1]
| -3 -> [ 0//1; 0//1; -1//1]
| n -> invalid_arg ("WZW.generation': " ^ string_of_int n)
let generation f =
match f with
| M (L n | N n | U n | D n) -> generation' n
| G _ | O _ -> [0//1; 0//1; 0//1]
let charge = function
| M f ->
begin match f with
| L n -> if n > 0 then -1//1 else 1//1
| N n -> 0//1
| U n -> if n > 0 then 2//3 else -2//3
| D n -> if n > 0 then -1//3 else 1//3
end
| G f ->
begin match f with
| Gl | Ga | Z -> 0//1
| Wp -> 1//1
| Wm -> -1//1
end
| O f ->
begin match f with
| H | Phi0 | Psi0 | Eta -> 0//1
| Phip -> 1//1
| Phim -> -1//1
end
let lepton = function
| M f ->
begin match f with
| L n | N n -> if n > 0 then 1//1 else -1//1
| U _ | D _ -> 0//1
end
| G _ | O _ -> 0//1
let baryon = function
| M f ->
begin match f with
| L _ | N _ -> 0//1
| U n | D n -> if n > 0 then 1//1 else -1//1
end
| G _ | O _ -> 0//1
let charges f =
[ charge f; lepton f; baryon f] @ generation f
type constant =
| Unit | Pi | Alpha_QED | Sin2thw
| Sinthw | Costhw | E | G_weak | Vev
| Q_lepton | Q_up | Q_down | G_CC
| G_NC_neutrino | G_NC_lepton | G_NC_up | G_NC_down
| G_NC_h_neutrino | G_NC_h_lepton | G_NC_h_up | G_NC_h_down
| I_Q_W | I_G_ZWW | I_G_WWW
| G_WWWW | G_ZZWW | G_AZWW | G_AAWW
| G_HWW | G_HHWW | G_HZZ | G_HHZZ | G_EtaGG | G_EtaWW
| G_PsiWW | G_PsiZZ | G_PsiAA | G_PsiAZ | G_PsiGG
| G_EtaZZ | G_EtaAZ | G_EtaAA
| G_Htt | G_Hbb | G_Hcc | G_Htautau | G_H3 | G_H4
| Gs | I_Gs | G2
| Mass of flavor | Width of flavor
(* Two integer counters for the QCD and EW order of the couplings. *)
- type orders = int * int
+ type coupling_order = QCD | EW
+ let all_coupling_orders () = [QCD; EW]
+ let coupling_order_to_string = function
+ | QCD -> "QCD"
+ | EW -> "EW"
- let orders = function
- | _ -> (0,0)
+ let coupling_orders = function
+ | _ -> failwith "Modellib_WZW.WZW.orders: not implemented yet!"
let input_parameters =
[]
let derived_parameters =
[]
let g_over_2_costh =
Quot (Neg (Atom G_weak), Prod [Integer 2; Atom Costhw])
let nc_coupling c t3 q =
(Real_Array c,
[Prod [g_over_2_costh; Diff (t3, Prod [Integer 2; q; Atom Sin2thw])];
Prod [g_over_2_costh; t3]])
let half = Quot (Integer 1, Integer 2)
let derived_parameter_arrays =
[ nc_coupling G_NC_neutrino half (Integer 0);
nc_coupling G_NC_lepton (Neg half) (Integer (-1));
nc_coupling G_NC_up half (Quot (Integer 2, Integer 3));
nc_coupling G_NC_down (Neg half) (Quot (Integer (-1), Integer 3));
nc_coupling G_NC_h_neutrino half (Integer 0);
nc_coupling G_NC_h_lepton (Neg half) (Integer (-1));
nc_coupling G_NC_h_up half (Quot (Integer 2, Integer 3));
nc_coupling G_NC_h_down (Neg half) (Quot (Integer (-1), Integer 3)) ]
let parameters () =
{ input = input_parameters;
derived = derived_parameters;
derived_arrays = derived_parameter_arrays }
module F = Modeltools.Fusions (struct
type f = flavor
type c = constant
let compare = compare
let conjugate = conjugate
end)
(* \begin{equation}
\mathcal{L}_{\textrm{EM}} =
- e \sum_i q_i \bar\psi_i\fmslash{A}\psi_i
\end{equation} *)
let mgm ((m1, g, m2), fbf, c) = ((M m1, G g, M m2), fbf, c)
let mom ((m1, o, m2), fbf, c) = ((M m1, O o, M m2), fbf, c)
let electromagnetic_currents n =
List.map mgm
[ ((L (-n), Ga, L n), FBF (1, Psibar, V, Psi), Q_lepton);
((U (-n), Ga, U n), FBF (1, Psibar, V, Psi), Q_up);
((D (-n), Ga, D n), FBF (1, Psibar, V, Psi), Q_down) ]
let color_currents n =
List.map mgm
[ ((U (-n), Gl, U n), FBF (1, Psibar, V, Psi), Gs);
((D (-n), Gl, D n), FBF (1, Psibar, V, Psi), Gs) ]
(* \begin{equation}
\mathcal{L}_{\textrm{NC}} =
- \frac{g}{2\cos\theta_W}
\sum_i \bar\psi_i\fmslash{Z}(g_V^i-g_A^i\gamma_5)\psi_i
\end{equation} *)
let neutral_currents n =
List.map mgm
[ ((L (-n), Z, L n), FBF (1, Psibar, VA, Psi), G_NC_lepton);
((N (-n), Z, N n), FBF (1, Psibar, VA, Psi), G_NC_neutrino);
((U (-n), Z, U n), FBF (1, Psibar, VA, Psi), G_NC_up);
((D (-n), Z, D n), FBF (1, Psibar, VA, Psi), G_NC_down) ]
(* \begin{equation}
\mathcal{L}_{\textrm{CC}} =
- \frac{g}{2\sqrt2} \sum_i \bar\psi_i
(T^+\fmslash{W}^+ + T^-\fmslash{W}^-)(1-\gamma_5)\psi_i
\end{equation} *)
let charged_currents n =
List.map mgm
[ ((L (-n), Wm, N n), FBF (1, Psibar, VL, Psi), G_CC);
((N (-n), Wp, L n), FBF (1, Psibar, VL, Psi), G_CC);
((D (-n), Wm, U n), FBF (1, Psibar, VL, Psi), G_CC);
((U (-n), Wp, D n), FBF (1, Psibar, VL, Psi), G_CC) ]
let yukawa =
[ ((M (U (-3)), O H, M (U 3)), FBF (1, Psibar, S, Psi), G_Htt);
((M (D (-3)), O H, M (D 3)), FBF (1, Psibar, S, Psi), G_Hbb);
((M (U (-2)), O H, M (U 2)), FBF (1, Psibar, S, Psi), G_Hcc);
((M (L (-3)), O H, M (L 3)), FBF (1, Psibar, S, Psi), G_Htautau) ]
(* \begin{equation}
\mathcal{L}_{\textrm{TGC}} =
- e \partial_\mu A_\nu W_+^\mu W_-^\nu + \ldots
- e \cot\theta_w \partial_\mu Z_\nu W_+^\mu W_-^\nu + \ldots
\end{equation} *)
let tgc ((g1, g2, g3), t, c) = ((G g1, G g2, G g3), t, c)
let triple_gauge =
List.map tgc
[ ((Ga, Wm, Wp), Gauge_Gauge_Gauge 1, I_Q_W);
((Z, Wm, Wp), Gauge_Gauge_Gauge 1, I_G_ZWW);
((Gl, Gl, Gl), Gauge_Gauge_Gauge 1, I_Gs)]
let qgc ((g1, g2, g3, g4), t, c) = ((G g1, G g2, G g3, G g4), t, c)
let gauge4 = Vector4 [(2, C_13_42); (-1, C_12_34); (-1, C_14_23)]
let minus_gauge4 = Vector4 [(-2, C_13_42); (1, C_12_34); (1, C_14_23)]
let quartic_gauge =
List.map qgc
[ (Wm, Wp, Wm, Wp), gauge4, G_WWWW;
(Wm, Z, Wp, Z), minus_gauge4, G_ZZWW;
(Wm, Z, Wp, Ga), minus_gauge4, G_AZWW;
(Wm, Ga, Wp, Ga), minus_gauge4, G_AAWW;
(Gl, Gl, Gl, Gl), gauge4, G2 ]
let gauge_higgs =
[ ((O H, G Wp, G Wm), Scalar_Vector_Vector 1, G_HWW);
((O H, G Z, G Z), Scalar_Vector_Vector 1, G_HZZ);
((O Psi0, G Wp, G Wm), Dim5_Scalar_Gauge2_Skew 1, G_PsiWW);
((O Psi0, G Z, G Z), Dim5_Scalar_Gauge2_Skew 1, G_PsiZZ);
((O Psi0, G Ga, G Ga), Dim5_Scalar_Gauge2_Skew 1, G_PsiAA);
((O Psi0, G Z, G Ga), Dim5_Scalar_Gauge2_Skew 1, G_PsiAZ);
((O Psi0, G Gl, G Gl), Dim5_Scalar_Gauge2_Skew 1, G_PsiGG);
((O Eta, G Gl, G Gl), Dim5_Scalar_Gauge2_Skew 1, G_EtaGG);
((O Eta, G Wp, G Wm), Dim5_Scalar_Gauge2_Skew 1, G_EtaWW);
((O Eta, G Z, G Z), Dim5_Scalar_Gauge2_Skew 1, G_EtaZZ);
((O Eta, G Z, G Ga), Dim5_Scalar_Gauge2_Skew 1, G_EtaAZ);
((O Eta, G Ga, G Ga), Dim5_Scalar_Gauge2_Skew 1, G_EtaAA)]
let gauge_higgs4 =
[ (O H, O H, G Wp, G Wm), Scalar2_Vector2 1, G_HHWW;
(O H, O H, G Z, G Z), Scalar2_Vector2 1, G_HHZZ ]
let higgs =
[ (O H, O H, O H), Scalar_Scalar_Scalar 1, G_H3 ]
let higgs4 =
[ (O H, O H, O H, O H), Scalar4 1, G_H4 ]
let goldstone_vertices =
[ ((O Phi0, G Wm, G Wp), Scalar_Vector_Vector 1, I_G_ZWW);
((O Phip, G Ga, G Wm), Scalar_Vector_Vector 1, I_Q_W);
((O Phip, G Z, G Wm), Scalar_Vector_Vector 1, I_G_ZWW);
((O Phim, G Wp, G Ga), Scalar_Vector_Vector 1, I_Q_W);
((O Phim, G Wp, G Z), Scalar_Vector_Vector 1, I_G_ZWW) ]
let vertices3 =
(ThoList.flatmap electromagnetic_currents [1;2;3] @
ThoList.flatmap color_currents [1;2;3] @
ThoList.flatmap neutral_currents [1;2;3] @
ThoList.flatmap charged_currents [1;2;3] @
yukawa @ triple_gauge @
gauge_higgs @ higgs @ goldstone_vertices)
let vertices4 =
quartic_gauge @ gauge_higgs4 @ higgs4
let vertices () = (vertices3, vertices4, [])
(* For efficiency, make sure that [F.of_vertices vertices] is
evaluated only once. *)
let table = F.of_vertices (vertices ())
let fuse2 = F.fuse2 table
let fuse3 = F.fuse3 table
let fuse = F.fuse table
let max_degree () = 4
let flavor_of_string = function
| "e-" -> M (L 1) | "e+" -> M (L (-1))
| "mu-" -> M (L 2) | "mu+" -> M (L (-2))
| "tau-" -> M (L 3) | "tau+" -> M (L (-3))
| "nue" -> M (N 1) | "nuebar" -> M (N (-1))
| "numu" -> M (N 2) | "numubar" -> M (N (-2))
| "nutau" -> M (N 3) | "nutaubar" -> M (N (-3))
| "u" -> M (U 1) | "ubar" -> M (U (-1))
| "c" -> M (U 2) | "cbar" -> M (U (-2))
| "t" -> M (U 3) | "tbar" -> M (U (-3))
| "d" -> M (D 1) | "dbar" -> M (D (-1))
| "s" -> M (D 2) | "sbar" -> M (D (-2))
| "b" -> M (D 3) | "bbar" -> M (D (-3))
| "g" | "gl" -> G Gl
| "A" -> G Ga | "Z" | "Z0" -> G Z
| "W+" -> G Wp | "W-" -> G Wm
| "Psi" -> O Psi0 | "Eta" -> O Eta
| "H" -> O H
| _ -> invalid_arg "Models.WZW.flavor_of_string"
let flavor_to_string = function
| M f ->
begin match f with
| L 1 -> "e-" | L (-1) -> "e+"
| L 2 -> "mu-" | L (-2) -> "mu+"
| L 3 -> "tau-" | L (-3) -> "tau+"
| L _ -> invalid_arg
"Models.WZW.flavor_to_string: invalid lepton"
| N 1 -> "nue" | N (-1) -> "nuebar"
| N 2 -> "numu" | N (-2) -> "numubar"
| N 3 -> "nutau" | N (-3) -> "nutaubar"
| N _ -> invalid_arg
"Models.WZW.flavor_to_string: invalid neutrino"
| U 1 -> "u" | U (-1) -> "ubar"
| U 2 -> "c" | U (-2) -> "cbar"
| U 3 -> "t" | U (-3) -> "tbar"
| U _ -> invalid_arg
"Models.WZW.flavor_to_string: invalid up type quark"
| D 1 -> "d" | D (-1) -> "dbar"
| D 2 -> "s" | D (-2) -> "sbar"
| D 3 -> "b" | D (-3) -> "bbar"
| D _ -> invalid_arg
"Models.WZW.flavor_to_string: invalid down type quark"
end
| G f ->
begin match f with
| Gl -> "g"
| Ga -> "A" | Z -> "Z"
| Wp -> "W+" | Wm -> "W-"
end
| O f ->
begin match f with
| Phip -> "phi+" | Phim -> "phi-" | Phi0 -> "phi0"
| H -> "H" | Psi0 -> "psi" | Eta -> "eta"
end
let flavor_to_TeX = function
| M f ->
begin match f with
| L 1 -> "e^-" | L (-1) -> "e^+"
| L 2 -> "\\mu-" | L (-2) -> "\\mu^+"
| L 3 -> "\\tau^-" | L (-3) -> "\\tau^+"
| L _ -> invalid_arg
"Models.WZW.flavor_to_TeX: invalid lepton"
| N 1 -> "\\nu_e" | N (-1) -> "\\bar{\\nu}_e"
| N 2 -> "\\nu_\\mu" | N (-2) -> "\\bar{\\nu}_\\mu"
| N 3 -> "\\nu_\\tau" | N (-3) -> "\\bar{\\nu}_\\tau"
| N _ -> invalid_arg
"Models.WZW.flavor_to_TeX: invalid neutrino"
| U 1 -> "u" | U (-1) -> "\\bar{u}"
| U 2 -> "c" | U (-2) -> "\\bar{c}"
| U 3 -> "t" | U (-3) -> "\\bar{t}"
| U _ -> invalid_arg
"Models.WZW.flavor_to_TeX: invalid up type quark"
| D 1 -> "d" | D (-1) -> "\\bar{d}"
| D 2 -> "s" | D (-2) -> "\\bar{s}"
| D 3 -> "b" | D (-3) -> "\\bar{b}"
| D _ -> invalid_arg
"Models.WZW.flavor_to_TeX: invalid down type quark"
end
| G f ->
begin match f with
| Gl -> "g"
| Ga -> "\\gamma" | Z -> "Z"
| Wp -> "W^+" | Wm -> "W^-"
end
| O f ->
begin match f with
| Phip -> "phi+" | Phim -> "phi-" | Phi0 -> "phi0"
| H -> "H" | Psi0 -> "\\Psi" | Eta -> "\\eta"
end
let flavor_symbol = function
| M f ->
begin match f with
| L n when n > 0 -> "l" ^ string_of_int n
| L n -> "l" ^ string_of_int (abs n) ^ "b"
| N n when n > 0 -> "n" ^ string_of_int n
| N n -> "n" ^ string_of_int (abs n) ^ "b"
| U n when n > 0 -> "u" ^ string_of_int n
| U n -> "u" ^ string_of_int (abs n) ^ "b"
| D n when n > 0 -> "d" ^ string_of_int n
| D n -> "d" ^ string_of_int (abs n) ^ "b"
end
| G f ->
begin match f with
| Gl -> "gl"
| Ga -> "a" | Z -> "z"
| Wp -> "wp" | Wm -> "wm"
end
| O f ->
begin match f with
| Phip -> "pp" | Phim -> "pm" | Phi0 -> "p0"
| H -> "h" | Psi0 -> "psi" | Eta -> "eta"
end
(* There are PDG numbers for Z', Z'', W', 32-34, respectively.
We just introduce a number 38 for Y0 as a Z'''.
As well, there is the number 8 for a t'.
*)
let pdg = function
| M f ->
begin match f with
| L n when n > 0 -> 9 + 2*n
| L n -> - 9 + 2*n
| N n when n > 0 -> 10 + 2*n
| N n -> - 10 + 2*n
| U n when n > 0 -> 2*n
| U n -> 2*n
| D n when n > 0 -> - 1 + 2*n
| D n -> 1 + 2*n
end
| G f ->
begin match f with
| Gl -> 21
| Ga -> 22 | Z -> 23
| Wp -> 24 | Wm -> (-24)
end
| O f ->
begin match f with
| Phip | Phim -> 27 | Phi0 -> 26
| H -> 25 | Psi0 -> 28 | Eta -> 29
end
let mass_symbol f =
"mass(" ^ string_of_int (abs (pdg f)) ^ ")"
let width_symbol f =
"width(" ^ string_of_int (abs (pdg f)) ^ ")"
let constant_symbol = function
| Unit -> "unit" | Pi -> "PI"
| Alpha_QED -> "alpha" | E -> "e" | G_weak -> "g" | Vev -> "vev"
| Sin2thw -> "sin2thw" | Sinthw -> "sinthw" | Costhw -> "costhw"
| Q_lepton -> "qlep" | Q_up -> "qup" | Q_down -> "qdwn"
| G_NC_lepton -> "gnclep" | G_NC_neutrino -> "gncneu"
| G_NC_up -> "gncup" | G_NC_down -> "gncdwn"
| G_CC -> "gcc"
| G_NC_h_lepton -> "gnchlep" | G_NC_h_neutrino -> "gnchneu"
| G_NC_h_up -> "gnchup" | G_NC_h_down -> "gnchdwn"
| I_Q_W -> "iqw" | I_G_ZWW -> "igzww" | I_G_WWW -> "igwww"
| G_WWWW -> "gw4" | G_ZZWW -> "gzzww"
| G_AZWW -> "gazww" | G_AAWW -> "gaaww"
| G_HWW -> "ghww" | G_HZZ -> "ghzz"
| G_HHWW -> "ghhww" | G_HHZZ -> "ghhzz"
| G_PsiWW -> "gpsiww" | G_PsiZZ -> "gpsizz" | G_PsiAA -> "gpsiaa"
| G_PsiAZ -> "gpsiaz" | G_PsiGG -> "gpsigg" | G_EtaGG -> "getagg"
| G_EtaZZ -> "getazz" | G_EtaAA -> "getaaa" | G_EtaAZ -> "getaaz"
| G_EtaWW -> "getaww"
| G_Htt -> "ghtt" | G_Hbb -> "ghbb"
| G_Htautau -> "ghtautau" | G_Hcc -> "ghcc"
| G_H3 -> "gh3" | G_H4 -> "gh4"
| Gs -> "gs" | I_Gs -> "igs" | G2 -> "gs**2"
| Mass f -> "mass" ^ flavor_symbol f
| Width f -> "width" ^ flavor_symbol f
end
Index: trunk/omega/src/topology.ml
===================================================================
--- trunk/omega/src/topology.ml (revision 8899)
+++ trunk/omega/src/topology.ml (revision 8900)
@@ -1,871 +1,860 @@
(* topology.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
module type T =
sig
type partition
val partitions : int -> partition list
type 'a children
val keystones : 'a list -> ('a list * 'a list children list) list
val max_subtree : int -> int
val inspect_partition : partition -> int list
end
(* \thocwmodulesection{Factorizing Diagrams for $\phi^3$} *)
module Binary =
struct
type partition = int * int * int
let inspect_partition (n1, n2, n3) = [n1; n2; n3]
(* One way~\cite{ALPHA:1997} to lift the degeneracy is to select the
vertex that is closest to the center
(see table~\ref{tab:partition}):
\begin{equation}
\label{eq:partition}
\text{\ocwlowerid{partitions}}: n \to
\bigl\{ (n_1,n_2,n_3) \,\vert\, n_1 + n_2 + n_3 = n
\land n_1 \le n_2 \le n_3 \le \lfloor n/2 \rfloor \bigr\}
\end{equation}
Other, less symmetric, approaches are possible. The simplest
of these is: choose the vertex adjacent to a fixed
external line~\cite{HELAC:2000}. They will be made available
for comparison in the future.
\begin{table}
\begin{center}
\begin{tabular}{ r | l }
[n]& [partitions n] \\\hline
4 & (1,1,2) \\
5 & (1,2,2) \\
6 & (1,2,3), (2,2,2) \\
7 & (1,3,3), (2,2,3) \\
8 & (1,3,4), (2,2,4), (2,3,3) \\
9 & (1,4,4), (2,3,4), (3,3,3) \\
10 & (1,4,5), (2,3,5), (2,4,4), (3,3,4) \\
11 & (1,5,5), (2,4,5), (3,3,5), (3,4,4) \\
12 & (1,5,6), (2,4,6), (2,5,5), (3,3,6), (3,4,5), (4,4,4) \\
13 & (1,6,6), (2,5,6), (3,4,6), (3,5,5), (4,4,5) \\
14 & (1,6,7), (2,5,7), (2,6,6), (3,4,7), (3,5,6), (4,4,6), (4,5,5) \\
15 & (1,7,7), (2,6,7), (3,5,7), (3,6,6), (4,4,7), (4,5,6), (5,5,5) \\
16 & (1,7,8), (2,6,8), (2,7,7), (3,5,8), (3,6,7), (4,4,8), (4,5,7), (4,6,6), (5,5,6)
\end{tabular}
\end{center}
\caption{\label{tab:partition} [partitions n] for moderate values
of [n].}
\end{table} *)
(* An obvious consequence of~$n_1 + n_2 + n_3 = n$
and~$n_1 \le n_2 \le n_3$ is $n_1\le\lfloor n/3 \rfloor$: *)
let rec partitions' n n1 =
if n1 > n / 3 then
[]
else
List.map (fun (n2, n3) -> (n1, n2, n3))
(Partition.pairs (n - n1) n1 (n / 2)) @ partitions' n (succ n1)
let partitions n = partitions' n 1
(* \begin{figure}
\begin{center}
\hfil\\
\begin{fmfgraph*}(25,20)
\fmfstraight
\fmfbottomn{b}{2}
\fmftopn{t}{1}
\fmf{plain}{t1,v}
\fmf{plain}{b1,v}
\fmf{plain}{b2,v}
\fmfv{d.sh=circle,d.f=empty,d.si=18pt,l=$n$,l.d=0}{b1}
\fmfv{d.sh=circle,d.f=empty,d.si=18pt,l=$n$,l.d=0}{b2}
\fmfv{d.sh=circle,d.f=empty,d.si=18pt,l=$n$,l.d=0}{t1}
\fmfv{d.sh=circle,d.f=empty,d.si=5thin}{v}
\end{fmfgraph*}
\qquad\qquad\qquad\qquad
\begin{fmfgraph*}(25,20)
\fmfstraight
\fmfbottomn{b}{3}
\fmftopn{t}{1}
\fmf{plain}{b1,t1}
\fmf{plain}{b2,t1}
\fmf{plain}{b3,t1}
\fmfv{d.sh=triangle,d.f=empty,d.si=25pt,l=$n$,l.d=0}{b1}
\fmfv{d.sh=triangle,d.f=empty,d.si=25pt,l=$n$,l.d=0}{b2}
\fmfv{d.sh=triangle,d.f=empty,d.si=25pt,l=$n$,l.d=0}{b3}
\fmfv{d.sh=circle,d.f=empty,d.si=5thin}{t1}
\end{fmfgraph*}
\end{center}
\caption{\label{fig:nnn} Topologies with a blatant three-fold
permutation symmetry, if the number of external lines is a
multiple of three}
\end{figure}
\begin{figure}
\begin{center}
\begin{fmfgraph*}(15,20)
\fmfstraight
\fmfbottomn{b}{2}
\fmftopn{t}{1}
\fmf{plain}{b1,v}
\fmf{plain}{b2,v}
\fmf{plain,tension=2}{t1,v}
\fmfv{d.sh=circle,d.f=empty,d.si=18pt,l=$n$,l.d=0}{t1}
\fmfv{d.sh=circle,d.f=empty,d.si=18pt,l=$n'$,l.d=0}{b1}
\fmfv{d.sh=circle,d.f=empty,d.si=18pt,l=$n'$,l.d=0}{b2}
\fmfv{d.sh=circle,d.f=empty,d.si=5thin}{v}
\end{fmfgraph*}
\qquad\qquad\qquad\qquad
\begin{fmfgraph*}(25,20)
\fmfstraight
\fmfbottomn{b}{3}
\fmftopn{t}{1}
\fmf{plain}{b1,t1}
\fmf{plain}{b2,t1}
\fmf{plain}{b3,t1}
\fmfv{d.sh=triangle,d.f=empty,d.si=25pt,l=$n$,l.d=0}{b1}
\fmfv{d.sh=triangle,d.f=empty,d.si=30pt,l=$n'$,l.d=0}{b2}
\fmfv{d.sh=triangle,d.f=empty,d.si=30pt,l=$n'$,l.d=0}{b3}
\fmfv{d.sh=circle,d.f=empty,d.si=5thin}{t1}
\fmfshift{(0,.2h)}{b1}
\end{fmfgraph*}
\qquad\qquad
\begin{fmfgraph*}(25,20)
\fmfstraight
\fmfbottomn{b}{3}
\fmftopn{t}{1}
\fmf{plain}{b1,t1}
\fmf{plain}{b2,t1}
\fmf{plain}{b3,t1}
\fmfv{d.sh=triangle,d.f=empty,d.si=25pt,l=$n'$,l.d=0}{b1}
\fmfv{d.sh=triangle,d.f=empty,d.si=25pt,l=$n'$,l.d=0}{b2}
\fmfv{d.sh=triangle,d.f=empty,d.si=30pt,l=$n$,l.d=0}{b3}
\fmfv{d.sh=circle,d.f=empty,d.si=5thin}{t1}
\fmfshift{(0,.2h)}{b1,b2}
\end{fmfgraph*}
\end{center}
\caption{\label{fig:n1n2n2} Topologies with a blatant two-fold symmetry.}
\end{figure}
\begin{figure}
\begin{center}
\hfil\\
\begin{fmfgraph*}(25,20)
\fmfstraight
\fmfbottomn{b}{3}
\fmftopn{t}{1}
\fmf{plain}{b1,t1}
\fmf{plain}{b2,t1}
\fmf{plain}{b3,t1}
\fmfv{d.sh=triangle,d.f=empty,d.si=25pt,l=$n_1$,l.d=0}{b1}
\fmfv{d.sh=triangle,d.f=empty,d.si=30pt,l=$n_2$,l.d=0}{b2}
\fmfv{d.sh=triangle,d.f=empty,d.si=35pt,l=$n_3$,l.d=0}{b3}
\fmfv{d.sh=circle,d.f=empty,d.si=5thin}{t1}
\fmfshift{(0,.30h)}{b1}
\fmfshift{(0,.15h)}{b2}
\end{fmfgraph*}
\qquad\qquad
\begin{fmfgraph*}(25,20)
\fmfstraight
\fmfbottomn{b}{3}
\fmftopn{t}{1}
\fmf{plain}{b1,t1}
\fmf{plain}{b2,t1}
\fmf{plain}{b3,t1}
\fmfv{d.sh=triangle,d.f=empty,d.si=25pt,l=$n$,l.d=0}{b1}
\fmfv{d.sh=triangle,d.f=empty,d.si=25pt,l=$n$,l.d=0}{b2}
\fmfv{d.sh=triangle,d.f=empty,d.si=35pt,l=$2n$,l.d=0}{b3}
\fmfv{d.sh=circle,d.f=empty,d.si=5thin}{t1}
\fmfshift{(0,.20h)}{b1}
\fmfshift{(0,.20h)}{b2}
\end{fmfgraph*}
\end{center}
\caption{\label{fig:n1n2n3} If~$n_3=n_1+n_2$, the apparently
asymmetric topologies on the left hand side have a non obvious
two-fold symmetry, that exchanges the two halves. Therefore,
the topologies on the right hand side have a four fold symmetry.}
\end{figure} *)
type 'a children = 'a Tuple.Binary.t
(* There remains one peculiar case, when the number of external lines is
even and~$n_3=n_1+n_2$ (cf.~figure~\ref{fig:n1n2n3}).
Unfortunately, this reflection symmetry is not respected by the equivalence
classes. E.\,g.
\begin{equation}
\{1\}\{2,3\}\{4,5,6\}\mapsto\bigl\{
\{4\}\{5,6\}\{1,2,3\}; \{5\}\{4,6\}\{1,2,3\}; \{6\}\{4,5\}\{1,2,3\} \bigr\}
\end{equation}
However, these reflections will always exchange the two halves
and a representative can be chosen by requiring that one fixed
momentum remains in one half. We choose to filter out the half
of the partitions where the element~[p] appears in the second
half, i.\,e.~the list of length~[n3].
Finally, a closed expression for the number of Feynman diagrams
in the equivalence class $(n_1,n_2,n_3)$ is
\begin{equation}
N(n_1,n_2,n_3) =
\frac{(n_1+n_2+n_3)!}{S(n_1,n_2,n_3)}
\prod_{i=1}^{3} \frac{(2n_i-3)!!}{n_i!}
\end{equation}
where the symmetry factor from the above arguments is
\begin{equation}
\label{eq:S(1,2,3)}
S(n_1,n_2,n_3) =
\begin{cases}
3! & \text{for $n_1 = n_2 = n_3$} \\
2\cdot2 & \text{for $n_3 = 2n_1 = 2n_2$} \\
2 & \text{for $n_1 = n_2 \lor n_2 = n_3$} \\
2 & \text{for $n_1 + n_2 = n_3$}
\end{cases}
\end{equation}
Indeed, the sum of all Feynman diagrams
\begin{equation}
\label{eq:keystone-check}
\sum_{\substack{n_1 + n_2 + n_3 = n\\
1 \le n_1 \le n_2 \le n_3 \le \lfloor n/2 \rfloor}}
N(n_1,n_2,n_3) = (2n-5)!!
\end{equation}
can be checked numerically for large values of $n=n_1+n_2+n_3$,
verifying the symmetry factor (see table~\ref{tab:keystone-check}).
\begin{dubious}
P.\,M.~claims to have seen similar formulae in the context of
Young tableaux. That's a good occasion to read the new edition
of Howard's book \ldots
\end{dubious}
\begin{table}
\begin{center}
\begin{tabular}{ r | r | l }
$n$ & $(2n-5)!!$ & $\sum N(n_1,n_2,n_3)$ \\\hline
4 & 3 & $3\cdot(1,1,2)$ \\
5 & 15 & $15\cdot(1,2,2)$ \\
6 & 105 & $90\cdot(1,2,3) + 15\cdot(2,2,2)$ \\
7 & 945 & $630\cdot(1,3,3) + 315\cdot(2,2,3)$ \\
8 & 10395 & $6300\cdot(1,3,4) + 1575\cdot(2,2,4) + 2520\cdot(2,3,3)$ \\
9 & 135135 & $70875\cdot(1,4,4) + 56700\cdot(2,3,4) + 7560\cdot(3,3,3)$ \\
10 & 2027025 & $992250\cdot(1,4,5) + 396900\cdot(2,3,5)$ \\
& & \quad$\mbox{}+ 354375\cdot(2,4,4) + 283500\cdot(3,3,4)$ \\
11 & 34459425 & $15280650\cdot(1,5,5) + 10914750\cdot(2,4,5)$ \\
& & \quad$\mbox{}+ 4365900\cdot(3,3,5) + 3898125\cdot(3,4,4)$ \\
12 & 654729075 & $275051700\cdot(1,5,6) + 98232750\cdot(2,4,6)$ \\
& & \quad$\mbox{}+ 91683900\cdot(2,5,5)+ 39293100\cdot(3,3,6)$ \\
& & \quad$\mbox{}+ 130977000\cdot(3,4,5) + 19490625\cdot(4,4,4)$
\end{tabular}
\end{center}
\caption{\label{tab:keystone-check} Equation~(\ref{eq:keystone-check}) for
small values of $n$.}
\end{table} *)
(* Return a list of all inequivalent partitions of the list~[l] in three
lists of length [n1], [n2] and [n3], respectively. Common first lists
are factored. This is nothing more than a typedafe wrapper around
[Combinatorics.factorized_keystones]. *)
exception Impossible of string
let tuple_of_list2 = function
| [x1; x2] -> Tuple.Binary.of2 x1 x2
| _ -> raise (Impossible "Topology.tuple_of_list")
let keystone (n1, n2, n3) l =
List.map (fun (p1, p23) -> (p1, List.rev_map tuple_of_list2 p23))
(Combinatorics.factorized_keystones [n1; n2; n3] l)
let keystones l =
ThoList.flatmap (fun n123 -> keystone n123 l) (partitions (List.length l))
let max_subtree n = n / 2
end
(* \thocwmodulesection{Factorizing Diagrams for $\sum_n\lambda_n\phi^n$} *)
(* \begin{figure}
\begin{center}
\begin{fmfgraph}(25,20)
\fmfleftn{l}{3}
\fmfrightn{r}{3}
\fmf{plain}{l1,v4}
\fmf{plain}{l2,v4}
\fmf{plain}{l3,v4}
\fmf{plain}{r1,v1}
\fmf{plain}{r2,v1}
\fmf{plain}{v1,v2}
\fmf{plain}{r3,v2}
\fmf{plain}{v2,v4}
\fmfv{d.sh=circle,d.f=empty,d.si=5thin}{v4}
\fmfdot{v1,v2}
\end{fmfgraph}
\qquad\qquad
\begin{fmfgraph}(25,20)
\fmfleftn{l}{3}
\fmfrightn{r}{3}
\fmf{plain}{l1,v4}
\fmf{plain}{l2,v4}
\fmf{plain}{l3,v4}
\fmf{plain}{r1,v1}
\fmf{plain}{r2,v1}
\fmf{plain}{v1,v2}
\fmf{plain}{r3,v2}
\fmf{plain}{v2,v4}
\fmfv{d.sh=circle,d.f=empty,d.si=5thin}{v2}
\fmfdot{v1,v4}
\end{fmfgraph}
\end{center}
\caption{\label{fig:n1n2n3n4} Degenerate $(1,1,1,3)$ and $(1,2,3)$.}
\end{figure} *)
(* Mixed $\phi^n$ adds new degeneracies, as in figure~\ref{fig:n1n2n3n4}.
They appear if and only if one part takes exactly half of the external
lines and can relate central vertices of different arity. *)
module Nary (B : Tuple.Bound) =
struct
type partition = int list
let inspect_partition p = p
let partition d sum =
Partition.tuples d sum 1 (sum / 2)
let rec partitions' d sum =
if d < 3 then
[]
else
partition d sum @ partitions' (pred d) sum
let partitions sum = partitions' (succ (B.max_arity ())) sum
(* \begin{table}
\begin{center}
\begin{tabular}{ r | r | l }
$n$ & $\sum$ & $\sum$ \\\hline
4 & 4 & $1\cdot(1,1,1,1) + 3\cdot(1,1,2)$ \\
5 & 25 & $10\cdot(1,1,1,2) + 15\cdot(1,2,2)$ \\
6 & 220 & $40\cdot(1,1,1,3) + 45\cdot(1,1,2,2)
+ 120\cdot(1,2,3) + 15\cdot(2,2,2)$ \\
7 & 2485 & $840\cdot(1,1,2,3) + 105\cdot(1,2,2,2)
+ 1120\cdot(1,3,3) + 420\cdot(2,2,3)$ \\
8 & 34300 & $5250\cdot(1,1,2,4) + 4480\cdot(1,1,3,3) + 3360\cdot(1,2,2,3)$\\
& & \quad$\mbox{}+ 105\cdot(2,2,2,2) + 14000\cdot(1,3,4)$\\
& & \quad$\mbox{}+ 2625\cdot(2,2,4) + 4480\cdot(2,3,3)$ \\
9 & 559405 & $126000\cdot(1,1,3,4) + 47250\cdot(1,2,2,4) + 40320\cdot(1,2,3,3)$\\
& & \quad$\mbox{}+ 5040\cdot(2,2,2,3) + 196875\cdot(1,4,4)$\\
& & \quad$\mbox{}+ 126000\cdot(2,3,4) + 17920\cdot(3,3,3)$ \\
10 & 10525900 & $1108800\cdot(1,1,3,5) + 984375\cdot(1,1,4,4) + 415800\cdot(1,2,2,5)$\\
& & \quad$\mbox{}+ 1260000\cdot(1,2,3,4) + 179200\cdot(1,3,3,3)
+ 78750\cdot(2,2,2,4)$\\
& & \quad$\mbox{}+ 100800\cdot(2,2,3,3) + 3465000\cdot(1,4,5)
+ 1108800\cdot(2,3,5)$\\
& & \quad$\mbox{}+ 984375\cdot(2,4,4) + 840000\cdot(3,3,4)$
\end{tabular}
\end{center}
\caption{\label{tab:keystone-check4}%
$\mathcal{L}=\lambda_3\phi^3+\lambda_4\phi^4$}
\end{table}
\begin{table}
\begin{center}
\begin{tabular}{ r | r | l }
$n$ & $\sum$ & $\sum$ \\\hline
4 & 4 & $1\cdot(1,1,1,1) + 3\cdot(1,1,2)$ \\
5 & 26 & $1\cdot(1,1,1,1,1) + 10\cdot(1,1,1,2) + 15\cdot(1,2,2)$ \\
6 & 236 & $1\cdot(1,1,1,1,1,1) + 15\cdot(1,1,1,1,2) + 40\cdot(1,1,1,3)$\\
& & \quad$\mbox{}+ 45\cdot(1,1,2,2) + 120\cdot(1,2,3) + 15\cdot(2,2,2)$ \\
7 & 2751 & $21\cdot(1,1,1,1,1,2) + 140\cdot(1,1,1,1,3) + 105\cdot(1,1,1,2,2)$\\
& & \quad$\mbox{}+ 840\cdot(1,1,2,3) + 105\cdot(1,2,2,2)
+ 1120\cdot(1,3,3) + 420\cdot(2,2,3)$ \\
8 & 39179 & $224\cdot(1,1,1,1,1,3) + 210\cdot(1,1,1,1,2,2) + 910\cdot(1,1,1,1,4)$\\
& & \quad$\mbox{}+ 2240\cdot(1,1,1,2,3) + 420\cdot(1,1,2,2,2)
+ 5460\cdot(1,1,2,4)$\\
& & \quad$\mbox{}+ 4480\cdot(1,1,3,3) + 3360\cdot(1,2,2,3)
+ 105\cdot(2,2,2,2)$\\
& & \quad$\mbox{}+ 14560\cdot(1,3,4) + 2730\cdot(2,2,4) + 4480\cdot(2,3,3)$
\end{tabular}
\end{center}
\caption{\label{tab:keystone-check6}%
$\mathcal{L}=\lambda_3\phi^3+\lambda_4\phi^4+\lambda_5\phi^5+\lambda_6\phi^6$}
\end{table} *)
module Tuple = Tuple.Nary(B)
type 'a children = 'a Tuple.t
let keystones' l =
let n = List.length l in
ThoList.flatmap (fun p -> Combinatorics.factorized_keystones p l)
(partitions n)
let keystones l =
List.map (fun (bra, kets) -> (bra, List.map Tuple.of_list kets))
(keystones' l)
let max_subtree n = n / 2
end
module Nary4 = Nary (struct let max_arity () = 3 end)
(* \thocwmodulesection{Factorizing Diagrams for $\phi^4$} *)
module Ternary =
struct
type partition = int * int * int * int
let inspect_partition (n1, n2, n3, n4) = [n1; n2; n3; n4]
type 'a children = 'a Tuple.Ternary.t
let collect4 acc = function
| [x; y; z; u] -> (x, y, z, u) :: acc
| _ -> acc
let partitions n =
List.fold_left collect4 [] (Nary4.partitions n)
let collect3 acc = function
| [x; y; z] -> Tuple.Ternary.of3 x y z :: acc
| _ -> acc
let keystones l =
List.map (fun (bra, kets) -> (bra, List.fold_left collect3 [] kets))
(Nary4.keystones' l)
let max_subtree = Nary4.max_subtree
end
(* \thocwmodulesection{Factorizing Diagrams for $\phi^3+\phi^4$} *)
module Mixed23 =
struct
type partition =
| P3 of int * int * int
| P4 of int * int * int * int
let inspect_partition = function
| P3 (n1, n2, n3) -> [n1; n2; n3]
| P4 (n1, n2, n3, n4) -> [n1; n2; n3; n4]
type 'a children = 'a Tuple.Mixed23.t
let collect34 acc = function
| [x; y; z] -> P3 (x, y, z) :: acc
| [x; y; z; u] -> P4 (x, y, z, u) :: acc
| _ -> acc
let partitions n =
List.fold_left collect34 [] (Nary4.partitions n)
let collect23 acc = function
| [x; y] -> Tuple.Mixed23.of2 x y :: acc
| [x; y; z] -> Tuple.Mixed23.of3 x y z :: acc
| _ -> acc
let keystones l =
List.map (fun (bra, kets) -> (bra, List.fold_left collect23 [] kets))
(Nary4.keystones' l)
let max_subtree = Nary4.max_subtree
end
(* \thocwmodulesection{%
Diagnostics: Counting Diagrams and Factorizations for $\sum_n\lambda_n\phi^n$} *)
module type Integer =
sig
type t
val zero : t
val one : t
val ( + ) : t -> t -> t
val ( - ) : t -> t -> t
val ( * ) : t -> t -> t
val ( / ) : t -> t -> t
val pred : t -> t
val succ : t -> t
val ( = ) : t -> t -> bool
val ( <> ) : t -> t -> bool
val ( < ) : t -> t -> bool
val ( <= ) : t -> t -> bool
val ( > ) : t -> t -> bool
val ( >= ) : t -> t -> bool
val of_int : int -> t
val to_int : t -> int
val to_string : t -> string
val compare : t -> t -> int
val factorial : t -> t
end
(* O'Caml's native integers suffice for all applications, but in
appendix~\ref{sec:count}, we want to use big integers for numeric
checks in high orders: *)
module Int : Integer =
struct
type t = int
let zero = 0
let one = 1
let ( + ) = ( + )
let ( - ) = ( - )
let ( * ) = ( * )
let ( / ) = ( / )
let pred = pred
let succ = succ
let ( = ) = ( = )
let ( <> ) = ( <> )
let ( < ) = ( < )
let ( <= ) = ( <= )
let ( > ) = ( > )
let ( >= ) = ( >= )
let of_int n = n
let to_int n = n
let to_string = string_of_int
let compare = compare
let factorial = Combinatorics.factorial
end
module type Count =
sig
type integer
val diagrams : ?f:(integer -> bool) -> integer -> integer -> integer
val diagrams_via_keystones : integer -> integer -> integer
val keystones : integer list -> integer
val diagrams_per_keystone : integer -> integer list -> integer
end
module Count (I : Integer) =
struct
let description = ["(still inoperational) phi^n topology"]
type integer = I.t
open I
let two = of_int 2
let three = of_int 3
-(* If [I.t] is an abstract datatype, the polymorphic [Pervasives.min]
+(* If [I.t] is an abstract datatype, the polymorphic [Stdlib.min]
can fail. Provide our own version using the specific comparison
``[(<=)]''. *)
let min x y =
if x <= y then
x
else
y
(* \thocwmodulesubsection{Counting Diagrams for $\sum_n\lambda_n\phi^n$} *)
(* Classes of diagrams are defined by the number of vertices and their
degrees. We could use fixed size arrays, but we will use a map
instead. For efficiency, we also maintain the number of external
lines and the total number of propagators. *)
- module IMap = Map.Make (struct type t = integer let compare = compare end)
+ module IMap = Map.Make (struct type t = integer let compare = I.compare end)
type diagram_class = { ext : integer; prop : integer; v : integer IMap.t }
(*i
let to_string cl =
IMap.fold
(fun d n s ->
s ^ Printf.sprintf ", #%s=%s" (to_string d) (to_string n)) cl.v
(Printf.sprintf "#ext=%s, #prop=%s"
(to_string cl.ext) (to_string cl.prop))
i*)
(* The numbers of external lines, propagators and vertices are determined
by the degrees and multiplicities of vertices:
\begin{subequations}
\begin{align}
E(\{n_3,n_4,\ldots\}) &= 2 + \sum_{d=3}^{\infty} (d-2)n_d \\
P(\{n_3,n_4,\ldots\}) &= \sum_{d=3}^{\infty} n_d - 1
= V(\{n_3,n_4,\ldots\}) - 1 \\
V(\{n_3,n_4,\ldots\}) &= \sum_{d=3}^{\infty} n_d
\end{align}
\end{subequations} *)
let num_ext v =
List.fold_left (fun sum (d, n) -> sum + (d - two) * n) two v
let num_prop v =
List.fold_left (fun sum (_, n) -> sum + n) (zero - one) v
(* The sum of all vertex degrees must be equal to the number of propagator end
points. This can be verified easily:
\begin{equation}
2 P(\{n_3,n_4,\ldots\}) + E(\{n_3,n_4,\ldots\}) = \sum_{d=3}^{\infty} dn_d
\end{equation} *)
let add_degree map (d, n) =
if d < three then
invalid_arg "add_degree: d < 3"
else if n < zero then
invalid_arg "add_degree: n <= 0"
else if n = zero then
map
else
IMap.add d n map
let create_class v =
{ ext = num_ext v;
prop = num_prop v;
v = List.fold_left add_degree IMap.empty v }
let multiplicity cl d =
if d >= three then
try
IMap.find d cl.v
with
| Not_found -> zero
else
invalid_arg "multiplicity: d < 3"
(* Remove one vertex of degree [d], maintaining the invariants. Raises
[Zero] if all vertices of degree [d] are exhausted. *)
exception Zero
let remove cl d =
let n = pred (multiplicity cl d) in
if n < zero then
raise Zero
else
{ ext = cl.ext - (d - two);
prop = pred cl.prop;
v = if n = zero then
IMap.remove d cl.v
else
IMap.add d n cl.v }
(* Add one vertex of degree [d], maintaining the invariants. *)
let add cl d =
{ ext = cl.ext + (d - two);
prop = succ cl.prop;
v = IMap.add d (succ (multiplicity cl d)) cl.v }
(* Count the number of diagrams. Any diagram can be obtained recursively either
from a diagram with one ternary vertex less by insertion if a ternary vertex
in an internal or external propagator or from a diagram with a higher order
vertex that has its degree reduced by one:
\begin{multline}
D(\{n_3,n_4,\ldots\}) = \\
\left(P(\{n_3-1,n_4,\ldots\})+E(\{n_3-1,n_4,\ldots\})\right)
D(\{n_3-1,n_4,\ldots\}) \\
{} + \sum_{d=4}^{\infty} (n_{d-1} + 1) D(\{n_3,n_4,\ldots,n_{d-1}+1,n_d-1,\ldots\})
\end{multline} *)
let rec class_size cl =
if cl.ext = two || cl.prop = zero then
one
else
IMap.fold (fun d _ s -> class_size_n cl d + s) cl.v (class_size_3 cl)
(* Purely ternary vertices recurse among themselves: *)
and class_size_3 cl =
try
let d' = remove cl three in
(d'.ext + d'.prop) * class_size d'
with
| Zero -> zero
(* Vertices of higher degree recurse one step towards lower degrees: *)
and class_size_n cl d =
if d > three then begin
try
let d' = pred d in
let cl' = add (remove cl d) d' in
multiplicity cl' d' * class_size cl'
with
| Zero -> zero
end else
zero
(* Find all $\{n_3,n_4,\ldots,n_d\}$ with
\begin{equation}
E(\{n_3,n_4,\ldots,n_d\}) - 2 = \sum_{i=3}^cl (i-2)n_i = \ocwlowerid{sum}
\end{equation}
The implementation is a variant of [tuples] above. *)
let rec distribute_degrees' d sum =
if d < three then
invalid_arg "distribute_degrees"
else if d = three then
[[(d, sum)]]
else
distribute_degrees'' d sum (sum / (d - two))
and distribute_degrees'' d sum n =
if n < zero then
[]
else
List.fold_left (fun ll l -> ((d, n) :: l) :: ll)
(distribute_degrees'' d sum (pred n))
(distribute_degrees' (pred d) (sum - (d - two) * n))
(* Actually, we need to find all $\{n_3,n_4,\ldots,n_d\}$ with
\begin{equation}
E(\{n_3,n_4,\ldots,n_d\}) = \ocwlowerid{sum}
\end{equation} *)
let distribute_degrees d sum = distribute_degrees' d (sum - two)
(* Finally we can count all diagrams by adding all possible ways of
splitting the degrees of vertices. We can also count diagrams where
\emph{all} degrees satisfy a predicate [f]: *)
let diagrams ?(f = fun _ -> true) deg n =
List.fold_left (fun s d ->
if List.for_all (fun (d', n') -> f d' || n' = zero) d then
s + class_size (create_class d)
else
s)
zero (distribute_degrees deg n)
(* The next two are duplicated from [ThoList] and [Combinatorics],
in order to use the specific comparison functions. *)
let classify l =
let rec add_to_class a = function
| [] -> [of_int 1, a]
| (n, a') :: rest ->
if a = a' then
(succ n, a) :: rest
else
(n, a') :: add_to_class a rest
in
let rec classify' cl = function
| [] -> cl
| a :: rest -> classify' (add_to_class a cl) rest
in
classify' [] l
let permutation_symmetry l =
List.fold_left (fun s (n, _) -> factorial n * s) one (classify l)
let symmetry l =
let sum = List.fold_left (+) zero l in
if List.exists (fun x -> two * x = sum) l then
two * permutation_symmetry l
else
permutation_symmetry l
(* The number of Feynman diagrams built of vertices with maximum
degree~$d_{\max}$ in a partition $N_{d,n}=\{n_1,n_2,\ldots,n_d\}$
with $n = n_1 + n_2 + \cdots + n_d$ and
\begin{equation}
\tilde F(d_{\max},N_{d,n}) =
\frac{n!}{ |\mathcal{S}(N_{d,n})| \sigma(n_d,n)}
\prod_{i=1}^{d} \frac{F(d_{\max},n_i+1)}{n_i!}
\end{equation}
with~$|\mathcal{S}(N)|$ the size of the symmetric group of~$N$,
$\sigma(n,2n) = 2$ and $\sigma(n,m) = 1$ otherwise. *)
let keystones p =
let sum = List.fold_left (+) zero p in
List.fold_left (fun acc n -> acc / (factorial n)) (factorial sum) p
/ symmetry p
let diagrams_per_keystone deg p =
List.fold_left (fun acc n -> acc * diagrams deg (succ n)) one p
(* We must find
\begin{equation}
F(d_{\max},n) =
\sum_{d=3}^{d_{\max}}
\sum_{\substack{N = \{n_1,n_2,\ldots,n_d\}\\
n_1 + n_2 + \cdots + n_d = n\\
1 \le n_1 \le n_2 \le \cdots \le n_d \le \lfloor n/2 \rfloor}}
\tilde F(d_{\max},N)
\end{equation} *)
let diagrams_via_keystones deg n =
let module N = Nary (struct let max_arity () = to_int (pred deg) end) in
List.fold_left
(fun acc p -> acc + diagrams_per_keystone deg p * keystones p)
zero (List.map (List.map of_int) (N.partitions (to_int n)))
end
(* \thocwmodulesection{Emulating HELAC} *)
(* In~\cite{HELAC:2000}, one leg is singled out: *)
module Helac (B : Tuple.Bound) =
struct
module Tuple = Tuple.Nary(B)
type partition = int list
let inspect_partition p = p
let partition d sum =
Partition.tuples d sum 1 (sum - d + 1)
let rec partitions' d sum =
let d' = pred d in
if d' < 2 then
[]
else
List.map (fun p -> 1::p) (partition d' (pred sum)) @ partitions' d' sum
let partitions sum = partitions' (succ (B.max_arity ())) sum
type 'a children = 'a Tuple.t
let keystones' l =
match l with
| [] -> []
| head :: tail ->
[([head],
ThoList.flatmap (fun p -> Combinatorics.partitions (List.tl p) tail)
(partitions (List.length l)))]
let keystones l =
List.map (fun (bra, kets) -> (bra, List.map Tuple.of_list kets))
(keystones' l)
let max_subtree n = pred n
end
(* \begin{dubious}
The following is not tested, but it is no rocket science either \ldots
\end{dubious} *)
module Helac_Binary =
struct
type partition = int * int * int
let inspect_partition (n1, n2, n3) = [n1; n2; n3]
let partitions sum =
List.map (fun (n2, n3) -> (1, n2, n3))
(Partition.pairs (sum - 1) 1 (sum - 2))
type 'a children = 'a Tuple.Binary.t
let keystones' l =
match l with
| [] -> []
| head :: tail ->
[([head],
ThoList.flatmap (fun (_, p2, _) -> Combinatorics.split p2 tail)
(partitions (List.length l)))]
let keystones l =
List.map (fun (bra, kets) ->
(bra, List.map (fun (x, y) -> Tuple.Binary.of2 x y) kets))
(keystones' l)
let max_subtree n = pred n
end
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
-
-
-
Index: trunk/omega/src/sets.ml
===================================================================
--- trunk/omega/src/sets.ml (revision 8899)
+++ trunk/omega/src/sets.ml (revision 8900)
@@ -1,34 +1,32 @@
(* sets.ml --
Copyright (C) 2019-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module String =
- Set.Make (struct type t = string let compare = compare end)
+module String = Set.Make(String)
module String_Caseless =
Set.Make
(struct
type t = string
let compare = ThoString.compare_caseless
end)
-module Int =
- Set.Make (struct type t = int let compare = compare end)
+module Int = Set.Make(Int)
Index: trunk/omega/src/omega_MSSM_CKM.ml
===================================================================
--- trunk/omega/src/omega_MSSM_CKM.ml (revision 8899)
+++ trunk/omega/src/omega_MSSM_CKM.ml (revision 8900)
@@ -1,26 +1,26 @@
(* omega_MSSM_CKM.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23_Majorana_vintage(Targets.Fortran_Majorana)(Modellib_MSSM.MSSM(Modellib_MSSM.MSSM_no_4_ckm))
+module O = Omega.Mixed23_Majorana_vintage(Target_Fortran.Make_Majorana)(Modellib_MSSM.MSSM(Modellib_MSSM.MSSM_no_4_ckm))
let _ = O.main ()
Index: trunk/omega/src/dirac.ml
===================================================================
--- trunk/omega/src/dirac.ml (revision 8899)
+++ trunk/omega/src/dirac.ml (revision 8900)
@@ -1,493 +1,493 @@
(* Dirac.ml --
Copyright (C) 1999-2017 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
(* \thocwmodulesection{Dirac $\gamma$-matrices} *)
module type T =
sig
type qc = Algebra.QC.t
type t = qc array array
val zero : qc
val one : qc
val minus_one : qc
val i : qc
val minus_i : qc
val unit : t
val null : t
val gamma0 : t
val gamma1 : t
val gamma2 : t
val gamma3 : t
val gamma5 : t
val gamma : t array
val cc : t
val neg : t -> t
val add : t -> t -> t
val sub : t -> t -> t
val mul : t -> t -> t
val times : qc -> t -> t
val transpose : t -> t
val adjoint : t -> t
val conj : t -> t
val product : t list -> t
val pp : Format.formatter -> t -> unit
val test_suite : OUnit.test
end
(* \thocwmodulesubsection{Matrices with complex rational entries} *)
module Q = Algebra.Q
module QC = Algebra.QC
type complex_rational = QC.t
let zero = QC.null
let one = QC.unit
let minus_one = QC.neg one
let i = QC.make Q.null Q.unit
let minus_i = QC.conj i
type matrix = complex_rational array array
(* \thocwmodulesubsection{Dirac $\gamma$-matrices} *)
module type R =
sig
type qc = complex_rational
type t = matrix
val gamma0 : t
val gamma1 : t
val gamma2 : t
val gamma3 : t
val gamma5 : t
val cc : t
val cc_is_i_gamma2_gamma_0 : bool
end
module Make (R : R) : T =
struct
type qc = complex_rational
type t = matrix
let zero = zero
let one = one
let minus_one = minus_one
let i = i
let minus_i = minus_i
let null =
[| [| zero; zero; zero; zero |];
[| zero; zero; zero; zero |];
[| zero; zero; zero; zero |];
[| zero; zero; zero; zero |] |]
let unit =
[| [| one; zero; zero; zero |];
[| zero; one; zero; zero |];
[| zero; zero; one; zero |];
[| zero; zero; zero; one |] |]
let gamma0 = R.gamma0
let gamma1 = R.gamma1
let gamma2 = R.gamma2
let gamma3 = R.gamma3
let gamma5 = R.gamma5
let gamma = [| gamma0; gamma1; gamma2; gamma3 |]
let cc = R.cc
let neg g =
let g' = Array.make_matrix 4 4 zero in
for i = 0 to 3 do
for j = 0 to 3 do
g'.(i).(j) <- QC.neg g.(i).(j)
done
done;
g'
let add g1 g2 =
let g12 = Array.make_matrix 4 4 zero in
for i = 0 to 3 do
for j = 0 to 3 do
g12.(i).(j) <- QC.add g1.(i).(j) g2.(i).(j)
done
done;
g12
let sub g1 g2 =
let g12 = Array.make_matrix 4 4 zero in
for i = 0 to 3 do
for j = 0 to 3 do
g12.(i).(j) <- QC.sub g1.(i).(j) g2.(i).(j)
done
done;
g12
let mul g1 g2 =
let g12 = Array.make_matrix 4 4 zero in
for i = 0 to 3 do
for k = 0 to 3 do
for j = 0 to 3 do
g12.(i).(k) <- QC.add g12.(i).(k) (QC.mul g1.(i).(j) g2.(j).(k))
done
done
done;
g12
let times q g =
let g' = Array.make_matrix 4 4 zero in
for i = 0 to 3 do
for j = 0 to 3 do
g'.(i).(j) <- QC.mul q g.(i).(j)
done
done;
g'
let transpose g =
let g' = Array.make_matrix 4 4 zero in
for i = 0 to 3 do
for j = 0 to 3 do
g'.(i).(j) <- g.(j).(i)
done
done;
g'
let adjoint g =
let g' = Array.make_matrix 4 4 zero in
for i = 0 to 3 do
for j = 0 to 3 do
g'.(i).(j) <- QC.conj g.(j).(i)
done
done;
g'
let conj g =
let g' = Array.make_matrix 4 4 zero in
for i = 0 to 3 do
for j = 0 to 3 do
g'.(i).(j) <- QC.conj g.(i).(j)
done
done;
g'
let product glist =
List.fold_right mul glist unit
let pp fmt g =
let pp_row i =
for j = 0 to 3 do
Format.fprintf fmt " %8s" (QC.to_string g.(i).(j))
done in
Format.fprintf fmt "\n /";
pp_row 0;
Format.fprintf fmt " \\\n";
for i = 1 to 2 do
Format.fprintf fmt " |";
pp_row i;
Format.fprintf fmt " |\n"
done;
Format.fprintf fmt " \\";
pp_row 3;
Format.fprintf fmt " /\n"
open OUnit
let two = QC.make (Q.make 2 1) Q.null
let half = QC.make (Q.make 1 2) Q.null
let two_unit = times two unit
let ac_lhs mu nu =
add (mul gamma.(mu) gamma.(nu)) (mul gamma.(nu) gamma.(mu))
let ac_rhs mu nu =
if mu = nu then
if mu = 0 then
two_unit
else
neg two_unit
else
null
let test_ac mu nu =
(ac_lhs mu nu) = (ac_rhs mu nu)
let ac_lhs_all =
let lhs = Array.make_matrix 4 4 null in
for mu = 0 to 3 do
for nu = 0 to 3 do
lhs.(mu).(nu) <- ac_lhs mu nu
done
done;
lhs
let ac_rhs_all =
let rhs = Array.make_matrix 4 4 null in
for mu = 0 to 3 do
for nu = 0 to 3 do
rhs.(mu).(nu) <- ac_rhs mu nu
done
done;
rhs
let dump2 lhs rhs =
for i = 0 to 3 do
for j = 0 to 3 do
Printf.printf
" i = %d, j =%d: %s + %s*I | %s + %s*I\n"
i j
- (Q.to_string (QC.real lhs.(i).(j)))
- (Q.to_string (QC.imag lhs.(i).(j)))
- (Q.to_string (QC.real rhs.(i).(j)))
- (Q.to_string (QC.imag rhs.(i).(j)))
+ (Q.to_string (QC.re lhs.(i).(j)))
+ (Q.to_string (QC.im lhs.(i).(j)))
+ (Q.to_string (QC.re rhs.(i).(j)))
+ (Q.to_string (QC.im rhs.(i).(j)))
done
done
let dump2_all lhs rhs =
for mu = 0 to 3 do
for nu = 0 to 3 do
Printf.printf "mu = %d, nu =%d: \n" mu nu;
dump2 lhs.(mu).(nu) rhs.(mu).(nu)
done
done
let anticommute =
"anticommutation relations" >::
(fun () ->
assert_bool
""
(if ac_lhs_all = ac_rhs_all then
true
else
begin
dump2_all ac_lhs_all ac_rhs_all;
false
end))
let equal_or_dump2 lhs rhs =
if lhs = rhs then
true
else
begin
dump2 lhs rhs;
false
end
let gamma5_def =
"gamma5" >::
(fun () ->
assert_bool
"definition"
(equal_or_dump2
gamma5
(times i (product [gamma0; gamma1; gamma2; gamma3]))))
let self_adjoint =
"(anti)selfadjointness" >:::
[ "gamma0" >::
(fun () ->
assert_bool "self" (equal_or_dump2 gamma0 (adjoint gamma0)));
"gamma1" >::
(fun () ->
assert_bool "anti" (equal_or_dump2 gamma1 (neg (adjoint gamma1))));
"gamma2" >::
(fun () ->
assert_bool "anti" (equal_or_dump2 gamma2 (neg (adjoint gamma2))));
"gamma3" >::
(fun () ->
assert_bool "anti" (equal_or_dump2 gamma3 (neg (adjoint gamma3))));
"gamma5" >::
(fun () ->
assert_bool "self" (equal_or_dump2 gamma5 (adjoint gamma5))) ]
(* $C^2=-\mathbf{1}$ is \emph{not} true in all realizations, but
we assume it at several points in [UFO_Lorentz]. Therefore we
must test it here for all realizations that are implemented. *)
let cc_inv = neg cc
(* Verify that $\Gamma^T= - C\Gamma C^{-1}$ using the actual
matrix transpose: *)
let cc_gamma g =
equal_or_dump2 (neg (transpose g)) (product [cc; g; cc_inv])
(* Of course, $C=\ii\gamma^2\gamma^0$ is also not true in \emph{all}
realizations. But it is true in the chiral representation
used here and we can test it. *)
let charge_conjugation =
"charge conjugation" >:::
[ "inverse" >::
(fun () ->
assert_bool "" (equal_or_dump2 (mul cc cc_inv) unit));
"gamma0" >:: (fun () -> assert_bool "" (cc_gamma gamma0));
"gamma1" >:: (fun () -> assert_bool "" (cc_gamma gamma1));
"gamma2" >:: (fun () -> assert_bool "" (cc_gamma gamma2));
"gamma3" >:: (fun () -> assert_bool "" (cc_gamma gamma3));
"gamma5" >::
(fun () ->
assert_bool "" (equal_or_dump2 (transpose gamma5)
(product [cc; gamma5; cc_inv])));
"=i*g2*g0" >::
(fun () ->
skip_if (not R.cc_is_i_gamma2_gamma_0)
"representation dependence";
assert_bool "" (equal_or_dump2 cc (times i (mul gamma2 gamma0))))
]
let test_suite =
"Dirac Matrices" >:::
[anticommute;
gamma5_def;
self_adjoint;
charge_conjugation]
end
module Chiral_R : R =
struct
type qc = complex_rational
type t = matrix
let gamma0 =
[| [| zero; zero; one; zero |];
[| zero; zero; zero; one |];
[| one; zero; zero; zero |];
[| zero; one; zero; zero |] |]
let gamma1 =
[| [| zero; zero; zero; one |];
[| zero; zero; one; zero |];
[| zero; minus_one; zero; zero |];
[| minus_one; zero; zero; zero |] |]
let gamma2 =
[| [| zero; zero; zero; minus_i |];
[| zero; zero; i; zero |];
[| zero; i; zero; zero |];
[| minus_i; zero; zero; zero |] |]
let gamma3 =
[| [| zero; zero; one; zero |];
[| zero; zero; zero; minus_one |];
[| minus_one; zero; zero; zero |];
[| zero; one; zero; zero |] |]
let gamma5 =
[| [| minus_one; zero; zero; zero |];
[| zero; minus_one; zero; zero |];
[| zero; zero; one; zero |];
[| zero; zero; zero; one |] |]
let cc =
[| [| zero; one; zero; zero |];
[| minus_one; zero; zero; zero |];
[| zero; zero; zero; minus_one |];
[| zero; zero; one; zero |] |]
let cc_is_i_gamma2_gamma_0 = true
end
module Dirac_R : R =
struct
type qc = complex_rational
type t = matrix
let gamma0 =
[| [| one; zero; zero; zero |];
[| zero; one; zero; zero |];
[| zero; zero; minus_one; zero |];
[| zero; zero; zero; minus_one |] |]
let gamma1 = Chiral_R.gamma1
let gamma2 = Chiral_R.gamma2
let gamma3 = Chiral_R.gamma3
let gamma5 =
[| [| zero; zero; one; zero |];
[| zero; zero; zero; one |];
[| one; zero; zero; zero |];
[| zero; one; zero; zero |] |]
let cc =
[| [| zero; zero; zero; minus_one |];
[| zero; zero; one; zero |];
[| zero; minus_one; zero; zero |];
[| one; zero; zero; zero |] |]
let cc_is_i_gamma2_gamma_0 = true
end
module Majorana_R : R =
struct
type qc = complex_rational
type t = matrix
let gamma0 =
[| [| zero; zero; zero; minus_i |];
[| zero; zero; i; zero |];
[| zero; minus_i; zero; zero |];
[| i; zero; zero; zero |] |]
let gamma1 =
[| [| i; zero; zero; zero |];
[| zero; minus_i; zero; zero |];
[| zero; zero; i; zero |];
[| zero; zero; zero; minus_i |] |]
let gamma2 =
[| [| zero; zero; zero; i |];
[| zero; zero; minus_i; zero |];
[| zero; minus_i; zero; zero |];
[| i; zero; zero; zero |] |]
let gamma3 =
[| [| zero; minus_i; zero; zero |];
[| minus_i; zero; zero; zero |];
[| zero; zero; zero; minus_i |];
[| zero; zero; minus_i; zero |] |]
let gamma5 =
[| [| zero; minus_i; zero; zero |];
[| i; zero; zero; zero |];
[| zero; zero; zero; i |];
[| zero; zero; minus_i; zero |] |]
let cc =
[| [| zero; zero; zero; minus_one |];
[| zero; zero; one; zero |];
[| zero; minus_one; zero; zero |];
[| one; zero; zero; zero |] |]
let cc_is_i_gamma2_gamma_0 = false
end
module Chiral = Make (Chiral_R)
module Dirac = Make (Dirac_R)
module Majorana = Make (Majorana_R)
Index: trunk/omega/src/UFOx_syntax.ml
===================================================================
--- trunk/omega/src/UFOx_syntax.ml (revision 8899)
+++ trunk/omega/src/UFOx_syntax.ml (revision 8900)
@@ -1,103 +1,107 @@
(* vertex_syntax.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
(* \thocwmodulesection{Abstract Syntax} *)
exception Syntax_Error of string * Lexing.position * Lexing.position
type expr =
| Integer of int
| Float of float
| Variable of string
| Quoted of string
+ | Young_Tableau of int Young.tableau
| Sum of expr * expr
| Difference of expr * expr
| Product of expr * expr
| Quotient of expr * expr
| Power of expr * expr
| Application of string * expr list
let integer i =
Integer i
let float x =
Float x
let variable s =
Variable s
let quoted s =
Quoted s
+let young_tableau y =
+ Young_Tableau y
+
let add e1 e2 =
Sum (e1, e2)
let subtract e1 e2 =
Difference (e1, e2)
(* This smart constructor is required since we parse negative
numbers as unary minus applied to a positive number.
[UFOx.Lorentz_Atom'.of_expr] and [UFOx.Color_Atom'.of_expr]
expect negative numbers as summation
indices and not expressions. Strictly speaking,
we only need the case [e1 = Integer (-1)] for this, but the
rest is natural.
There used to be a special rule in the grammar, but this
cause reduce/reduce conflicts, that harmless, but annoying. *)
let multiply e1 e2 =
match e1, e2 with
| Integer i1, Integer i2 -> Integer (i1 * i2)
| Integer i, Float x | Float x, Integer i -> Float (float_of_int i *. x)
| Float x1, Float x2 -> Float (x1 *. x2)
| e1, e2 -> Product (e1, e2)
let divide e1 e2 =
Quotient (e1, e2)
-
+
let power e p =
Power (e, p)
let apply f args =
Application (f, args)
module CSet = Sets.String_Caseless
let rec variables = function
- | Integer _ | Float _ | Quoted _ -> CSet.empty
+ | Integer _ | Float _ | Quoted _ | Young_Tableau _ -> CSet.empty
| Variable name -> CSet.singleton name
| Sum (e1, e2) | Difference (e1, e2)
| Product (e1, e2) | Quotient (e1, e2)
| Power (e1, e2) -> CSet.union (variables e1) (variables e2)
| Application (_, elist) ->
List.fold_left CSet.union CSet.empty (List.map variables elist)
let rec functions = function
- | Integer _ | Float _ | Variable _ | Quoted _ -> CSet.empty
+ | Integer _ | Float _ | Variable _ | Quoted _ | Young_Tableau _ -> CSet.empty
| Sum (e1, e2) | Difference (e1, e2)
| Product (e1, e2) | Quotient (e1, e2)
| Power (e1, e2) -> CSet.union (functions e1) (functions e2)
| Application (f, elist) ->
List.fold_left CSet.union (CSet.singleton f) (List.map functions elist)
Index: trunk/omega/src/birdtracks.ml
===================================================================
--- trunk/omega/src/birdtracks.ml (revision 0)
+++ trunk/omega/src/birdtracks.ml (revision 8900)
@@ -0,0 +1,794 @@
+(* birdtracks.ml --
+
+ Copyright (C) 2022-2023 by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+ with contributions from
+ Christian Speckner <cnspeckn@googlemail.com>
+
+ WHIZARD is free software; you can redistribute it and/or modify it
+ under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ WHIZARD is distributed in the hope that it will be useful, but
+ WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
+
+(* \thocwmodulesection{Types} *)
+
+module QC = Algebra.QC
+module L = Algebra.Laurent
+module A = Arrow
+open A.Infix
+
+(* There can be one or more $\epsilon$ or $\bar\epsilon$, but
+ not both at the same time. *)
+
+(* I wanted to use a GADT with Peano numerals to track the number
+ of $\epsilon$ and $\bar\epsilon$ in the type system. However,
+ I would have needed to implement a ``multiplication'' function
+ of the type ['n1 term -> 'n2 term -> ('n1 + 'n2) term]
+ that I have not been able to implement using Peano numerals for
+ the type variables ['n1] and ['n2], due to the lack of an
+ addition operator for Peano numerals in the type system.
+
+Therefore I will use normal lists, sacrificing some type safety. *)
+
+type 'a aterm = { coeff : L.t; arrows : 'a list }
+type ('a, 'e) eterm = 'a aterm * 'e NEList.t
+type ('a, 'b) bterm = 'a aterm * 'b NEList.t
+
+type ('a, 'e, 'b) term =
+ | Arrows of 'a aterm
+ | Epsilons of ('a, 'e) eterm
+ | Epsilon_Bars of ('a, 'b) bterm
+
+(* \begin{dubious}
+ Having already added type annotations for polymorphic
+ recursion, I could use a simple GADT instead of an ADT at the toplevel, trying
+ to maintain some unboxing potential:
+
+ [ type ('a, 'e, 'b) term =
+ | Arrows : 'a aterm -> ('a, 'e, 'b) term
+ | Epsilons : ('a, 'e) eterm -> ('a, 'e, 'b) term
+ | Epsilon_Bars : ('a, 'b) bterm -> ('a, 'e, 'b) term ]
+
+ but it is not obvious that this produces a real performance benefit.
+ \end{dubious} *)
+
+type afree = A.free aterm
+type efree = (A.free, A.free_eps) eterm
+type bfree = (A.free, A.free_eps_bar) bterm
+type free = (A.free, A.free_eps, A.free_eps_bar) term
+
+type afactor = A.factor aterm
+type efactor = (A.factor, A.factor_eps) eterm
+type bfactor = (A.factor, A.factor_eps_bar) bterm
+type factor = (A.factor, A.factor_eps, A.factor_eps_bar) term
+
+type t = free list
+
+(* \thocwmodulesection{Functions} *)
+
+let tips_and_tails_of_aterm aterm =
+ List.fold_left
+ (fun (tips, tails) arrow ->
+ (List.rev_append (A.tips arrow) tips,
+ List.rev_append (A.tails arrow) tails))
+ ([], []) aterm.arrows
+
+let tips_and_tails_raw : free -> A.tip list * A.tail list = function
+ | Arrows aterm -> tips_and_tails_of_aterm aterm
+ | Epsilons (aterm, epsilons) ->
+ let tips, tails = tips_and_tails_of_aterm aterm in
+ (List.concat (tips :: NEList.to_list epsilons), tails)
+ | Epsilon_Bars (aterm, epsilon_bars) ->
+ let tips, tails = tips_and_tails_of_aterm aterm in
+ (tips, List.concat (tails :: NEList.to_list epsilon_bars))
+
+let tips_and_tails term =
+ let tips, tails = tips_and_tails_raw term in
+ (List.sort compare tips, List.sort compare tails)
+
+(* Expressions *)
+let const coeff = [ Arrows { coeff; arrows = [] } ]
+let ints pairs = const (L.ints pairs)
+let null = const L.null
+let fraction n = const (L.fraction n)
+let one = const (L.int 1)
+let two = const (L.int 2)
+let minus = const (L.int (-1))
+let int n = const (L.int n)
+let nc = const (L.nc 1)
+let over_nc = const (L.ints [(1, -1)])
+let imag = const (L.imag 1)
+
+module AMap = Pmap.Tree
+
+let psort alist = List.sort compare alist
+let ne_psort alist = NEList.sort compare alist
+
+let find_term_opt term map =
+ AMap.find_opt compare term map
+
+let map_aterm fc fa aterm =
+ { coeff = fc aterm.coeff; arrows = fa aterm.arrows }
+
+let map_term fc fa fe fb = function
+ | Arrows aterm -> Arrows (map_aterm fc fa aterm)
+ | Epsilons (aterm, elist) -> Epsilons (map_aterm fc fa aterm, fe elist)
+ | Epsilon_Bars (aterm, blist) -> Epsilon_Bars (map_aterm fc fa aterm, fb blist)
+
+let map_term_deep fc fa fe fb term =
+ map_term fc (List.map fa) (NEList.map fe) (NEList.map fb) term
+
+let canonicalize_aterm term =
+ map_aterm Fun.id psort term
+
+(* \begin{dubious}
+ We're \emph{not yet} canonicalizing the $\epsilon$ and
+ $\bar\epsilon$ themselves. This could be done, if
+ necessary, using [Combinatorics.sort_signed] to keep track of
+ the signs. While we're debugging, it could be beneficial to
+ keep the indices where they are.
+ \end{dubious} *)
+
+let canonicalize_term : type a e b. (a, e, b) term -> (a, e, b) term =
+ fun term ->
+ map_term Fun.id psort ne_psort ne_psort term
+
+let split_coeff : type a e b. (a, e, b) term -> L.t * (a, e, b) term = function
+ | Arrows aterm -> (aterm.coeff, Arrows { aterm with coeff = L.int 1 })
+ | Epsilons (aterm, epsilons) ->
+ (aterm.coeff, Epsilons ({ aterm with coeff = L.int 1 }, epsilons))
+ | Epsilon_Bars (aterm, epsilon_bars) ->
+ (aterm.coeff, Epsilon_Bars ({ aterm with coeff = L.int 1 }, epsilon_bars))
+
+let inject_coeff : type a e b. L.t -> (a, e, b) term -> (a, e, b) term =
+ fun coeff -> map_term (fun _ -> coeff) Fun.id Fun.id Fun.id
+
+(* \begin{dubious}
+ Note that the final result
+ must be a homogeneous list with all elements containing the same
+ number of $\epsilon$ and $\bar\epsilon$, because otherwise the number
+ of incoming and outgoing color lince would not match.
+
+ Nevertheless, we might have to work very hard to avoid too much code
+ duplication.
+ \end{dubious} *)
+
+let canonicalize : type a e b. (a, e, b) term list -> (a, e, b) term list =
+ fun terms ->
+ let map =
+ List.fold_left
+ (fun acc term ->
+ let coeff, term = split_coeff (canonicalize_term term) in
+ if L.is_null coeff then
+ acc
+ else
+ match find_term_opt term acc with
+ | None -> AMap.add compare term coeff acc
+ | Some coeff' ->
+ let coeff'' = L.add coeff coeff' in
+ if L.is_null coeff'' then
+ AMap.remove compare term acc
+ else
+ AMap.add compare term coeff'' acc)
+ AMap.empty terms in
+ if AMap.is_empty map then
+ []
+ else
+ AMap.fold (fun term coeff acc -> inject_coeff coeff term :: acc) map []
+
+let number v =
+ match canonicalize v with
+ | [] -> Some L.null
+ | [Arrows { coeff; arrows = [] }] -> Some coeff
+ | _ -> None
+
+let is_null v =
+ match canonicalize v with
+ | [] -> true
+ | _ -> false
+
+let is_unit v =
+ match canonicalize v with
+ | [Arrows { coeff; arrows = [] }] -> coeff = L.unit
+ | _ -> false
+
+let with_nc nc t =
+ let substitute c = L.const (L.eval (QC.int nc) c) in
+ canonicalize (List.map (map_term substitute Fun.id Fun.id Fun.id) t)
+
+let aterm_to_string f term =
+ match term.arrows with
+ | [] -> Printf.sprintf "(%s)" (L.to_string "N" term.coeff)
+ | arrows ->
+ Printf.sprintf
+ "(%s) * %s"
+ (L.to_string "N" term.coeff) (ThoList.to_string f arrows)
+
+let to_string1_aux fa fe fb = function
+ | Arrows aterm -> aterm_to_string fa aterm
+ | Epsilons (aterm, epsilons) ->
+ aterm_to_string fa aterm ^ " * " ^ ThoList.to_string fe (NEList.to_list epsilons)
+ | Epsilon_Bars (aterm, epsilon_bars) ->
+ aterm_to_string fa aterm ^ " * " ^ ThoList.to_string fb (NEList.to_list epsilon_bars)
+
+let to_string1 term =
+ to_string1_aux A.free_to_string A.free_eps_to_string A.free_eps_bar_to_string term
+
+let to_string_raw terms =
+ ThoList.to_string to_string1 terms
+
+let to_string terms =
+ to_string_raw (canonicalize terms)
+
+(*i
+ let trivial terms =
+ let result = trivial terms in
+ Printf.eprintf
+ "trivial %s -> %b\n"
+ (to_string terms)
+ result;
+ trivial terms
+i*)
+
+let pp fmt v =
+ Format.fprintf fmt "%s" (to_string v)
+
+let relocate1 f term =
+ map_term_deep Fun.id (A.relocate f) (List.map (A.relocate_tip f)) (List.map (A.relocate_tail f)) term
+
+let relocate f = List.map (relocate1 f)
+
+let rev_aterm aterm =
+ { aterm with arrows = List.map A.rev aterm.arrows }
+
+let rev1 = function
+ | Arrows aterm -> Arrows (rev_aterm aterm)
+ | Epsilons (aterm, elist) -> Epsilon_Bars (rev_aterm aterm, NEList.map A.rev_eps elist)
+ | Epsilon_Bars (aterm, blist) -> Epsilons (rev_aterm aterm, NEList.map A.rev_eps_bar blist)
+
+let rev = List.map rev1
+
+let of_afactor aterm =
+ map_aterm Fun.id (List.map A.of_factor) aterm
+
+let of_factor term =
+ map_term_deep Fun.id A.of_factor A.of_factor_eps A.of_factor_eps_bar term
+
+let to_left_factor is_sum term =
+ map_term_deep Fun.id
+ (A.to_left_factor is_sum)
+ (A.to_left_factor_eps is_sum)
+ (A.to_left_factor_eps_bar is_sum)
+ term
+
+let to_right_factor is_sum term =
+ map_term_deep Fun.id
+ (A.to_right_factor is_sum)
+ (A.to_right_factor_eps is_sum)
+ (A.to_right_factor_eps_bar is_sum)
+ term
+
+(* We start with the simply recursive evaluation functions,
+ leaving the the more complicated mutually recursive
+ functions for later. *)
+
+(* Add one [arrow] to a list of arrows, updating [coeff]
+ if necessary. Accumulate already processed arrows in [seen].
+ Returns [None] if there is a mismatch (a gluon meeting
+ a ghost) and [Some afactor] containing a coefficient and a
+ list of arrows otherwise. *)
+
+(* We assume that the trivial cases of no summation indices
+ and the arrow looping back to itself have already been filtered
+ out. *)
+
+(* \label{pg:add_arrow} *)
+
+let rec add_arrow_to_arrows_list' coeff seen arrow = function
+ | [] -> (* visited all [arrows]: no opportunities for further matches *)
+ Some ({ coeff; arrows = arrow :: seen })
+ | arrow' :: arrows' ->
+ begin match A.merge_arrow_arrow arrow arrow' with
+ | A.Mismatch ->
+ None
+ | A.Ghost_Match -> (* replace matching ghosts by $-1/N_C$ *)
+ Some ({ coeff = L.mul (L.over_nc (-1)) coeff;
+ arrows = List.rev_append seen arrows' })
+ | A.Loop_Match -> (* replace a loop by $N_C$ *)
+ Some ({ coeff = L.mul (L.nc 1) coeff;
+ arrows = List.rev_append seen arrows' })
+ | A.Match arrow'' -> (* two arrows have been merged into one *)
+ if A.is_free arrow'' then (* no opportunities for further matches *)
+ Some ({ coeff; arrows = arrow'' :: List.rev_append seen arrows' })
+ else (* the new [arrow''] ist not yet saturated, try again: *)
+ add_arrow_to_arrows_list' coeff seen arrow'' arrows'
+ | A.No_Match -> (* recurse to the remaining arrows *)
+ add_arrow_to_arrows_list' coeff (arrow' :: seen) arrow arrows'
+ end
+
+let add_arrow_to_arrows_list coeff arrow arrows =
+ add_arrow_to_arrows_list' coeff [] arrow arrows
+
+(* Similarly, add one [arrow] to a list of $\epsilon$ and
+ accumulate already processed arrows in [seen].
+ Returns [[]] if there is no match. Note that there is
+ never the need to update the coefficient and that only
+ the tail of the [arrow] can match. *)
+
+let rec add_arrow_to_epsilon_list' seen arrow = function
+ | [] -> []
+ | epsilon :: epsilons ->
+ begin match A.merge_arrow_eps arrow epsilon with
+ | A.Mismatch_Eps -> []
+ | A.Match_Eps epsilon' -> List.rev_append seen (epsilon' :: epsilons)
+ | A.No_Match_Eps -> add_arrow_to_epsilon_list' (epsilon :: seen) arrow epsilons
+ end
+
+let add_arrow_to_epsilon_list arrow epsilons =
+ add_arrow_to_epsilon_list' [] arrow epsilons
+
+(* Same preocedure for adding one [arrow] to a list of $\bar\epsilon$. *)
+
+let rec add_arrow_to_epsilon_bar_list' seen arrow = function
+ | [] -> []
+ | epsilon_bar :: epsilon_bars ->
+ begin match A.merge_arrow_eps_bar arrow epsilon_bar with
+ | A.Mismatch_Eps -> []
+ | A.Match_Eps epsilon_bar' -> List.rev_append seen (epsilon_bar' :: epsilon_bars)
+ | A.No_Match_Eps -> add_arrow_to_epsilon_bar_list' (epsilon_bar :: seen) arrow epsilon_bars
+ end
+
+let add_arrow_to_epsilon_bar_list arrow epsilon_bars =
+ add_arrow_to_epsilon_bar_list' [] arrow epsilon_bars
+
+(* Avoid a recursion, if there is no summation index in [arrow].
+ Likewise, if [arrow] loops back to itself, just replace it by
+ a factor of~$N_C$. *)
+
+let add_arrow_to_aterm_trivial : A.factor -> afactor -> afactor option =
+ fun arrow term ->
+ if A.is_free arrow then
+ Some ({ coeff = term.coeff; arrows = arrow :: term.arrows })
+ else if A.is_tadpole arrow then
+ Some ({ coeff = L.mul (L.nc 1) term.coeff; arrows = term.arrows })
+ else
+ None
+
+(* Straightforwardly add an arrow or an arrow list to a term
+ containing no $\epsilon$ or $\bar\epsilon$, using the functions
+ implemented above. *)
+
+let add_arrow_to_aterm : A.factor -> afactor -> afactor option =
+ fun arrow term ->
+ match add_arrow_to_aterm_trivial arrow term with
+ | None -> add_arrow_to_arrows_list term.coeff arrow term.arrows
+ | term_opt -> term_opt
+
+let add_arrow_list_to_aterm : A.factor list -> afactor -> afactor option =
+ fun arrows term ->
+ ThoList.fold_left_opt (Fun.flip add_arrow_to_aterm) term arrows
+
+(* Adding an arrow or an arrow list to a term containing
+ $\epsilon$ or $\bar\epsilon$ is not more complicated, we only
+ have to make two attempts. *)
+
+(* \begin{dubious}
+ Caveat: if the arrow matches one of the $\epsilon$s and
+ this $\epsilon$ has a tip appearing among the remaining
+ tips of this $\epsilon$, the result should be set to zero
+ explicitelty. But such expressions are illegal anyway!
+ \end{dubious} *)
+
+let add_arrow_to_eterm : A.factor -> efactor -> efactor option =
+ fun arrow (aterm, epsilons) ->
+ match add_arrow_to_aterm_trivial arrow aterm with
+ | Some aterm -> Some (aterm, epsilons)
+ | None ->
+ begin match add_arrow_to_epsilon_list arrow (NEList.to_list epsilons) with
+ | [] ->
+ begin match add_arrow_to_arrows_list aterm.coeff arrow aterm.arrows with
+ | None -> None
+ | Some aterm -> Some (aterm, epsilons)
+ end
+ | epsilon :: epsilons -> Some (aterm, NEList.make epsilon epsilons)
+ end
+
+let add_arrow_list_to_eterm : A.factor list -> efactor -> efactor option =
+ fun arrows term ->
+ ThoList.fold_left_opt (Fun.flip add_arrow_to_eterm) term arrows
+
+let add_arrow_to_bterm : A.factor -> bfactor -> bfactor option =
+ fun arrow (aterm, epsilon_bars) ->
+ match add_arrow_to_aterm_trivial arrow aterm with
+ | Some aterm -> Some (aterm, epsilon_bars)
+ | None ->
+ begin match add_arrow_to_epsilon_bar_list arrow (NEList.to_list epsilon_bars) with
+ | [] ->
+ begin match add_arrow_to_arrows_list aterm.coeff arrow aterm.arrows with
+ | None -> None
+ | Some aterm -> Some (aterm, epsilon_bars)
+ end
+ | epsilon_bar :: epsilon_bars -> Some (aterm, NEList.make epsilon_bar epsilon_bars)
+ end
+
+let add_arrow_list_to_bterm : A.factor list -> bfactor -> bfactor option =
+ fun arrows term ->
+ ThoList.fold_left_opt (Fun.flip add_arrow_to_bterm) term arrows
+
+(* Adding an $\epsilon$ to a term containing $\epsilon$s is trivial,
+ if there are no summation indices. Otherwise, we add the arrows
+ back in to find matches.
+ \begin{dubious}
+ Here's potential for optimization, since the arrows can only
+ match the new $\epsilon$.
+ \end{dubious} *)
+
+let add_epsilon_to_eterm : A.factor_eps -> efactor -> efactor option =
+ fun epsilon (aterm, epsilons) ->
+ if A.is_free_eps epsilon then
+ Some (aterm, NEList.cons epsilon epsilons)
+ else
+ let coeff = { coeff = aterm.coeff; arrows = []} in
+ add_arrow_list_to_eterm aterm.arrows (coeff, NEList.cons epsilon epsilons)
+
+let add_epsilon_list_to_eterm : A.factor_eps list -> efactor -> efactor option =
+ fun epsilons eterm ->
+ ThoList.fold_left_opt (Fun.flip add_epsilon_to_eterm) eterm epsilons
+
+(* Once more for $\bar\epsilon$. *)
+
+let add_epsilon_bar_to_bterm : A.factor_eps_bar -> bfactor -> bfactor option =
+ fun epsilon_bar (aterm, epsilon_bars) ->
+ if A.is_free_eps_bar epsilon_bar then
+ Some (aterm, NEList.cons epsilon_bar epsilon_bars)
+ else
+ let coeff = { coeff = aterm.coeff; arrows = []} in
+ add_arrow_list_to_bterm aterm.arrows (coeff, NEList.cons epsilon_bar epsilon_bars)
+
+let add_epsilon_bar_list_to_bterm : A.factor_eps_bar list -> bfactor -> bfactor option =
+ fun epsilon_bars bterm ->
+ ThoList.fold_left_opt (Fun.flip add_epsilon_bar_to_bterm) bterm epsilon_bars
+
+(* Here we simply have to select the correct function. *)
+
+let add_arrow_to_term : A.factor -> factor -> factor option =
+ fun arrow -> function
+ | Arrows aterm ->
+ Option.map (fun a -> Arrows a) (add_arrow_to_aterm arrow aterm)
+ | Epsilons eterm ->
+ Option.map (fun e -> Epsilons e) (add_arrow_to_eterm arrow eterm)
+ | Epsilon_Bars bterm ->
+ Option.map (fun b -> Epsilon_Bars b) (add_arrow_to_bterm arrow bterm)
+
+let add_arrow_list_to_term : A.factor list -> factor -> factor option =
+ fun arrows term ->
+ ThoList.fold_left_opt (Fun.flip add_arrow_to_term) term arrows
+
+let scale_aterm : L.t -> afactor -> afactor =
+ fun coeff aterm ->
+ { coeff = L.mul coeff aterm.coeff; arrows = aterm.arrows}
+
+let scale_eterm : L.t -> efactor -> efactor =
+ fun coeff (aterm, epsilons) ->
+ (scale_aterm coeff aterm, epsilons)
+
+let scale_bterm : L.t -> bfactor -> bfactor =
+ fun coeff (aterm, epsilon_bars) ->
+ (scale_aterm coeff aterm, epsilon_bars)
+
+let scale_term : L.t -> factor -> factor =
+ fun coeff -> function
+ | Arrows aterm -> Arrows (scale_aterm coeff aterm)
+ | Epsilons eterm -> Epsilons (scale_eterm coeff eterm)
+ | Epsilon_Bars bterm -> Epsilon_Bars (scale_bterm coeff bterm)
+
+let aterm_times_aterm : afactor -> afactor -> afactor option =
+ fun aterm1 aterm2 ->
+ Option.map (scale_aterm aterm1.coeff) (add_arrow_list_to_aterm aterm1.arrows aterm2)
+
+(* Almost the same as [aterm_times_term] below, but the arguments
+ are exchanged an the result are [factor]s and not [free]. *)
+
+let term_times_aterm : factor -> afactor -> factor list =
+ fun term aterm ->
+ match add_arrow_list_to_term aterm.arrows term with
+ | None -> []
+ | Some factor -> [scale_term aterm.coeff factor]
+
+(* The return type is [factor list], because adding a product
+ of~$\epsilon$ and~$\bar\epsilon$ will produce a sum of terms and
+ the result can be a [afactor], [efactor] or [bfactor] depending on
+ the number of~$\epsilon$s and~$\bar\epsilon$s in the arguments. *)
+
+(* \begin{dubious}
+ Add more tests for multiple $\epsilon$ and $\bar\epsilon$!
+ I'm not yet convinced only from playing with the toplevel.
+ \end{dubious} *)
+
+(* \begin{dubious}
+ Calling [aterm_times_aterm] in each recursion step and
+ only using the last result ist wasteful. Find a better
+ way!
+ \end{dubious} *)
+
+(* \begin{dubious}
+ This would fail if one of [epsilons] or [epsilon_bars] is
+ empty (which does not happen). We could try to replace
+ the ['e list] in [type ('a, 'e) eterm] by a non empty list
+ type (and similarly for ['e list] in [type ('a, 'b) bterm].
+
+ But is it worth the effort? It probably enough
+ to hide the list in a [private] ADT that can be deconstructed,
+ but requires a smart constructor that requires at least one
+ element.
+ \end{dubious} *)
+
+let rec match_eterm_and_bterm : efactor -> bfactor -> factor list =
+ fun (aterm1, epsilons) (aterm2, epsilon_bars) ->
+ match NEList.snoc_opt epsilons, NEList.snoc_opt epsilon_bars with
+ | (epsilon, epsilons_opt), (epsilon_bar, epsilon_bars_opt) ->
+ begin match aterm_times_aterm aterm1 aterm2 with
+ | None -> []
+ | Some aterm ->
+ match A.merge_eps_eps_bar epsilon epsilon_bar with
+ | None -> []
+ | Some (even, odd) ->
+ let even = List.rev_map (fun arrows -> { coeff = L.unit; arrows }) even
+ and odd = List.rev_map (fun arrows -> { coeff = L.neg L.unit; arrows }) odd in
+ let terms =
+ match epsilons_opt, epsilon_bars_opt with
+ | None, None -> [Arrows aterm]
+ | Some epsilons, None-> [Epsilons (aterm, epsilons)]
+ | None, Some epsilon_bars-> [Epsilon_Bars (aterm, epsilon_bars)]
+ | Some epsilon, Some epsilon_bars ->
+ match_eterm_and_bterm (aterm1, epsilon) (aterm2, epsilon_bars) in
+ Product.fold2
+ (fun term aterm acc ->
+ List.rev_append (term_times_aterm term aterm) acc)
+ terms (List.rev_append even odd) []
+ end
+
+(* NB: we can reject the contributions with unsaturated summation indices
+ from Ghost contributions to~$T_a$ only \emph{after} adding all
+ arrows that might saturate an open index. *)
+
+(* Note that a negative index might be summed only
+ later in a sequence of binary products and must
+ therefore be treated as free in this product. Therefore,
+ we have to classify the indices as summation indices
+ \emph{not only} based on their sign, but in addition based on
+ whether they appear in both factors. Only then can we reject
+ surviving ghosts. *)
+
+module ESet =
+ Set.Make
+ (struct
+ type t = A.endpoint
+ let compare = compare
+ end)
+
+let negatives_arrows arrows acc =
+ List.fold_right (fun a -> List.fold_right ESet.add (A.negatives a)) arrows acc
+
+let negatives_eps epsilons acc =
+ NEList.fold_right
+ (fun e -> List.fold_right ESet.add (A.negatives_eps e))
+ epsilons acc
+
+let negatives_eps_bar epsilon_bars acc =
+ NEList.fold_right
+ (fun b -> List.fold_right ESet.add (A.negatives_eps_bar b))
+ epsilon_bars acc
+
+let negatives = function
+ | Arrows aterm -> negatives_arrows aterm.arrows ESet.empty
+ | Epsilons (aterm, epsilons) ->
+ negatives_eps epsilons (negatives_arrows aterm.arrows ESet.empty)
+ | Epsilon_Bars (aterm, epsilon_bars) ->
+ negatives_eps_bar epsilon_bars (negatives_arrows aterm.arrows ESet.empty)
+
+let aterm_times_term : afactor -> factor -> free list =
+ fun aterm term ->
+ match add_arrow_list_to_term aterm.arrows term with
+ | None -> []
+ | Some factor -> [of_factor (scale_term aterm.coeff factor)]
+
+let eterm_times_eterm : efactor -> efactor -> free list =
+ fun (aterm, epsilons) eterm ->
+ match add_epsilon_list_to_eterm (NEList.to_list epsilons) eterm with
+ | None -> []
+ | Some factor ->
+ begin match add_arrow_list_to_eterm aterm.arrows factor with
+ | None -> []
+ | Some factor -> [of_factor (Epsilons (scale_eterm aterm.coeff factor))]
+ end
+
+let bterm_times_bterm : bfactor -> bfactor -> free list =
+ fun (aterm, epsilon_bars) bterm ->
+ match add_epsilon_bar_list_to_bterm (NEList.to_list epsilon_bars) bterm with
+ | None -> []
+ | Some factor ->
+ begin match add_arrow_list_to_bterm aterm.arrows factor with
+ | None -> []
+ | Some factor -> [of_factor (Epsilon_Bars (scale_bterm aterm.coeff factor))]
+ end
+
+let eterm_times_bterm : efactor -> bfactor -> free list =
+ fun eterm bterm ->
+ List.map of_factor (match_eterm_and_bterm eterm bterm)
+
+let times1 term1 term2 =
+ let summations = ESet.inter (negatives term1) (negatives term2) in
+ let is_sum i = ESet.mem i summations in
+ match to_left_factor is_sum term1, to_right_factor is_sum term2 with
+ | Arrows aterm, factor | factor, Arrows aterm ->
+ aterm_times_term aterm factor
+ | Epsilons eterm1, Epsilons eterm2 ->
+ eterm_times_eterm eterm1 eterm2
+ | Epsilon_Bars bterm1, Epsilon_Bars bterm2 ->
+ bterm_times_bterm bterm1 bterm2
+ | Epsilons eterm, Epsilon_Bars bterm
+ | Epsilon_Bars bterm, Epsilons eterm ->
+ eterm_times_bterm eterm bterm
+
+let sum terms =
+ canonicalize (List.concat terms)
+
+let times term term' =
+ canonicalize
+ (Product.fold2
+ (fun x y -> List.rev_append (times1 x y))
+ term term' [])
+
+(* \begin{dubious}
+ Is that more efficient than the following implementation?
+ \end{dubious} *)
+
+(*i
+ let rec multiply1' acc = function
+ | [] -> [acc]
+ | factor :: factors ->
+ List.fold_right multiply1' (times1 acc factor) factors
+
+ let multiply1 = function
+ | [] -> [(L.unit, [])]
+ | [factor] -> [factor]
+ | factor :: factors -> multiply1' factor factors
+
+ let multiply terms =
+ canonicalize
+ (Product.fold (fun x -> List.rev_append (multiply1 x)) terms [])
+
+i*)
+(* \begin{dubious}
+ Isn't that the more straightforward implementation?
+ \end{dubious} *)
+
+let multiply = function
+ | [] -> []
+ | term :: terms ->
+ canonicalize (List.fold_left times term terms)
+
+let scale1 : type a e b. L.c -> (a, e, b) term -> (a, e, b) term =
+ fun q term ->
+ map_term (L.scale q) Fun.id Fun.id Fun.id term
+
+let scale q = List.map (scale1 q)
+
+let diff term1 term2 =
+ canonicalize (List.rev_append term1 (scale (QC.int (-1)) term2))
+
+module Infix =
+ struct
+ let ( +++ ) term term' = sum [term; term']
+ let ( --- ) = diff
+ let ( *** ) = times
+ end
+
+open Infix
+
+(* Compute $ \tr(r(T_a) r(T_b) r(T_c)) $. NB: this uses the
+ summation indices $-1$, $-2$ and $-3$. Therefore
+ it \emph{must not} appear unevaluated more than once in a product! *)
+let trace3 r a b c =
+ r a (-1) (-2) *** r b (-2) (-3) *** r c (-3) (-1)
+
+let f_of_rep r a b c =
+ minus *** imag *** (trace3 r a b c --- trace3 r a c b)
+
+(* $ d_{abc} = \tr(r(T_a) [r(T_b), r(T_c)]_+) $ *)
+let d_of_rep r a b c =
+ trace3 r a b c +++ trace3 r a c b
+
+(* \thocwmodulesection{Unit Tests} *)
+
+let vertices_equal v1 v2 =
+ is_null (v1 --- v2)
+
+let assert_zero_vertex v =
+ OUnit.assert_equal ~printer:to_string ~cmp:vertices_equal null v
+
+(* As an extra protection agains vacuous tests, we make
+ sure that the LHS does not vanish. *)
+let equal v1 v2 =
+ OUnit.assert_bool "LHS = 0" (not (is_null v1));
+ OUnit.assert_equal ~printer:to_string ~cmp:vertices_equal v1 v2
+
+module Test =
+ struct
+ open OUnit
+
+ let vertices_equal v1 v2 =
+ (canonicalize v1) = (canonicalize v2)
+
+ let eq v1 v2 =
+ assert_equal ~printer:to_string_raw ~cmp:vertices_equal v1 v2
+
+ let suite_times1 =
+ "times1" >:::
+ [ "merge two" >::
+ (fun () ->
+ eq
+ [Arrows { coeff = L.unit; arrows = 1 ==> 2 }]
+ (times1
+ (Arrows { coeff = L.unit; arrows = 1 ==> -1 })
+ (Arrows { coeff = L.unit; arrows = -1 ==> 2 })));
+
+ "merge two exchanged" >::
+ (fun () ->
+ eq
+ [Arrows { coeff = L.unit; arrows = 1 ==> 2 }]
+ (times1
+ (Arrows { coeff = L.unit; arrows = -1 ==> 2 })
+ (Arrows { coeff = L.unit; arrows = 1 ==> -1 })));
+
+ "ghost1" >::
+ (fun () ->
+ eq
+ [Arrows { coeff = L.over_nc (-1); arrows = 1 ==> 2 }]
+ (times1
+ (Arrows { coeff = L.unit; arrows = [-1 => 2; ?? (-3)] })
+ (Arrows { coeff = L.unit; arrows = [ 1 => -1; ?? (-3)] })));
+
+ "ghost2" >::
+ (fun () ->
+ eq
+ []
+ (times1
+ (Arrows { coeff = L.unit; arrows = [ 1 => -1; ?? (-3)] })
+ (Arrows { coeff = L.unit; arrows = [-1 => 2; -3 => -4; -4 => -3] })));
+
+ "ghost2 exchanged" >::
+ (fun () ->
+ eq
+ []
+ (times1
+ (Arrows { coeff = L.unit; arrows = [-1 => 2; -3 => -4; -4 => -3] })
+ (Arrows { coeff = L.unit; arrows = [ 1 => -1; ?? (-3)] }))) ]
+
+ let suite_canonicalize =
+ "canonicalize" >:::
+
+ [ ]
+
+ let suite =
+ "Birdtracks" >:::
+ [suite_times1;
+ suite_canonicalize]
+
+ let suite_long =
+ "Birdtracks long" >:::
+ []
+ end
Index: trunk/omega/src/Makefile.sources
===================================================================
--- trunk/omega/src/Makefile.sources (revision 8899)
+++ trunk/omega/src/Makefile.sources (revision 8900)
@@ -1,305 +1,323 @@
# Makefile.sources -- Makefile component for O'Mega
##
## Process Makefile.am with automake to include this file in Makefile.in
##
########################################################################
#
# Copyright (C) 1999-2023 by
# Wolfgang Kilian <kilian@physik.uni-siegen.de>
# Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
# Juergen Reuter <juergen.reuter@desy.de>
# 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.
#
########################################################################
##
## We define the source files in a separate file so that they can be
## include by Makefiles in multiple directories.
##
########################################################################
########################################################################
#
# O'Caml sources
#
########################################################################
#
# NB:
#
# * all modules MUST be given in the correct sequence for linking
#
# * foo.ml as a source file implies foo.mli as a source files
#
# * we must use ocamlc -i to generate *_lexer.mli from *_lexer.ml in
# order to treat *_lexer.ml like all other modules
#
# * automake conditionals are not available here, use
# autoconf substitutions that expand to '#' or ''
#
########################################################################
CASCADE_MLL = cascade_lexer.mll
CASCADE_MLY = cascade_parser.mly
CASCADE_MLD = $(CASCADE_MLL:.mll=.ml) $(CASCADE_MLY:.mly=.ml)
CASCADE_ML_PRIMARY = cascade_syntax.ml cascade.ml
CASCADE_ML = cascade_syntax.ml $(CASCADE_MLD) cascade.ml
+ORDERS_MLL = orders_lexer.mll
+ORDERS_MLY = orders_parser.mly
+ORDERS_MLD = $(ORDERS_MLL:.mll=.ml) $(ORDERS_MLY:.mly=.ml)
+ORDERS_ML_PRIMARY = orders_syntax.ml orders.ml
+ORDERS_ML = orders_syntax.ml $(ORDERS_MLD) orders.ml
+
VERTEX_MLL = vertex_lexer.mll
VERTEX_MLY = vertex_parser.mly
VERTEX_MLD = $(VERTEX_MLL:.mll=.ml) $(VERTEX_MLY:.mly=.ml)
VERTEX_ML_PRIMARY = vertex_syntax.ml vertex.ml
VERTEX_ML = vertex_syntax.ml $(VERTEX_MLD) vertex.ml
UFO_MLL = UFOx_lexer.mll UFO_lexer.mll
UFO_MLY = UFOx_parser.mly UFO_parser.mly
UFO_MLD = $(UFO_MLL:.mll=.ml) $(UFO_MLY:.mly=.ml)
UFO_ML_PRIMARY = UFO_tools.ml UFOx_syntax.ml UFOx.ml UFO_syntax.ml UFO_Lorentz.ml UFO_targets.ml UFO.ml
UFO_ML = UFO_tools.ml UFOx_syntax.ml UFO_syntax.ml $(UFO_MLD) UFOx.ml UFO_Lorentz.ml UFO_targets.ml UFO.ml
-OMEGA_MLL = $(CASCADE_MLL) $(VERTEX_MLL) $(UFO_MLL)
-OMEGA_MLY = $(CASCADE_MLY) $(VERTEX_MLY) $(UFO_MLY)
+OMEGA_MLL = $(CASCADE_MLL) $(ORDERS_MLL) $(VERTEX_MLL) $(UFO_MLL)
+OMEGA_MLY = $(CASCADE_MLY) $(ORDERS_MLY) $(VERTEX_MLY) $(UFO_MLY)
OMEGA_DERIVED_CAML = \
$(OMEGA_MLL:.mll=.mli) $(OMEGA_MLL:.mll=.ml) \
$(OMEGA_MLY:.mly=.mli) $(OMEGA_MLY:.mly=.ml)
OMEGA_INTERFACES_MLI = \
coupling.mli \
model.mli \
target.mli
########################################################################
# We need lists of all modules including and excluding derived
# files (*_PRIMARY). Unfortunately, we need the longer list in
# proper linking order, so we can't just tack the additional
# files to the end of the shorter list.
########################################################################
# Derived from a *.ml.in, not to be distributed
OMEGA_CONFIG_ML = \
config.ml
OMEGA_CONFIG_MLI = $(OMEGA_CONFIG_ML:.ml=.mli)
+# Not used anymore: trie.ml
+
OMEGA_CORE_ML_PART1 = \
OUnit.ml OUnitDiff.ml \
partial.ml pmap.ml format_Fortran.ml \
- thoString.ml sets.ml thoList.ml thoArray.ml bundle.ml powSet.ml \
- thoFilename.ml cache.ml progress.ml trie.ml linalg.ml tree2.ml \
+ thoString.ml sets.ml NList.ml NEList.ml thoList.ml \
+ PArray.ml thoArray.ml thoMap.ml bundle.ml powSet.ml \
+ thoFilename.ml cache.ml progress.ml linalg.ml tree2.ml \
algebra.ml options.ml product.ml combinatorics.ml \
permutation.ml partition.ml tree.ml young.ml \
tuple.ml topology.ml DAG.ml momentum.ml phasespace.ml \
- charges.ml color.ml modeltools.ml whizard.ml dirac.ml
+ charges.ml arrow.ml birdtracks.ml SU3.ml \
+ color_Propagator.ml color_Fusion.ml color.ml \
+ modeltools.ml whizard.ml dirac.ml
OMEGA_CORE_ML_PART2 = \
- $(VERTEX_ML) $(UFO_ML) $(CASCADE_ML)
+ $(VERTEX_ML) $(UFO_ML) $(CASCADE_ML) $(ORDERS_ML)
OMEGA_CORE_ML_PART2_PRIMARY = \
- $(VERTEX_ML_PRIMARY) $(UFO_ML_PRIMARY) $(CASCADE_ML_PRIMARY)
+ $(VERTEX_ML_PRIMARY) $(UFO_ML_PRIMARY) $(CASCADE_ML_PRIMARY) $(ORDERS_ML_PRIMARY)
OMEGA_CORE_ML_PART3 = \
- colorize.ml process.ml fusion.ml fusion_vintage.ml omega.ml
+ colorize.ml orders.ml process.ml fusion.ml fusion_vintage.ml \
+ feynmp.ml omega.ml omega_cli.ml
+
OMEGA_CORE_ML_PRIMARY = \
$(OMEGA_CORE_ML_PART1) $(OMEGA_CORE_ML_PART2_PRIMARY) $(OMEGA_CORE_ML_PART3)
OMEGA_CORE_ML = \
$(OMEGA_CORE_ML_PART1) $(OMEGA_CORE_ML_PART2) $(OMEGA_CORE_ML_PART3)
OMEGA_CORE_MLI_PRIMARY = $(OMEGA_INTERFACES_MLI) $(OMEGA_CORE_ML_PRIMARY:.ml=.mli)
OMEGA_CORE_MLI = \
$(OMEGA_CONFIG_MLI) $(OMEGA_INTERFACES_MLI) $(OMEGA_CORE_ML:.ml=.mli)
OMEGA_MODELLIB_ML = \
modellib_SM.ml \
modellib_MSSM.ml \
modellib_NoH.ml \
modellib_NMSSM.ml \
modellib_PSSSM.ml \
modellib_BSM.ml \
modellib_WZW.ml \
modellib_Zprime.ml
OMEGA_MODELLIB_MLI = $(OMEGA_MODELLIB_ML:.ml=.mli)
OMEGA_TARGETLIB_ML = \
targets_Kmatrix.ml \
targets_Kmatrix_2.ml \
+ target_Fortran_Names.ml \
+ targets_vintage.ml \
+ target_Fortran.ml \
+ target_VM.ml \
targets.ml
OMEGA_TARGETLIB_MLI = $(OMEGA_TARGETLIB_ML:.ml=.mli)
########################################################################
# The supported models:
########################################################################
OMEGA_MINIMAL_APPLICATIONS_ML = \
omega_QED.ml \
omega_QCD.ml \
omega_SM.ml
OMEGA_APPLICATIONS_ML = \
+ omega3.ml \
omega_QED.ml \
omega_QED_VM.ml \
omega_QCD.ml \
omega_QCD_VM.ml \
omega_SM.ml \
omega_SM_VM.ml \
omega_SM_CKM.ml \
omega_SM_CKM_VM.ml \
omega_SM_ac.ml \
omega_SM_ac_CKM.ml \
omega_SM_dim6.ml \
omega_SM_top.ml \
omega_SM_top_anom.ml \
omega_SM_tt_threshold.ml \
omega_SM_Higgs.ml \
omega_SM_Higgs_VM.ml \
omega_SM_Higgs_CKM.ml \
omega_SM_Higgs_CKM_VM.ml \
omega_THDM.ml \
omega_THDM_VM.ml \
omega_THDM_CKM.ml \
omega_THDM_CKM_VM.ml \
omega_MSSM.ml \
omega_MSSM_CKM.ml \
omega_MSSM_Grav.ml \
omega_MSSM_Hgg.ml \
omega_NMSSM.ml \
omega_NMSSM_CKM.ml \
omega_NMSSM_Hgg.ml \
omega_PSSSM.ml \
omega_Littlest.ml \
omega_Littlest_Eta.ml \
omega_Littlest_Tpar.ml \
omega_Simplest.ml \
omega_Simplest_univ.ml \
omega_Xdim.ml \
omega_GravTest.ml \
omega_NoH_rx.ml \
omega_AltH.ml \
omega_SM_rx.ml \
omega_SM_ul.ml \
omega_SSC.ml \
omega_SSC_2.ml \
omega_SSC_AltT.ml \
omega_UED.ml \
omega_WZW.ml \
omega_Zprime.ml \
omega_Zprime_VM.ml \
omega_Threeshl.ml \
omega_Threeshl_nohf.ml \
omega_HSExt.ml \
omega_HSExt_VM.ml \
omega_Template.ml \
omega_SYM.ml \
omega_UFO.ml \
omega_UFO_Dirac.ml \
omega_UFO_Majorana.ml \
omega_SM_Majorana.ml \
omega_SM_Majorana_legacy.ml
OMEGA_CORE_CMO = $(OMEGA_CONFIG_ML:.ml=.cmo) $(OMEGA_CORE_ML:.ml=.cmo)
OMEGA_CORE_CMX = $(OMEGA_CORE_CMO:.cmo=.cmx)
OMEGA_TARGETS_CMO = $(OMEGA_TARGETLIB_ML:.ml=.cmo)
OMEGA_TARGETS_CMX = $(OMEGA_TARGETLIB_ML:.ml=.cmx)
OMEGA_MODELS_CMO = $(OMEGA_MODELLIB_ML:.ml=.cmo)
OMEGA_MODELS_CMX = $(OMEGA_MODELLIB_ML:.ml=.cmx)
OMEGA_APPLICATIONS_CMO = $(OMEGA_APPLICATIONS_ML:.ml=.cmo)
OMEGA_APPLICATIONS_CMX = $(OMEGA_APPLICATIONS_ML:.ml=.cmx)
OMEGA_APPLICATIONS_BYTECODE = $(OMEGA_APPLICATIONS_ML:.ml=$(OCAML_BYTECODE_EXT))
OMEGA_APPLICATIONS_NATIVE = $(OMEGA_APPLICATIONS_ML:.ml=$(OCAML_NATIVE_EXT))
OMEGA_CACHES = $(OMEGA_APPLICATIONS_ML:.ml=.$(OMEGA_CACHE_SUFFIX))
OMEGA_MINIMAL_APPLICATIONS_BYTECODE = $(OMEGA_MINIMAL_APPLICATIONS_ML:.ml=$(OCAML_BYTECODE_EXT))
OMEGA_MINIMAL_APPLICATIONS_NATIVE = $(OMEGA_MINIMAL_APPLICATIONS_ML:.ml=$(OCAML_NATIVE_EXT))
OMEGA_MINIMAL_CACHES = $(OMEGA_MINIMAL_APPLICATIONS_ML:.ml=.$(OMEGA_CACHE_SUFFIX))
# Only primary sources, excluding generated parsers and lexers
# (used for dependency generation)
OMEGA_ML_PRIMARY = \
$(OMEGA_CORE_ML_PRIMARY) \
$(OMEGA_MODELLIB_ML) \
$(OMEGA_TARGETLIB_ML) \
$(OMEGA_APPLICATIONS_ML)
OMEGA_MLI_PRIMARY = \
$(OMEGA_CORE_MLI_PRIMARY) \
$(OMEGA_MODELLIB_MLI) \
$(OMEGA_TARGETLIB_MLI)
OMEGA_CAML_PRIMARY = $(OMEGA_ML_PRIMARY) $(OMEGA_MLI_PRIMARY) $(OMEGA_MLL) $(OMEGA_MLY)
# All sources, including generated parsers and lexers
# (used for linking and distribution)
OMEGA_ML = \
$(OMEGA_CORE_ML) \
$(OMEGA_MODELLIB_ML) \
$(OMEGA_TARGETLIB_ML) \
$(OMEGA_APPLICATIONS_ML)
OMEGA_MLI = \
$(OMEGA_CONFIG_MLI) \
$(OMEGA_CORE_MLI) \
$(OMEGA_MODELLIB_MLI) \
$(OMEGA_TARGETLIB_MLI)
OMEGA_CAML = $(OMEGA_ML) $(OMEGA_MLI) $(OMEGA_MLL) $(OMEGA_MLY) $(OMEGA_DERIVED_CAML)
########################################################################
#
# Fortran 90/95/2003 sources
#
########################################################################
AM_FCFLAGS =
## Profiling
if FC_USE_PROFILING
AM_FCFLAGS += $(FCFLAGS_PROFILING)
endif
## OpenMP
if FC_USE_OPENMP
AM_FCFLAGS += $(FCFLAGS_OPENMP)
endif
KINDS_F90 = kinds.f90
CONSTANTS_F90 = constants.f90
STRINGS_F90 = iso_varying_string.f90
OMEGA_PARAMETERS_F90 = # omega_parameters.f90 omega_parameters_madgraph.f90
OMEGALIB_DERIVED_F90 = \
omega_spinors.f90 omega_bispinors.f90 omega_vectors.f90 \
omega_vectorspinors.f90 omega_tensors.f90 \
omega_couplings.f90 omega_spinor_couplings.f90 omega_bispinor_couplings.f90 \
omega_polarizations.f90 omega_polarizations_madgraph.f90 \
omega_tensor_polarizations.f90 omega_vspinor_polarizations.f90 \
omega_color.f90 omega_utils.f90 \
omega95.f90 omega95_bispinors.f90 omegavm95.f90
OMEGALIB_F90 = \
$(CONSTANTS_F90) $(STRINGS_F90) \
$(OMEGALIB_DERIVED_F90) \
$(OMEGA_PARAMETERS_F90)
OMEGALIB_MOD = $(KINDS_F90:.f90=.mod) $(OMEGALIB_F90:.f90=.mod)
########################################################################
## The End.
########################################################################
Index: trunk/omega/src/thoArray.ml
===================================================================
--- trunk/omega/src/thoArray.ml (revision 8899)
+++ trunk/omega/src/thoArray.ml (revision 8900)
@@ -1,305 +1,305 @@
(* thoArray.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-(* Avoid refering to [Pervasives.compare], because [Pervasives] will
- become [Stdlib.Pervasives] in O'Caml 4.07 and [Stdlib] in O'Caml 4.08. *)
-let pcompare = compare
-
type 'a compressed =
{ uniq : 'a array;
embedding: int array }
let uniq a = a.uniq
let embedding a = a.embedding
type 'a compressed2 =
{ uniq2 : 'a array array;
embedding1: int array;
embedding2: int array }
let uniq2 a = a.uniq2
let embedding1 a = a.embedding1
let embedding2 a = a.embedding2
module PMap = Pmap.Tree
let compress a =
let last = Array.length a - 1 in
let embedding = Array.make (succ last) (-1) in
let rec scan num_uniq uniq elements n =
if n > last then
{ uniq = Array.of_list (List.rev elements);
embedding = embedding }
else
match PMap.find_opt compare a.(n) uniq with
| Some n' ->
embedding.(n) <- n';
scan num_uniq uniq elements (succ n)
| None ->
embedding.(n) <- num_uniq;
scan
(succ num_uniq)
(PMap.add compare a.(n) num_uniq uniq)
(a.(n) :: elements)
(succ n) in
scan 0 PMap.empty [] 0
let uncompress a =
Array.map (Array.get a.uniq) a.embedding
(* \begin{dubious}
Using [transpose] simplifies the algorithms, but can be inefficient.
If this turns out to be the case, we should add special treatments
for symmetric matrices.
\end{dubious} *)
let transpose a =
let dim1 = Array.length a
and dim2 = Array.length a.(0) in
let a' = Array.make_matrix dim2 dim1 a.(0).(0) in
for i1 = 0 to pred dim1 do
for i2 = 0 to pred dim2 do
a'.(i2).(i1) <- a.(i1).(i2)
done
done;
a'
let compress2 a =
let c2 = compress a in
let c12_transposed = compress (transpose c2.uniq) in
{ uniq2 = transpose c12_transposed.uniq;
embedding1 = c12_transposed.embedding;
embedding2 = c2.embedding }
let uncompress2 a =
let a2 = uncompress { uniq = a.uniq2; embedding = a.embedding2 } in
transpose (uncompress { uniq = transpose a2; embedding = a.embedding1 })
(* FIXME: not tail recursive! *)
-let compare ?(cmp=pcompare) a1 a2 =
+let compare ?(cmp=Stdlib.compare) a1 a2 =
let l1 = Array.length a1
and l2 = Array.length a2 in
if l1 < l2 then
-1
else if l1 > l2 then
1
else
let rec scan i =
if i = l1 then
0
else
let c = cmp a1.(i) a2.(i) in
if c < 0 then
-1
else if c > 0 then
1
else
scan (succ i) in
scan 0
let find_first f a =
let l = Array.length a in
let rec find_first' i =
if i >= l then
raise Not_found
else if f (a.(i)) then
i
else
find_first' (succ i)
in
find_first' 0
let match_first x a =
find_first (fun x' -> x = x') a
let find_all f a =
let matches = ref [] in
for i = Array.length a - 1 downto 0 do
if f (a.(i)) then
matches := i :: !matches
done;
!matches
let match_all x a =
find_all (fun x' -> x = x') a
let num_rows a =
Array.length a
let num_columns a =
match ThoList.classify (List.map Array.length (Array.to_list a)) with
| [ (_, n) ] -> n
| _ -> invalid_arg "ThoArray.num_columns: inhomogeneous array"
+let shuffle a =
+ for n = Array.length a - 1 downto 1 do
+ let k = Random.int (succ n) in
+ if k <> n then
+ let tmp = Array.get a n in
+ Array.set a n (Array.get a k);
+ Array.set a k tmp
+ done
+
+let rank3 n1 n2 n3 initial =
+ let a = Array.make n1 [| |] in
+ for i1 = 0 to pred n1 do
+ a.(i1) <- Array.make_matrix n2 n3 initial
+ done;
+ a
+
module Test =
struct
open OUnit
let test_compare_empty =
"empty" >::
(fun () -> assert_equal 0 (compare [| |] [| |]))
let test_compare_shorter =
"shorter" >::
(fun () -> assert_equal (-1) (compare [|0|] [|0; 1|]))
let test_compare_longer =
"longer" >::
(fun () -> assert_equal ( 1) (compare [|0; 1|] [|0|]))
let test_compare_less =
"longer" >::
(fun () -> assert_equal (-1) (compare [|0; 1|] [|0; 2|]))
let test_compare_equal =
"equal" >::
(fun () -> assert_equal ( 0) (compare [|0; 1|] [|0; 1|]))
let test_compare_more =
"more" >::
(fun () -> assert_equal ( 1) (compare [|0; 2|] [|0; 1|]))
let suite_compare =
"compare" >:::
[test_compare_empty;
test_compare_shorter;
test_compare_longer;
test_compare_less;
test_compare_equal;
test_compare_more]
let test_find_first_not_found =
"not found" >::
(fun () ->
assert_raises Not_found
(fun () -> find_first (fun n -> n mod 2 = 0) [|1;3;5|]))
let test_find_first_first =
"first" >::
(fun () ->
assert_equal 0
(find_first (fun n -> n mod 2 = 0) [|2;3;4;5|]))
let test_find_first_not_last =
"last" >::
(fun () ->
assert_equal 1
(find_first (fun n -> n mod 2 = 0) [|1;2;3;4|]))
let test_find_first_last =
"not last" >::
(fun () ->
assert_equal 1
(find_first (fun n -> n mod 2 = 0) [|1;2|]))
let suite_find_first =
"find_first" >:::
[test_find_first_not_found;
test_find_first_first;
test_find_first_not_last;
test_find_first_last]
let test_find_all_empty =
"empty" >::
(fun () ->
assert_equal []
(find_all (fun n -> n mod 2 = 0) [|1;3;5|]))
let test_find_all_first =
"first" >::
(fun () ->
assert_equal [0;2]
(find_all (fun n -> n mod 2 = 0) [|2;3;4;5|]))
let test_find_all_not_last =
"last" >::
(fun () ->
assert_equal [1;3]
(find_all (fun n -> n mod 2 = 0) [|1;2;3;4;5|]))
let test_find_all_last =
"not last" >::
(fun () ->
assert_equal [1;3]
(find_all (fun n -> n mod 2 = 0) [|1;2;3;4|]))
let suite_find_all =
"find_all" >:::
[test_find_all_empty;
test_find_all_first;
test_find_all_last;
test_find_all_not_last]
let test_num_columns_ok2 =
"ok/2" >::
(fun () ->
assert_equal 2
(num_columns [| [| 11; 12 |];
[| 21; 22 |];
[| 31; 32 |] |]))
let test_num_columns_ok0 =
"ok/0" >::
(fun () ->
assert_equal 0
(num_columns [| [| |];
[| |];
[| |] |]))
let test_num_columns_not_ok =
"not_ok" >::
(fun () ->
assert_raises (Invalid_argument
"ThoArray.num_columns: inhomogeneous array")
(fun () -> num_columns [| [| 11; 12 |];
[| 21 |];
[| 31; 32 |] |]))
let suite_num_columns =
"num_columns" >:::
[test_num_columns_ok2;
test_num_columns_ok0;
test_num_columns_not_ok]
let suite =
"ThoArrays" >:::
[suite_compare;
suite_find_first;
suite_find_all;
suite_num_columns]
end
-
-(*i
- * Local Variables:
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
-
-
-
-
-
Index: trunk/omega/src/tree.ml
===================================================================
--- trunk/omega/src/tree.ml (revision 8899)
+++ trunk/omega/src/tree.ml (revision 8900)
@@ -1,760 +1,761 @@
(* tree.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
(* \thocwmodulesection{Abstract Data Type} *)
type ('n, 'l) t =
| Leaf of 'n * 'l
| Node of 'n * ('n, 'l) t list
let leaf n l = Leaf (n, l)
let cons n children = Node (n, children)
(* Presenting the leafs \textit{in order} comes naturally, but will be
useful below. *)
let rec leafs = function
| Leaf (_, l) -> [l]
| Node (_, ch) -> ThoList.flatmap leafs ch
let node = function
| Leaf (n, _) -> n
| Node (n, _) -> n
(* This guarantees that the root node can be stripped from the result
by [List.tl]. *)
let rec nodes = function
| Leaf _ -> []
| Node (n, ch) -> n :: ThoList.flatmap nodes ch
(* [first_match p list] returns [(x,list')], where [x] is the first element
of [list] for which [p x = true] and [list'] is [list] sans [x]. *)
let first_match p list =
let rec first_match' no_match = function
| [] -> invalid_arg "Tree.fuse: prospective root not found"
| t :: rest when p t -> (t, List.rev_append no_match rest)
| t :: rest -> first_match' (t :: no_match) rest in
first_match' [] list
(* One recursion step in [fuse'] rotates the topmost tree node, moving
the prospective root up:
\begin{equation}
\label{eq:tree-rotation}
\parbox{46\unitlength}{%
\fmfframe(0,0)(0,4){%
\begin{fmfgraph*}(45,30)
\fmfstraight
\fmftop{r}
\fmfbottom{l11,l12,l1x,l1n,db1,l21,l22,l2x,l2n,db2,db3,db4,db5,db6,%
lx1,lx2,lxx,lxn,db7,ln1,ln2,lnx,lnn}
\fmf{plain,tension=4}{r,vr1}
\fmf{plain,tension=4,lab=$p$,lab.side=left}{r,vr2}
\fmf{dots,tension=4}{r,vrx}
\fmf{plain,tension=4}{r,vrn}
\fmf{plain}{vr1,l11}\fmf{plain}{vr1,l12}
\fmf{dots}{vr1,l1x}\fmf{plain}{vr1,l1n}
\fmf{plain}{vr2,l21}\fmf{plain}{vr2,l22}
\fmf{dots}{vr2,l2x}\fmf{plain}{vr2,l2n}
\fmf{dots}{vrx,lx1}\fmf{dots}{vrx,lx2}
\fmf{dots}{vrx,lxx}\fmf{dots}{vrx,lxn}
\fmf{plain}{vrn,ln1}\fmf{plain}{vrn,ln2}
\fmf{dots}{vrn,lnx}\fmf{plain}{vrn,lnn}
\fmfv{l=$r$,l.ang=-90}{l22}
\fmfv{d.shape=circle,d.filled=empty,d.size=7thick,%
back=.8white}{r,vr1,vrx,vrn}
\fmfv{d.shape=circle,d.filled=empty,d.size=7thick,%
lab=$R$,lab.dist=0}{vr2}
\end{fmfgraph*}}}
\to
\parbox{61\unitlength}{%
\fmfframe(0,0)(0,4){%
\begin{fmfgraph*}(60,30)
\fmfstraight
\fmftop{r}
\fmfbottom{l21,d1,d2,l22,d3,d4,l2x,d5,d6,l2n,d7,d8,db2,%
l11,l12,l1x,l1n,db1,db2,db3,lx1,lx2,lxx,lxn,db4,%
ln1,ln2,lnx,lnn}
\fmf{plain}{r,vr1}\fmf{phantom}{vr1,l21}
\fmf{plain}{r,vr2}\fmf{phantom}{vr2,l22}
\fmf{dots}{r,vrx}\fmf{phantom}{vrx,l2x}
\fmf{plain}{r,vr3}\fmf{phantom}{vr3,l2n}
\fmf{plain,tension=12,lab=$-p$,lab.side=left}{r,vrn}
\fmf{plain,tension=4}{vrn,vvr1}
\fmf{dots,tension=4}{vrn,vvrx}
\fmf{plain,tension=4}{vrn,vvrn}
\fmf{plain}{vvr1,l11}\fmf{plain}{vvr1,l12}
\fmf{dots}{vvr1,l1x}\fmf{plain}{vvr1,l1n}
\fmf{dots}{vvrx,lx1}\fmf{dots}{vvrx,lx2}
\fmf{dots}{vvrx,lxx}\fmf{dots}{vvrx,lxn}
\fmf{plain}{vvrn,ln1}\fmf{plain}{vvrn,ln2}
\fmf{dots}{vvrn,lnx}\fmf{plain}{vvrn,lnn}
\fmfv{l=$r$,l.ang=-90}{vr2}
\fmfv{d.shape=circle,d.filled=empty,d.size=7thick,%
back=.8white}{vrn,vvr1,vvrx,vvrn}
\fmfv{d.shape=circle,d.filled=empty,d.size=7thick,%
lab=$R$,lab.dist=0}{r}
\end{fmfgraph*}}}
\end{equation} *)
let fuse conjg root contains_root trees =
let rec fuse' subtrees =
match first_match contains_root subtrees with
(* If the prospective root is contained in a leaf, we have either found
the root---in which case we're done---or have failed catastrophically: *)
| Leaf (n, l), children ->
if l = root then
Node (conjg n, children)
else
invalid_arg "Tree.fuse: root predicate inconsistent"
(* Otherwise, we perform a rotation as in~(\ref{eq:tree-rotation}) and
connect all nodes that do not contain the root to a new node.
For efficiency, we append the new node at the end and prevent
[first_match] from searching for the root in it in vain again.
Since [root_children] is probably rather short, this should be
a good strategy. *)
| Node (n, root_children), other_children ->
fuse' (root_children @ [Node (conjg n, other_children)]) in
fuse' trees
(* Sorting is also straightforward, we only have to keep track of the
suprema of the subtrees: *)
type ('a, 'b) with_supremum = { sup : 'a; data : 'b }
(* Since the lists are rather short, [List.sort] could be replaced by
an optimized version, but we're not (yet) dealing with the most
important speed bottleneck here: *)
let rec sort' lesseq = function
| Leaf (_, l) as e -> { sup = l; data = e }
| Node (n, ch) ->
let ch' = List.sort
(fun x y -> compare x.sup y.sup) (List.map (sort' lesseq) ch) in
{ sup = (List.hd (List.rev ch')).sup;
data = Node (n, List.map (fun x -> x.data) ch') }
(* finally, throw away the overall supremum: *)
let sort lesseq t = (sort' lesseq t).data
let rec canonicalize = function
| Leaf (_, _) as l -> l
| Node (n, ch) ->
Node (n, List.sort compare (List.map canonicalize ch))
(* \thocwmodulesection{Homomorphisms} *)
(* Isomophisms are simple: *)
let rec map fn fl = function
| Leaf (n, l) -> Leaf (fn n, fl l)
| Node (n, ch) -> Node (fn n, List.map (map fn fl) ch)
(* homomorphisms are not more complicated: *)
let rec fold leaf node = function
| Leaf (n, l) -> leaf n l
| Node (n, ch) -> node n (List.map (fold leaf node) ch)
(* and tensor products are fun: *)
let rec fan leaf node = function
| Leaf (n, l) -> leaf n l
| Node (n, ch) -> Product.fold
(fun ch' t -> node n ch' @ t) (List.map (fan leaf node) ch) []
(* \thocwmodulesection{Output} *)
let leaf_to_string n l =
if n = "" then
l
else if l = "" then
n
else
n ^ "(" ^ l ^ ")"
let node_to_string n ch =
"(" ^ (if n = "" then "" else n ^ ":") ^ (String.concat "," ch) ^ ")"
let to_string t =
fold leaf_to_string node_to_string t
(* \thocwmodulesubsection{Feynmf}
Add a value that is greater than all suprema *)
type 'a supremum_or_infinity = Infinity | Sup of 'a
type ('a, 'b) with_supremum_or_infinity =
{ sup : 'a supremum_or_infinity; data : 'b }
let with_infinity cmp x y =
match x.sup, y.sup with
| Infinity, _ -> 1
| _, Infinity -> -1
| Sup x', Sup y' -> cmp x' y'
(* Using this, we can sort the tree in another way that guarantees that
a particular leaf ([i2]) is moved as far to the end as possible. We
can then flip this leaf from outgoing to incoming without introducing
a crossing: *)
let rec sort_2i' lesseq i2 = function
| Leaf (_, l) as e ->
{ sup = if l = i2 then Infinity else Sup l; data = e }
| Node (n, ch) ->
let ch' = List.sort (with_infinity compare)
(List.map (sort_2i' lesseq i2) ch) in
{ sup = (List.hd (List.rev ch')).sup;
data = Node (n, List.map (fun x -> x.data) ch') }
(* again, throw away the overall supremum: *)
let sort_2i lesseq i2 t = (sort_2i' lesseq i2 t).data
type feynmf =
{ style : (string * string) option;
rev : bool;
label : string option;
tension : float option }
open Printf
let style prop =
match prop.style with
| None -> ("plain","")
| Some s -> s
let species prop = fst (style prop)
let tex_lbl prop = snd (style prop)
let leaf_label tex io leaf lab = function
| None -> fprintf tex " \\fmflabel{${%s}$}{%s%s}\n" lab io leaf
| Some s ->
fprintf tex " \\fmflabel{${%s{}^{(%s)}}$}{%s%s}\n" s lab io leaf
let leaf_label tex io leaf lab label =
()
(* We try to draw diagrams more symmetrically by reducing the tension
on the outgoing external lines.
\begin{dubious}
\index{shortcomings!algorithmical}
This is insufficient for asymmetrical cascade decays.
\end{dubious} *)
let rec leaf_node tex to_label i2 n prop leaf =
let io, tension, rev =
if leaf = i2 then
("i", "", not prop.rev)
else
("o", ",tension=0.5", prop.rev) in
leaf_label tex io (to_label leaf) (tex_lbl prop) prop.label ;
fprintf tex " \\fmfdot{v%d}\n" n;
if rev then
fprintf tex " \\fmf{%s%s}{%s%s,v%d}\n"
(species prop) tension io (to_label leaf) n
else
fprintf tex " \\fmf{%s%s}{v%d,%s%s}\n"
(species prop) tension n io (to_label leaf)
and int_node tex to_label i2 n n' prop t =
if prop.rev then
fprintf tex
" \\fmf{%s,label=\\begin{scriptsize}${%s}$\\end{scriptsize}}{v%d,v%d}\n"
(species prop) (tex_lbl prop) n' n
else
fprintf tex
" \\fmf{%s,label=\\begin{scriptsize}${%s}$\\end{scriptsize}}{v%d,v%d}\n"
(species prop) (tex_lbl prop) n n';
fprintf tex " \\fmfdot{v%d,v%d}\n" n n';
edges_feynmf' tex to_label i2 n' t
and leaf_or_int_node tex to_label i2 n n' = function
| Leaf (prop, l) -> leaf_node tex to_label i2 n prop l
| Node (prop, _) as t -> int_node tex to_label i2 n n' prop t
and edges_feynmf' tex to_label i2 n = function
| Leaf (prop, l) -> leaf_node tex to_label i2 n prop l
| Node (_, ch) ->
ignore (List.fold_right
(fun t' n' ->
leaf_or_int_node tex to_label i2 n n' t';
succ n') ch (4*n))
let edges_feynmf tex to_label i1 i2 t =
let n = 1 in
begin match t with
| Leaf _ -> ()
| Node (prop, _) ->
leaf_label tex "i" "1" (tex_lbl prop) prop.label;
if prop.rev then
fprintf tex " \\fmf{%s}{v%d,i%s}\n" (species prop) n (to_label i1)
else
fprintf tex " \\fmf{%s}{i%s,v%d}\n" (species prop) (to_label i1) n
end;
fprintf tex " \\fmfdot{v%d}\n" n;
edges_feynmf' tex to_label i2 n t
let to_feynmf_channel tex to_TeX to_label incoming t =
match incoming with
| i1 :: i2 :: _ ->
let t' = sort_2i (<=) i2 t in
let out = List.filter (fun a -> i2 <> a) (leafs t') in
fprintf tex "\\fmfframe(8,7)(8,6){%%\n";
fprintf tex " \\begin{fmfgraph*}(35,30)\n";
fprintf tex " \\fmfpen{thin}\n";
fprintf tex " \\fmfset{arrow_len}{2mm}\n";
fprintf tex " \\fmfleft{i%s,i%s}\n" (to_label i1) (to_label i2);
fprintf tex " \\fmfright{o%s}\n"
(String.concat ",o" (List.map to_label out));
List.iter
(fun s ->
fprintf tex " \\fmflabel{${%s}$}{i%s}\n"
(to_TeX s) (to_label s))
[i1; i2];
List.iter
(fun s ->
fprintf tex " \\fmflabel{${%s}$}{o%s}\n"
(to_TeX s) (to_label s))
out;
edges_feynmf tex to_label i1 i2 t';
fprintf tex " \\end{fmfgraph*}}\\hfil\\allowbreak\n"
| _ -> ()
(* \begin{figure}
\fmfframe(3,5)(3,5){%
\begin{fmfgraph*}(30,30)
\fmfleft{i1,i2}
\fmfright{o3,o4,o5,o6}
\fmflabel{$1$}{i1}
\fmflabel{$2$}{i2}
\fmflabel{$3$}{o3}
\fmflabel{$4$}{o4}
\fmflabel{$5$}{o5}
\fmflabel{$6$}{o6}
\fmf{plain}{i1,v1}
\fmf{plain}{v1,v3}
\fmf{plain,tension=0.5}{v3,o3}
\fmf{plain}{v3,v9}
\fmf{plain,tension=0.5}{v9,o4}
\fmf{plain}{v9,v27}
\fmf{plain,tension=0.5}{v27,o5}
\fmf{plain,tension=0.5}{v27,o6}
\fmf{plain}{v1,i2}
\end{fmfgraph*}}
\fmfframe(3,5)(3,5){%
\begin{fmfgraph*}(30,30)
\fmfleft{i1,i2}
\fmfright{o3,o4,o6,o5}
\fmflabel{$1$}{i1}
\fmflabel{$2$}{i2}
\fmflabel{$3$}{o3}
\fmflabel{$4$}{o4}
\fmflabel{$6$}{o6}
\fmflabel{$5$}{o5}
\fmf{plain}{i1,v1}
\fmf{plain}{v1,v3}
\fmf{plain,tension=0.5}{v3,o3}
\fmf{plain}{v3,v9}
\fmf{plain}{v9,v27}
\fmf{plain,tension=0.5}{v27,o4}
\fmf{plain,tension=0.5}{v27,o6}
\fmf{plain,tension=0.5}{v9,o5}
\fmf{plain}{v1,i2}
\end{fmfgraph*}}
\fmfframe(3,5)(3,5){%
\begin{fmfgraph*}(30,30)
\fmfleft{i1,i2}
\fmfright{o3,o4,o5,o6}
\fmflabel{$1$}{i1}
\fmflabel{$2$}{i2}
\fmflabel{$3$}{o3}
\fmflabel{$4$}{o4}
\fmflabel{$5$}{o5}
\fmflabel{$6$}{o6}
\fmf{plain}{i1,v1}
\fmf{plain}{v1,v3}
\fmf{plain}{v3,v9}
\fmf{plain,tension=0.5}{v9,o3}
\fmf{plain,tension=0.5}{v9,o4}
\fmf{plain}{v3,v10}
\fmf{plain,tension=0.5}{v10,o5}
\fmf{plain,tension=0.5}{v10,o6}
\fmf{plain}{v1,i2}
\end{fmfgraph*}}
\caption{\label{fig:to_feynmf}%
Note that this is subtly different \ldots}
\end{figure} *)
let vanilla = { style = None; rev = false; label = None; tension = None }
let sty (s, r, l) = { vanilla with style = Some s; rev = r; label = Some l }
type 'l feynmf_set =
{ header : string;
incoming : 'l list;
diagrams : (feynmf, 'l) t list }
type ('l, 'm) feynmf_sets =
{ outer : 'l feynmf_set;
inner : 'm feynmf_set list }
type 'l feynmf_levels =
{ this : 'l feynmf_set;
lower : 'l feynmf_levels list }
let latex_section = function
| level when level < 0 -> "part"
| 0 -> "chapter"
| 1 -> "section"
| 2 -> "subsection"
| 3 -> "subsubsection"
| 4 -> "paragraph"
| _ -> "subparagraph"
let rec feynmf_set tex sections level to_TeX to_label set =
fprintf tex "%s\\%s{%s}\n"
(if sections then "" else "%%% ")
(latex_section level)
set.header;
List.iter
(to_feynmf_channel tex to_TeX to_label set.incoming)
set.diagrams
let feynmf_sets tex sections level
to_TeX_outer to_label_outer to_TeX_inner to_label_inner set =
feynmf_set tex sections level to_TeX_outer to_label_outer set.outer;
List.iter
(feynmf_set tex sections (succ level) to_TeX_inner to_label_inner)
set.inner
let feynmf_sets_plain sections level file
to_TeX_outer to_label_outer to_TeX_inner to_label_inner sets =
let tex = open_out (file ^ ".tex") in
List.iter
(feynmf_sets tex sections level
to_TeX_outer to_label_outer to_TeX_inner to_label_inner)
sets;
close_out tex
let feynmf_header tex file =
fprintf tex "\\documentclass[10pt]{article}\n";
fprintf tex "\\usepackage{ifpdf}\n";
fprintf tex "\\usepackage[colorlinks]{hyperref}\n";
fprintf tex "\\usepackage[a4paper,margin=1cm]{geometry}\n";
fprintf tex "\\usepackage{feynmp}\n";
fprintf tex "\\ifpdf\n";
fprintf tex " \\DeclareGraphicsRule{*}{mps}{*}{}\n";
fprintf tex "\\else\n";
fprintf tex " \\DeclareGraphicsRule{*}{eps}{*}{}\n";
fprintf tex "\\fi\n";
fprintf tex "\\setlength{\\unitlength}{1mm}\n";
fprintf tex "\\setlength{\\parindent}{0pt}\n";
fprintf tex
"\\renewcommand{\\mathstrut}{\\protect\\vphantom{\\hat{0123456789}}}\n";
fprintf tex "\\begin{document}\n";
fprintf tex "\\tableofcontents\n";
fprintf tex "\\begin{fmffile}{%s-fmf}\n\n" file
let feynmf_footer tex =
fprintf tex "\n";
fprintf tex "\\end{fmffile} \n";
fprintf tex "\\end{document} \n"
let feynmf_sets_wrapped latex file
to_TeX_outer to_label_outer to_TeX_inner to_label_inner sets =
let tex = open_out (file ^ ".tex") in
if latex then feynmf_header tex file;
List.iter
(feynmf_sets tex latex 1
to_TeX_outer to_label_outer to_TeX_inner to_label_inner)
sets;
if latex then feynmf_footer tex;
close_out tex
+let feynmf_sets_wrapped_to_channel latex channel
+ to_TeX_outer to_label_outer to_TeX_inner to_label_inner sets =
+ if latex then feynmf_header channel "\\jobname";
+ List.iter
+ (feynmf_sets channel latex 1
+ to_TeX_outer to_label_outer to_TeX_inner to_label_inner)
+ sets;
+ if latex then feynmf_footer channel
+
let rec feynmf_levels tex sections level to_TeX to_label set =
fprintf tex "%s\\%s{%s}\n"
(if sections then "" else "%%% ")
(latex_section level)
set.this.header;
List.iter
(to_feynmf_channel tex to_TeX to_label set.this.incoming)
set.this.diagrams;
List.iter (feynmf_levels tex sections (succ level) to_TeX to_label) set.lower
let feynmf_levels_plain sections level file to_TeX to_label sets =
let tex = open_out (file ^ ".tex") in
List.iter (feynmf_levels tex sections level to_TeX to_label) sets;
close_out tex
let feynmf_levels_wrapped file to_TeX to_label sets =
let tex = open_out (file ^ ".tex") in
feynmf_header tex file;
List.iter (feynmf_levels tex true 1 to_TeX to_label) sets;
feynmf_footer tex;
close_out tex
(* \thocwmodulesection{Least Squares Layout}
\begin{equation}
L = \frac{1}{2} \sum_{i\not=i'} T_{ii'} \left(x_i-x_{i'}\right)^2
+ \frac{1}{2} \sum_{i,j} T'_{ij} \left(x_i-e_j\right)^2
\end{equation}
and thus
\begin{equation}
0 = \frac{\partial L}{\partial x_i}
= \sum_{i'\not=i} T_{ii'} \left(x_i-x_{i'}\right)
+ \sum_{j} T'_{ij} \left(x_i-e_j\right)
\end{equation}
or
\begin{equation}
\label{eq:layout}
\left(\sum_{i'\not=i} T_{ii'} + \sum_{j} T'_{ij}\right) x_i
- \sum_{i'\not=i} T_{ii'} x_{i'}
= \sum_{j} T'_{ij} e_j
\end{equation}
where we can assume that
\begin{subequations}
\begin{align}
T_{ii'} &= T_{i'i} \\
T_{ii} &= 0
\end{align}
\end{subequations} *)
type 'a node_with_tension = { node : 'a; tension : float }
let unit_tension t =
map (fun n -> { node = n; tension = 1.0 }) (fun l -> l) t
let leafs_and_nodes i2 t =
let t' = sort_2i (<=) i2 t in
match nodes t' with
| [] -> failwith "Tree.nodes_and_leafs: impossible"
| i1 :: _ as n -> (i1, i2, List.filter (fun l -> l <> i2) (leafs t'), n)
(* Not tail recursive, but they're unlikely to meet any deep trees: *)
let rec internal_edges_from n = function
| Leaf _ -> []
| Node (n', ch) -> (n', n) :: (ThoList.flatmap (internal_edges_from n') ch)
(* The root node of the tree represents a vertex (node) and an
external line (leaf) of the Feynman diagram simultaneously. Thus
it requires special treatment: *)
let internal_edges = function
| Leaf _ -> []
| Node (n, ch) -> ThoList.flatmap (internal_edges_from n) ch
let rec external_edges_from n = function
| Leaf (n', _) -> [(n', n)]
| Node (n', ch) -> ThoList.flatmap (external_edges_from n') ch
let external_edges = function
| Leaf (n, _) -> [(n, n)]
| Node (n, ch) -> (n, n) :: ThoList.flatmap (external_edges_from n) ch
type ('edge, 'node, 'ext) graph =
{ int_nodes : 'node array;
ext_nodes : 'ext array;
int_edges : ('edge * int * int) list;
ext_edges : ('edge * int * int) list }
module M = Pmap.Tree
(* Invert an array, viewed as a map from non-negative integers
into a set. The result is a map from the set to the integers:
[val invert_array : 'a array -> ('a, int) M.t] *)
let invert_array_unsafe a =
fst (Array.fold_left (fun (m, i) a_i ->
(M.add compare a_i i m, succ i)) (M.empty, 0) a)
exception Not_invertible
let add_unique key data map =
if M.mem compare key map then
raise Not_invertible
else
M.add compare key data map
let invert_array a =
fst (Array.fold_left (fun (m, i) a_i ->
(add_unique a_i i m, succ i)) (M.empty, 0) a)
let graph_of_tree nodes2edge conjugate i2 t =
let i1, i2, out, vertices = leafs_and_nodes i2 t in
let int_nodes = Array.of_list vertices
and ext_nodes = Array.of_list (conjugate i1 :: i2 :: out) in
let int_nodes_index_table = invert_array int_nodes
and ext_nodes_index_table = invert_array ext_nodes in
let int_nodes_index n = M.find compare n int_nodes_index_table
and ext_nodes_index n = M.find compare n ext_nodes_index_table in
{ int_nodes = int_nodes;
ext_nodes = ext_nodes;
int_edges = List.map
(fun (n1, n2) ->
(nodes2edge n1 n2, int_nodes_index n1, int_nodes_index n2))
(internal_edges t);
ext_edges = List.map
(fun (e, n) ->
let e' =
if e = i1 then
conjugate e
else
e in
(nodes2edge e' n, ext_nodes_index e', int_nodes_index n))
(external_edges t) }
let int_incidence f null g =
let n = Array.length g.int_nodes in
let incidence = Array.make_matrix n n null in
List.iter (fun (edge, n1, n2) ->
if n1 <> n2 then begin
let edge' = f edge g.int_nodes.(n1) g.int_nodes.(n2) in
incidence.(n1).(n2) <- edge';
incidence.(n2).(n1) <- edge'
end)
g.int_edges;
incidence
let ext_incidence f null g =
let n_int = Array.length g.int_nodes
and n_ext = Array.length g.ext_nodes in
let incidence = Array.make_matrix n_int n_ext null in
List.iter (fun (edge, e, n) ->
incidence.(n).(e) <- f edge g.ext_nodes.(e) g.int_nodes.(n))
g.ext_edges;
incidence
let division n =
if n < 0 then
[]
else if n = 1 then
[0.5]
else
let n' = pred n in
let d = 1.0 /. (float n') in
let rec division' i acc =
if i < 0 then
acc
else
division' (pred i) (float i *. d :: acc) in
division' n' []
type ('e, 'n, 'ext) ext_layout = ('e, 'n, 'ext * float * float) graph
type ('e, 'n, 'ext) layout = ('e, 'n * float * float, 'ext) ext_layout
let left_to_right num_in g =
if num_in < 1 then
invalid_arg "left_to_right"
else
let num_out = Array.length g.ext_nodes - num_in in
if num_out < 1 then
invalid_arg "left_to_right"
else
let incoming =
List.map2 (fun e y -> (e, 0.0, y))
(Array.to_list (Array.sub g.ext_nodes 0 num_in))
(division num_in)
and outgoing =
List.map2 (fun e y -> (e, 1.0, y))
(Array.to_list (Array.sub g.ext_nodes num_in num_out))
(division num_out) in
{ g with ext_nodes = Array.of_list (incoming @ outgoing) }
(* Reformulating~(\ref{eq:layout})
\begin{subequations}
\begin{align}
Ax &= b_x \\
Ay &= b_y
\end{align}
\end{subequations}
with
\begin{subequations}
\begin{align}
A_{ii'} &=
\left( \sum_{i''\not=i} T_{ii''}
+ \sum_j T'_{ij} \right) \delta_{ii'} - T_{ii'} \\
(b_{x/y})_i &= \sum_j T'_{ij} (e_{x/y})_j
\end{align}
\end{subequations} *)
let sum a = Array.fold_left (+.) 0.0 a
let tension_to_equation t t' e =
let xe, ye = List.split e in
let bx = Linalg.matmulv t' (Array.of_list xe)
and by = Linalg.matmulv t' (Array.of_list ye)
and a = Array.init (Array.length t)
(fun i ->
let a_i = Array.map (~-.) t.(i) in
a_i.(i) <- a_i.(i) +. sum t.(i) +. sum t'.(i);
a_i) in
(a, bx, by)
let layout g =
let ext_nodes =
List.map (fun (_, x, y) -> (x, y)) (Array.to_list g.ext_nodes) in
let a, bx, by =
tension_to_equation
(int_incidence (fun _ _ _ -> 1.0) 0.0 g)
(ext_incidence (fun _ _ _ -> 1.0) 0.0 g) ext_nodes in
match Linalg.solve_many a [bx; by] with
| [x; y] -> { g with int_nodes = Array.mapi
(fun i n -> (n, x.(i), y.(i))) g.int_nodes }
| _ -> failwith "impossible"
let iter_edges f g =
List.iter (fun (edge, n1, n2) ->
let _, x1, y1 = g.int_nodes.(n1)
and _, x2, y2 = g.int_nodes.(n2) in
f edge (x1, y1) (x2, y2)) g.int_edges;
List.iter (fun (edge, e, n) ->
let _, x1, y1 = g.ext_nodes.(e)
and _, x2, y2 = g.int_nodes.(n) in
f edge (x1, y1) (x2, y2)) g.ext_edges
let iter_internal f g =
Array.iter (fun (node, x, y) -> f (x, y)) g.int_nodes
let iter_incoming f g =
f g.ext_nodes.(0);
f g.ext_nodes.(1)
let iter_outgoing f g =
for i = 2 to pred (Array.length g.ext_nodes) do
f g.ext_nodes.(i)
done
let dump g =
Array.iter (fun (_, x, y) -> Printf.eprintf "(%g,%g) " x y) g.ext_nodes;
Printf.eprintf "\n => ";
Array.iter (fun (_, x, y) -> Printf.eprintf "(%g,%g) " x y) g.int_nodes;
Printf.eprintf "\n"
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/omega_UFO.ml
===================================================================
--- trunk/omega/src/omega_UFO.ml (revision 8899)
+++ trunk/omega/src/omega_UFO.ml (revision 8900)
@@ -1,30 +1,30 @@
(* omega_UFO.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module Omega_Dirac = Omega.Nary(Targets.Fortran)(UFO.Model)
-module Omega_Majorana = Omega.Nary_Majorana(Targets.Fortran_Majorana)(UFO.Model)
+module Omega_Dirac = Omega.Nary(Target_Fortran.Make)(UFO.Model)
+module Omega_Majorana = Omega.Nary_Majorana(Target_Fortran.Make_Majorana)(UFO.Model)
let _ =
try Omega_Dirac.main () with
| Fusion.Majorana -> Omega_Majorana.main ()
Index: trunk/omega/src/PArray.mli
===================================================================
--- trunk/omega/src/PArray.mli (revision 0)
+++ trunk/omega/src/PArray.mli (revision 8900)
@@ -0,0 +1,88 @@
+(* PArray.mli --
+
+ Copyright (C) 2022-2023 by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+ with contributions from
+ Christian Speckner <cnspeckn@googlemail.com>
+
+ 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. *)
+
+(* O'Caml arrays ['a array] are a special case of maps
+ [int -> 'a] from a subset of the integers into a set,
+ where the subset is contiguous and starts with 0.
+
+ In O'Caml, updating element of an ['a array] is not pure,
+ since the array is updated in place and all references
+ to the array element in other parts of the code are affected.
+ This is efficient, but complicates backtracking.
+
+ A ['a PArray.t], on the other hand is updated with
+ pure functions, keeping the original array in place. *)
+
+(* The type of persistent array. *)
+type 'a t
+
+val empty : 'a t
+val is_empty : 'a t -> bool
+val map : ('a -> 'b) -> 'a t -> 'b t
+val add : int -> 'a -> 'a t -> 'a t
+val remove : int -> 'a t -> 'a t
+val get_opt : int -> 'a t -> 'a option
+
+(* Create an array from a list of pairs of index and value. Note that
+ we assume the array indices to start from~$0$. *)
+val of_pairs : (int * 'a) list -> 'a t
+val to_pairs : 'a t -> (int * 'a) list
+
+(* Compute a list of all entries of the array, starting from the
+ index~$0$. Entries [a] are represented by [Some a] and missing
+ entries are represented by [None].
+ For example [to_option_list [of_pairs [(2,42)]] evaluates
+ to [[None; Some 42]]. *)
+val to_option_list : 'a t -> 'a option list
+
+(* For debugging: *)
+val to_string : ('a -> string) -> 'a t -> string
+
+(* Order: *)
+val compare : ('a -> 'a -> int) -> 'a t -> 'a t -> int
+val equal : ('a -> 'a -> bool) -> 'a t -> 'a t -> bool
+
+(* [take_one project_opt parray] tries to
+ find one element in [parray] that is mapped to [None] by [project_opt].
+ Returns [Nothing projected_parray] if nothing is found and
+ [Unique (key, value, projected_parray)] if there is exactly one
+ match where [projected_parray] is [parray] with the binding for [key]
+ removed and the function [project_opt] has been applied (with the [Some]
+ stripped, of course).
+ Returns [Multiple (key, value, parray')] if there are multiple
+ matches, where [parray'] is [parray] with the binding for [key]
+ removed. In both cases, [key] is one of the matching keys and [value]
+ the associated binding. The rationale is that we can use
+ [take_one] to remove bindings from a map until we can
+ replace the type of the values by a simpler type,
+ e.\,g.~by unboxing. *)
+
+type ('a, 'b) taken = private
+ | Nothing of 'b t
+ | Single of int * 'a * 'b t
+ | Multiple of int * 'a * 'a t
+
+val take_one : (int -> 'a -> 'b option) -> 'a t -> ('a, 'b) taken
+
+module Test : sig val suite : OUnit.test end
Index: trunk/omega/src/omega_SM_Higgs_VM.ml
===================================================================
--- trunk/omega/src/omega_SM_Higgs_VM.ml (revision 8899)
+++ trunk/omega/src/omega_SM_Higgs_VM.ml (revision 8900)
@@ -1,35 +1,26 @@
(* omega_SM_Higgs_VM.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
cf. main AUTHORS file
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.VM)
- (Modellib_SM.SM(Modellib_SM.SM_Higgs))
+module O = Omega.Mixed23(Target_VM.Make)(Modellib_SM.SM(Modellib_SM.SM_Higgs))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/target_Fortran_Names.mli
===================================================================
--- trunk/omega/src/target_Fortran_Names.mli (revision 0)
+++ trunk/omega/src/target_Fortran_Names.mli (revision 8900)
@@ -0,0 +1,66 @@
+(* target_Fortran_Names.mli --
+
+ Copyright (C) 1999-2023 by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+ with contributions from
+ Christian Speckner <cnspeckn@googlemail.com>
+
+ 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. *)
+
+(* These are the names of Fortran types, wave function variables and
+ propagator functions. This must by synchronized among the
+ \texttt{omegalib}, modern and vintage Fortran [Target] implementations. *)
+
+module type T =
+ sig
+ val psi_type : string
+ val psibar_type : string
+ val chi_type : string
+ val grav_type : string
+ val psi_incoming : string
+ val brs_psi_incoming : string
+ val psibar_incoming : string
+ val brs_psibar_incoming : string
+ val chi_incoming : string
+ val brs_chi_incoming : string
+ val grav_incoming : string
+ val psi_outgoing : string
+ val brs_psi_outgoing : string
+ val psibar_outgoing : string
+ val brs_psibar_outgoing : string
+ val chi_outgoing : string
+ val brs_chi_outgoing : string
+ val grav_outgoing : string
+ val psi_propagator : string
+ val psibar_propagator : string
+ val chi_propagator : string
+ val grav_propagator : string
+ val psi_projector : string
+ val psibar_projector : string
+ val chi_projector : string
+ val grav_projector : string
+ val psi_gauss : string
+ val psibar_gauss : string
+ val chi_gauss : string
+ val grav_gauss : string
+ val use_module : string
+ val require_library : string list
+ end
+
+module Dirac : T
+module Majorana : T
Index: trunk/omega/src/omega_SSC_2.ml
===================================================================
--- trunk/omega/src/omega_SSC_2.ml (revision 8899)
+++ trunk/omega/src/omega_SSC_2.ml (revision 8900)
@@ -1,36 +1,27 @@
(* omega_SSC.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@physik.uni-freiburg.de>
with contributions from
Marco Sekulla <marco.sekulla@kit.edu>
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.Fortran)
- (Modellib_BSM.SSC(Modellib_BSM.SSC_kmatrix_2))
+module O = Omega.Mixed23(Target_Fortran.Make)(Modellib_BSM.SSC(Modellib_BSM.SSC_kmatrix_2))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/modellib_MSSM.ml
===================================================================
--- trunk/omega/src/modellib_MSSM.ml (revision 8899)
+++ trunk/omega/src/modellib_MSSM.ml (revision 8900)
@@ -1,2649 +1,2645 @@
(* modellib_MSSM.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
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. *)
(* modellib_MSSM.ml -- *)
(* \thocwmodulesection{Minimal Supersymmetric Standard Model} *)
module type MSSM_flags =
sig
val include_goldstone : bool
val include_four : bool
val ckm_present : bool
val gravitino : bool
val higgs_triangle : bool
end
module MSSM_no_goldstone : MSSM_flags =
struct
let include_goldstone = false
let include_four = true
let ckm_present = false
let gravitino = false
let higgs_triangle = false
end
module MSSM_goldstone : MSSM_flags =
struct
let include_goldstone = true
let include_four = true
let ckm_present = false
let gravitino = false
let higgs_triangle = false
end
module MSSM_no_4 : MSSM_flags =
struct
let include_goldstone = false
let include_four = false
let ckm_present = false
let gravitino = false
let higgs_triangle = false
end
module MSSM_no_4_ckm : MSSM_flags =
struct
let include_goldstone = false
let include_four = false
let ckm_present = true
let gravitino = false
let higgs_triangle = false
end
module MSSM_Grav : MSSM_flags =
struct
let include_goldstone = false
let include_four = false
let ckm_present = false
let gravitino = true
let higgs_triangle = false
end
module MSSM_Hgg : MSSM_flags =
struct
let include_goldstone = false
let include_four = false
let ckm_present = false
let gravitino = false
let higgs_triangle = true
end
module MSSM (Flags : MSSM_flags) =
struct
open Coupling
let default_width = ref Timelike
let use_fudged_width = ref false
let options = Options.create
[ "constant_width", Arg.Unit (fun () -> default_width := Constant),
"use constant width (also in t-channel)";
"fudged_width", Arg.Set use_fudged_width,
"use fudge factor for charge particle width";
"custom_width", Arg.String (fun f -> default_width := Custom f),
"use custom width";
"cancel_widths", Arg.Unit (fun () -> default_width := Vanishing),
"use vanishing width";
"cms_width", Arg.Unit (fun () -> default_width := Complex_Mass),
"use complex mass scheme";
"running_width", Arg.Unit (fun () -> default_width := Running),
"use running width"]
let caveats () = []
type gen =
| G of int | GG of gen*gen
let rec string_of_gen = function
| G n when n > 0 -> string_of_int n
| G n -> string_of_int (abs n) ^ "c"
| GG (g1,g2) -> string_of_gen g1 ^ "_" ^ string_of_gen g2
(* With this we distinguish the flavour. *)
type sff =
| SL | SN | SU | SD
let string_of_sff = function
| SL -> "sl" | SN -> "sn" | SU -> "su" | SD -> "sd"
(* With this we distinguish the mass eigenstates. At the moment we have to cheat
a little bit for the sneutrinos. Because we are dealing with massless
neutrinos there is only one sort of sneutrino. *)
type sfm =
| M1 | M2
- let string_of_sfm = function
+ let string_of_sfm = function
| M1 -> "1" | M2 -> "2"
(* We also introduce special types for the charginos and neutralinos. *)
type char =
| C1 | C2 | C1c | C2c
type neu =
| N1 | N2 | N3 | N4
let int_of_char = function
| C1 -> 1 | C2 -> 2 | C1c -> -1 | C2c -> -2
let string_of_char = function
| C1 -> "1" | C2 -> "2" | C1c -> "-1" | C2c -> "-2"
let conj_char = function
| C1 -> C1c | C2 -> C2c | C1c -> C1 | C2c -> C2
let string_of_neu = function
| N1 -> "1" | N2 -> "2" | N3 -> "3" | N4 -> "4"
(* Also we need types to distinguish the Higgs bosons. We follow the
conventions of Kuroda, which means
\begin{align}
\label{eq:higgs3}
H_1 &=
\begin{pmatrix}
\frac{1}{\sqrt{2}}
\bigl(
v_1 + H^0 \cos\alpha - h^0
\sin\alpha + \ii A^0 \sin\beta - \ii \phi^0 \cos\beta
\bigr) \\
H^- \sin\beta - \phi^- \cos\beta
\end{pmatrix},
\\ & \notag \\
H_2 & =
\begin{pmatrix}
H^+ \cos\beta + \phi^+ \sin\beta \\
\frac{1}{\sqrt{2}}
\bigl(
v_2 + H^0 \sin\alpha + h^0 \cos\alpha + \ii A^0 \cos\beta +
\ii \phi^0 \sin\beta
\bigr)
\end{pmatrix}
\label{eq:higgs4}
\end{align}
This is a different sign convention compared to, e.g.,
Weinberg's volume iii. We will refer to it as [GS+].
*)
type higgs =
| H1 (* the light scalar Higgs *)
| H2 (* the heavy scalar Higgs *)
| H3 (* the pseudoscalar Higgs *)
| H4 (* the charged Higgs *)
| H5 (* the neutral Goldstone boson *)
| H6 (* the charged Goldstone boson *)
| DH of higgs*higgs
let rec string_of_higgs = function
| H1 -> "h1" | H2 -> "h2" | H3 -> "h3" | H4 -> "h4"
| H5 -> "p1" | H6 -> "p2"
| DH (h1,h2) -> string_of_higgs h1 ^ string_of_higgs h2
type flavor =
| L of int | N of int
| U of int | D of int
| Sup of sfm*int | Sdown of sfm*int
| Ga | Wp | Wm | Z | Gl
| Slepton of sfm*int | Sneutrino of int
| Neutralino of neu | Chargino of char
| Gluino | Grino
| Phip | Phim | Phi0 | H_Heavy | H_Light | Hp | Hm | A
type gauge = unit
let gauge_symbol () =
failwith "Modellib_MSSM.MSSM.gauge_symbol: internal error"
(* At this point we will forget graviton and -tino. *)
let lep_family g = [ L g; N g; Slepton (M1,g);
Slepton (M2,g); Sneutrino g ]
let family g =
[ L g; N g; Slepton (M1,g); Slepton (M2,g); Sneutrino g;
U g; D g; Sup (M1,g); Sup (M2,g); Sdown (M1,g);
Sdown (M2,g)]
let external_flavors'' =
[ "1st Generation", ThoList.flatmap family [1; -1];
"2nd Generation", ThoList.flatmap family [2; -2];
"3rd Generation", ThoList.flatmap family [3; -3];
"Gauge Bosons", [Ga; Z; Wp; Wm; Gl];
"Charginos", [Chargino C1; Chargino C2; Chargino C1c; Chargino C2c];
"Neutralinos", [Neutralino N1; Neutralino N2; Neutralino N3;
Neutralino N4];
"Higgs Bosons", [H_Heavy; H_Light; Hp; Hm; A];
"Gluinos", [Gluino]]
let external_flavors' =
if Flags.gravitino then external_flavors'' @ ["Gravitino", [Grino]]
else
external_flavors''
let external_flavors () =
if Flags.include_goldstone then external_flavors' @ ["Goldstone Bosons",
[Phip; Phim; Phi0]]
else
external_flavors'
let flavors () = ThoList.flatmap snd (external_flavors ())
let spinor n =
if n >= 0 then
Spinor
else if
n <= 0 then
ConjSpinor
else
invalid_arg "Modellib_MSSM.MSSM.spinor: internal error"
let lorentz = function
| L g -> spinor g | N g -> spinor g
| U g -> spinor g | D g -> spinor g
| Chargino c -> spinor (int_of_char c)
| Ga -> Vector
(*i | Ga -> Ward_Vector i*)
| Gl -> Vector
| Wp | Wm | Z -> Massive_Vector
| H_Heavy | H_Light | Hp | Hm | A -> Scalar
| Phip | Phim | Phi0 -> Scalar
| Sup _ | Sdown _ | Slepton _ | Sneutrino _ -> Scalar
| Neutralino _ -> Majorana
| Gluino -> Majorana
| Grino -> Vectorspinor
let color = function
| U g -> Color.SUN (if g > 0 then 3 else -3)
| Sup (m,g) -> Color.SUN (if g > 0 then 3 else -3)
| D g -> Color.SUN (if g > 0 then 3 else -3)
| Sdown (m,g) -> Color.SUN (if g > 0 then 3 else -3)
| Gl | Gluino -> Color.AdjSUN 3
| _ -> Color.Singlet
let nc () = 3
let prop_spinor n =
if n >= 0 then
Prop_Spinor
else if
n <=0 then
Prop_ConjSpinor
else
invalid_arg "Modellib_MSSM.MSSM.prop_spinor: internal error"
let propagator = function
| L g -> prop_spinor g | N g -> prop_spinor g
| U g -> prop_spinor g | D g -> prop_spinor g
| Chargino c -> prop_spinor (int_of_char c)
| Ga | Gl -> Prop_Feynman
| Wp | Wm | Z -> Prop_Unitarity
| H_Heavy | H_Light | Hp | Hm | A -> Prop_Scalar
| Phip | Phim | Phi0 -> if Flags.include_goldstone then Prop_Scalar
else Only_Insertion
| Slepton _ | Sneutrino _ | Sup _ | Sdown _ -> Prop_Scalar
| Gluino -> Prop_Majorana | Neutralino _ -> Prop_Majorana
| Grino -> Only_Insertion
(* Note, that we define the gravitino only as an insertion since when using propagators
we are effectively going to a higher order in the gravitational coupling. This would
enforce us to also include higher-dimensional vertices with two gravitinos for
a consistent power counting in $1/M_{\text{Planck}}$. *)
(*i | Grino -> Prop_Vectorspinor i*)
(* Optionally, ask for the fudge factor treatment for the widths of
charged particles. Currently, this only applies to $W^\pm$ and top. *)
let width f =
if !use_fudged_width then
match f with
| Wp | Wm | U 3 | U (-3) -> Fudged
| _ -> !default_width
else
!default_width
(* For the Goldstone bosons we adopt the conventions of the Kuroda paper.
\begin{subequations}
\begin{equation}
H_1 \equiv \begin{pmatrix} \left( v_1 + H^0 \cos\alpha - h^0 \sin
\alpha + \ii A^0 \sin\beta - \ii \cos\beta \phi^0 \right) / \sqrt{2} \\
H^- \sin\beta - \phi^- \cos\beta \end{pmatrix}
\end{equation}
\begin{equation}
H_2 \equiv \begin{pmatrix} H^+ \cos\beta + \phi^+ \sin\beta \\ \left(
v_2 + H^0 \sin\alpha + h^0 \cos\alpha + \ii A^0 \cos\beta + \ii
\phi^0 \sin\beta \right) / \sqrt{2} \end{pmatrix}
\end{equation}
\end{subequations}
*)
let goldstone = function
| Wp -> Some (Phip, Coupling.Integer 1)
| Wm -> Some (Phim, Coupling.Integer 1)
| Z -> Some (Phi0, Coupling.Integer 1)
| _ -> None
let conjugate = function
| L g -> L (-g) | N g -> N (-g)
| U g -> U (-g) | D g -> D (-g)
| Sup (m,g) -> Sup (m,-g)
| Sdown (m,g) -> Sdown (m,-g)
| Slepton (m,g) -> Slepton (m,-g)
| Sneutrino g -> Sneutrino (-g)
| Gl -> Gl (* | Gl0 -> Gl0 *)
| Ga -> Ga | Z -> Z | Wp -> Wm | Wm -> Wp
| H_Heavy -> H_Heavy | H_Light -> H_Light | A -> A
| Hp -> Hm | Hm -> Hp
| Phip -> Phim | Phim -> Phip | Phi0 -> Phi0
| Gluino -> Gluino
| Grino -> Grino
| Neutralino n -> Neutralino n | Chargino c -> Chargino (conj_char c)
let fermion = function
| L g -> if g > 0 then 1 else -1
| N g -> if g > 0 then 1 else -1
| U g -> if g > 0 then 1 else -1
| D g -> if g > 0 then 1 else -1
| Gl | Ga | Z | Wp | Wm -> 0 (* | Gl0 -> 0 *)
| H_Heavy | H_Light | Hp | Hm | A -> 0
| Phip | Phim | Phi0 -> 0
| Neutralino _ -> 2
| Chargino c -> if (int_of_char c) > 0 then 1 else -1
| Sup _ -> 0 | Sdown _ -> 0
| Slepton _ -> 0 | Sneutrino _ -> 0
| Gluino | Grino -> 2
(* Because the O'Caml compiler only allows 248 constructors we must divide the
constants into subgroups of constants, e.g. for the Higgs couplings. In the
MSSM there are a lot of angles among the parameters, the Weinberg-angle, the
angle describing the Higgs vacuum structure, the mixing angle of the real
parts of the Higgs dubletts, the mixing angles of the sfermions. Therefore we
are going to define the trigonometric functions of those angles not as
constants but as functors of the angels. Sums and differences of angles are
only used as arguments for the $\alpha$ and $\beta$ angles, so it makes no
sense to define special functions for differences and sums of angles. *)
type angle =
| Thw | Al | Be | Th_SF of sff*int | Delta | CKM_12 | CKM_13 | CKM_23
let string_of_angle = function
| Thw -> "thw" | Al -> "al" | Be -> "be" | Delta -> "d"
| CKM_12 -> "ckm12" | CKM_13 -> "ckm13" | CKM_23 -> "ckm23"
| Th_SF (f,g) -> "th" ^ string_of_sff f ^ string_of_int g
(* We introduce a Boolean type vc as a pseudonym for Vertex Conjugator to
distinguish between vertices containing complex mixing matrices like the
CKM--matrix or the sfermion or neutralino/chargino--mixing matrices, which
have to become complex conjugated. The true--option stands for the conjugated
vertex, the false--option for the unconjugated vertex. *)
type vc = bool
type constant =
| Unit | Pi | Alpha_QED | Sin2thw
| Sin of angle | Cos of angle | E | G | Vev | Tanb | Tana
| Cos2be | Cos2al | Sin2be | Sin2al | Sin4al | Sin4be | Cos4be
| Cosapb | Cosamb | Sinapb | Sinamb | Cos2am2b | Sin2am2b
| Eidelta
| Mu | AU of int | AD of int | AL of int
| V_CKM of int*int | M_SF of sff*int*sfm*sfm
| M_V of char*char (* left chargino mixing matrix *)
| M_U of char*char (* right chargino mixing matrix *)
| M_N of neu*neu (* neutralino mixing matrix *)
| V_0 of neu*neu | A_0 of neu*neu | V_P of char*char | A_P of char*char
| L_CN of char*neu | R_CN of char*neu | L_NC of neu*char | R_NC of neu*char
(*i | L_NF of neu*sff*sfm | R_NF of neu*sff*sfm i*)
| S_NNH1 of neu*neu | P_NNH1 of neu*neu
| S_NNH2 of neu*neu | P_NNH2 of neu*neu
| S_NNA of neu*neu | P_NNA of neu*neu
| S_NNG of neu*neu | P_NNG of neu*neu
| L_CNG of char*neu | R_CNG of char*neu
| L_NCH of neu*char | R_NCH of neu*char
| Q_lepton | Q_up | Q_down | Q_charg
| G_Z | G_CC | G_CCQ of vc*int*int
| G_NC_neutrino | G_NC_lepton | G_NC_up | G_NC_down
| I_Q_W | I_G_ZWW | G_WWWW | G_ZZWW | G_PZWW | G_PPWW
| G_strong | G_SS | I_G_S | G_S_Sqrt
| Gs
| M of flavor | W of flavor
| G_NZN of neu*neu | G_CZC of char*char | G_NNA
| G_YUK of int*int
| G_YUK_1 of int*int | G_YUK_2 of int*int | G_YUK_3 of int*int
| G_YUK_4 of int*int | G_NHC of neu*char | G_CHN of char*neu
| G_YUK_C of vc*int*char*sff*sfm
| G_YUK_Q of vc*int*int*char*sff*sfm
| G_YUK_N of vc*int*neu*sff*sfm
| G_YUK_G of vc*int*sff*sfm
| G_NGC of neu*char | G_CGN of char*neu
| SUM_1
| G_NWC of neu*char | G_CWN of char*neu
| G_CH1C of char*char | G_CH2C of char*char | G_CAC of char*char
| G_CGC of char*char
| G_SWS of vc*int*int*sfm*sfm
| G_SLSNW of vc*int*sfm
| G_ZSF of sff*int*sfm*sfm
| G_CICIH1 of neu*neu | G_CICIH2 of neu*neu | G_CICIA of neu*neu
| G_CICIG of neu*neu
| G_GH of int | G_GHGo of int
| G_GLGLH | G_GLGLHH | G_GLGLA | G_PPH | G_PPHH | G_PPA
| G_WWSFSF of sff*int*sfm*sfm
| G_WPSLSN of vc*int*sfm
| G_H3 of int | G_H4 of int
| G_HGo3 of int | G_HGo4 of int | G_GG4 of int
| G_H1SFSF of sff*int*sfm*sfm | G_H2SFSF of sff*int*sfm*sfm
| G_ASFSF of sff*int*sfm*sfm
| G_HSNSL of vc*int*sfm
| G_GoSFSF of sff*int*sfm*sfm
| G_GoSNSL of vc*int*sfm
| G_HSUSD of vc*sfm*sfm*int*int | G_GSUSD of vc*sfm*sfm*int*int
| G_WPSUSD of vc*sfm*sfm*int*int
| G_WZSUSD of vc*sfm*sfm*int*int
| G_WZSLSN of vc*int*sfm | G_GlGlSQSQ
| G_PPSFSF of sff
| G_ZZSFSF of sff*int*sfm*sfm | G_ZPSFSF of sff*int*sfm*sfm
| G_GlZSFSF of sff*int*sfm*sfm | G_GlPSQSQ
| G_GlWSUSD of vc*sfm*sfm*int*int
| G_GH4 of int | G_GHGo4 of int
| G_H1H2SFSF of sff*sfm*sfm*int
| G_H1H1SFSF of sff*sfm*sfm*int
| G_H2H2SFSF of sff*sfm*sfm*int
| G_HHSFSF of sff*sfm*sfm*int
| G_AASFSF of sff*sfm*sfm*int
| G_HH1SLSN of vc*sfm*int | G_HH2SLSN of vc*sfm*int
| G_HASLSN of vc*sfm*int
| G_HH1SUSD of vc*sfm*sfm*int*int
| G_HH2SUSD of vc*sfm*sfm*int*int
| G_HASUSD of vc*sfm*sfm*int*int
| G_AG0SFSF of sff*sfm*sfm*int
| G_HGSFSF of sff*sfm*sfm*int
| G_GGSFSF of sff*sfm*sfm*int
| G_G0G0SFSF of sff*sfm*sfm*int
| G_HGSNSL of vc*sfm*int | G_H1GSNSL of vc*sfm*int
| G_H2GSNSL of vc*sfm*int | G_AGSNSL of vc*sfm*int
| G_GGSNSL of vc*sfm*int
| G_HGSUSD of vc*sfm*sfm*int*int
| G_H1GSUSD of vc*sfm*sfm*int*int
| G_H2GSUSD of vc*sfm*sfm*int*int
| G_AGSUSD of vc*sfm*sfm*int*int
| G_GGSUSD of vc*sfm*sfm*int*int
| G_SN4 of int*int
| G_SN2SL2_1 of sfm*sfm*int*int | G_SN2SL2_2 of sfm*sfm*int*int
| G_SF4 of sff*sff*sfm*sfm*sfm*sfm*int*int
| G_SF4_3 of sff*sff*sfm*sfm*sfm*sfm*int*int*int
| G_SF4_4 of sff*sff*sfm*sfm*sfm*sfm*int*int*int*int
| G_SL4 of sfm*sfm*sfm*sfm*int
| G_SL4_2 of sfm*sfm*sfm*sfm*int*int
| G_SN2SQ2 of sff*sfm*sfm*int*int
| G_SL2SQ2 of sff*sfm*sfm*sfm*sfm*int*int
| G_SUSDSNSL of vc*sfm*sfm*sfm*int*int*int
| G_SU4 of sfm*sfm*sfm*sfm*int
| G_SU4_2 of sfm*sfm*sfm*sfm*int*int
| G_SD4 of sfm*sfm*sfm*sfm*int
| G_SD4_2 of sfm*sfm*sfm*sfm*int*int
| G_SU2SD2 of sfm*sfm*sfm*sfm*int*int*int*int
| G_HSF31 of higgs*int*sfm*sfm*sff*sff
| G_HSF32 of higgs*int*int*sfm*sfm*sff*sff
| G_HSF41 of higgs*int*sfm*sfm*sff*sff
| G_HSF42 of higgs*int*int*sfm*sfm*sff*sff
| G_Grav | G_Gr_Ch of char | G_Gr_Z_Neu of neu
| G_Gr_A_Neu of neu | G_Gr4_Neu of neu
| G_Gr4_A_Ch of char | G_Gr4_Z_Ch of char
| G_Grav_N | G_Grav_U of int*sfm | G_Grav_D of int*sfm
| G_Grav_L of int*sfm | G_Grav_Uc of int*sfm | G_Grav_Dc of int*sfm
| G_Grav_Lc of int*sfm | G_GravGl
| G_Gr_H_Ch of char | G_Gr_H1_Neu of neu
| G_Gr_H2_Neu of neu | G_Gr_H3_Neu of neu
| G_Gr4A_Sl of int*sfm | G_Gr4A_Slc of int*sfm
| G_Gr4A_Su of int*sfm | G_Gr4A_Suc of int*sfm
| G_Gr4A_Sd of int*sfm | G_Gr4A_Sdc of int*sfm
| G_Gr4Z_Sn | G_Gr4Z_Snc
| G_Gr4Z_Sl of int*sfm | G_Gr4Z_Slc of int*sfm
| G_Gr4Z_Su of int*sfm | G_Gr4Z_Suc of int*sfm
| G_Gr4Z_Sd of int*sfm | G_Gr4Z_Sdc of int*sfm
| G_Gr4W_Sl of int*sfm | G_Gr4W_Slc of int*sfm
| G_Gr4W_Su of int*sfm | G_Gr4W_Suc of int*sfm
| G_Gr4W_Sd of int*sfm | G_Gr4W_Sdc of int*sfm
| G_Gr4W_Sn | G_Gr4W_Snc
| G_Gr4Gl_Su of int*sfm | G_Gr4Gl_Suc of int*sfm
| G_Gr4Gl_Sd of int*sfm | G_Gr4Gl_Sdc of int*sfm
| G_Gr4_Z_H1 of neu | G_Gr4_Z_H2 of neu | G_Gr4_Z_H3 of neu
| G_Gr4_W_H of neu | G_Gr4_W_Hc of neu | G_Gr4_H_A of char
| G_Gr4_H_Z of char
(* Two integer counters for the QCD and EW order of the couplings. *)
- type orders = int * int
+ type coupling_order = QCD | EW
+ let all_coupling_orders () = [QCD; EW]
+ let coupling_order_to_string = function
+ | QCD -> "QCD"
+ | EW -> "EW"
- let orders = function
- | _ -> (0,0)
+ let coupling_orders = function
+ | _ -> failwith "Modellib_MSSM.MSSM.orders: not implemented yet!"
let ferm_of_sff = function
| SL, g -> (L g) | SN, g -> (N g)
| SU, g -> (U g) | SD, g -> (D g)
(* \begin{subequations}
\begin{align}
\alpha_{\text{QED}} &= \frac{1}{137.0359895} \\
\sin^2\theta_w &= 0.23124
\end{align}
\end{subequations}
Here we must perhaps allow for complex input parameters. So split them
into their modulus and their phase. At first, we leave them real; the
generalization to complex parameters is obvious. *)
module Ch = Charges.QQ
let ( // ) = Algebra.Small_Rational.make
let generation' = function
| 1 -> [ 1//1; 0//1; 0//1]
| 2 -> [ 0//1; 1//1; 0//1]
| 3 -> [ 0//1; 0//1; 1//1]
| -1 -> [-1//1; 0//1; 0//1]
| -2 -> [ 0//1; -1//1; 0//1]
| -3 -> [ 0//1; 0//1; -1//1]
| n -> invalid_arg ("MSSM.generation': " ^ string_of_int n)
let generation f =
if Flags.ckm_present then
[]
else
match f with
| L n | N n | U n | D n | Sup (_,n)
| Sdown (_,n) | Slepton (_,n)
| Sneutrino n -> generation' n
| _ -> [0//1; 0//1; 0//1]
let charge = function
| L n -> if n > 0 then -1//1 else 1//1
| Slepton (_,n) -> if n > 0 then -1//1 else 1//1
| N n -> 0//1
| Sneutrino n -> 0//1
| U n -> if n > 0 then 2//3 else -2//3
| Sup (_,n) -> if n > 0 then 2//3 else -2//3
| D n -> if n > 0 then -1//3 else 1//3
| Sdown (_,n) -> if n > 0 then -1//3 else 1//3
| Gl | Ga | Z | Neutralino _ | Gluino -> 0//1
| Wp -> 1//1
| Wm -> -1//1
| H_Heavy | H_Light | Phi0 -> 0//1
| Hp | Phip -> 1//1
| Hm | Phim -> -1//1
| Chargino (C1 | C2) -> 1//1
| Chargino (C1c | C2c) -> -1//1
| _ -> 0//1
let lepton = function
| L n | N n -> if n > 0 then 1//1 else -1//1
| Slepton (_,n)
| Sneutrino n -> if n > 0 then 1//1 else -1//1
| _ -> 0//1
let baryon = function
| U n | D n -> if n > 0 then 1//1 else -1//1
| Sup (_,n) | Sdown (_,n) -> if n > 0 then 1//1 else -1//1
| _ -> 0//1
let charges f =
[ charge f; lepton f; baryon f] @ generation f
let parameters () =
{ input = [];
derived = [];
derived_arrays = [] }
module F = Modeltools.Fusions (struct
type f = flavor
type c = constant
let compare = compare
let conjugate = conjugate
end)
(* For the couplings there are generally two possibilities concerning the
sign of the covariant derivative.
\begin{equation}
{\rm CD}^\pm = \partial_\mu \pm \ii g T^a A^a_\mu
\end{equation}
The particle data group defines the signs consistently to be positive.
Since the convention for that signs also influence the phase definitions
of the gaugino/higgsino fields via the off-diagonal entries in their
mass matrices it would be the best to adopt that convention. *)
(*** REVISED: Compatible with CD+. ***)
let electromagnetic_currents_3 g =
[((U (-g), Ga, U g), FBF (1, Psibar, V, Psi), Q_up);
((D (-g), Ga, D g), FBF (1, Psibar, V, Psi), Q_down);
((L (-g), Ga, L g), FBF (1, Psibar, V, Psi), Q_lepton) ]
(*** REVISED: Compatible with CD+. ***)
let electromagnetic_sfermion_currents g m =
[ ((Ga, Slepton (m,-g), Slepton (m,g)), Vector_Scalar_Scalar 1, Q_lepton);
((Ga, Sup (m,-g), Sup (m,g)), Vector_Scalar_Scalar 1, Q_up);
((Ga, Sdown (m,-g), Sdown (m,g)), Vector_Scalar_Scalar 1, Q_down) ]
(*** REVISED: Compatible with CD+. ***)
let electromagnetic_currents_2 c =
let cc = conj_char c in
[ ((Chargino cc, Ga, Chargino c), FBF (1, Psibar, V, Psi), Q_charg) ]
(*** REVISED: Compatible with CD+. ***)
let neutral_currents g =
[ ((L (-g), Z, L g), FBF (1, Psibar, VA, Psi), G_NC_lepton);
((N (-g), Z, N g), FBF (1, Psibar, VA, Psi), G_NC_neutrino);
((U (-g), Z, U g), FBF (1, Psibar, VA, Psi), G_NC_up);
((D (-g), Z, D g), FBF (1, Psibar, VA, Psi), G_NC_down) ]
(* \begin{equation}
\mathcal{L}_{\textrm{CC}} =
\mp \frac{g}{2\sqrt2} \sum_i \bar\psi_i \gamma^\mu
(1-\gamma_5)(T^+W^+_\mu+T^-W^-_\mu)\psi_i ,
\end{equation}
where the sign corresponds to $\text{CD}_\pm$, respectively. *)
(*** REVISED: Compatible with CD+. ***)
(* Remark: The definition with the other sign compared to the SM files
comes from the fact that $g_{cc} = 1/(2\sqrt{2})$ is used
overwhelmingly often in the SUSY Feynman rules, so that JR
decided to use a different definiton for [g_cc] in SM and MSSM. *)
let charged_currents g =
[ ((L (-g), Wm, N g), FBF ((-1), Psibar, VL, Psi), G_CC);
((N (-g), Wp, L g), FBF ((-1), Psibar, VL, Psi), G_CC) ]
(* The quark with the inverted generation (the antiparticle) is the outgoing
one, the other the incoming. The vertex attached to the outgoing up-quark
contains the CKM matrix element {\em not} complex conjugated, while the
vertex with the outgoing down-quark has the conjugated CKM matrix
element. *)
(*** REVISED: Compatible with CD+. ***)
let charged_quark_currents g h =
[ ((D (-g), Wm, U h), FBF ((-1), Psibar, VL, Psi), G_CCQ (true,g,h));
((U (-g), Wp, D h), FBF ((-1), Psibar, VL, Psi), G_CCQ (false,h,g))]
(*** REVISED: Compatible with CD+. ***)
let charged_chargino_currents n c =
let cc = conj_char c in
[ ((Chargino cc, Wp, Neutralino n),
FBF (1, Psibar, VLR, Chi), G_CWN (c,n));
((Neutralino n, Wm, Chargino c),
FBF (1, Chibar, VLR, Psi), G_NWC (n,c)) ]
(*** REVISED: Compatible with CD+. ***)
let charged_slepton_currents g m =
[ ((Wm, Slepton (m,-g), Sneutrino g), Vector_Scalar_Scalar (-1), G_SLSNW
(true,g,m));
((Wp, Slepton (m,g), Sneutrino (-g)), Vector_Scalar_Scalar 1, G_SLSNW
(false,g,m)) ]
(*** REVISED: Compatible with CD+. ***)
let charged_squark_currents' g h m1 m2 =
[ ((Wm, Sup (m1,g), Sdown (m2,-h)), Vector_Scalar_Scalar (-1), G_SWS
(true,g,h,m1,m2));
((Wp, Sup (m1,-g), Sdown (m2,h)), Vector_Scalar_Scalar 1, G_SWS
(false,g,h,m1,m2)) ]
let charged_squark_currents g h = List.flatten (Product.list2
(charged_squark_currents' g h) [M1;M2] [M1;M2])
(*** REVISED: Compatible with CD+. ***)
let neutral_sfermion_currents' g m1 m2 =
[ ((Z, Slepton (m1,-g), Slepton (m2,g)), Vector_Scalar_Scalar (-1), G_ZSF
(SL,g,m1,m2));
((Z, Sup (m1,-g), Sup (m2,g)), Vector_Scalar_Scalar (-1), G_ZSF
(SU,g,m1,m2));
((Z, Sdown (m1,-g), Sdown (m2,g)), Vector_Scalar_Scalar (-1), G_ZSF
(SD,g,m1,m2)) ]
let neutral_sfermion_currents g =
List.flatten (Product.list2 (neutral_sfermion_currents'
g) [M1;M2] [M1;M2]) @
[ ((Z, Sneutrino (-g), Sneutrino g), Vector_Scalar_Scalar (-1), G_ZSF
(SN,g,M1,M1)) ]
(* The reality of the coupling of the Z-boson to two identical neutralinos
makes the vector part of the coupling vanish. So we distinguish them not
by the name but by the structure of the couplings. *)
(*** REVISED: Compatible with CD+. ***)
let neutral_Z_1 (n,m) =
[ ((Neutralino n, Z, Neutralino m), FBF (1, Chibar, VA, Chi),
(G_NZN (n,m))) ]
(*** REVISED: Compatible with CD+. ***)
let neutral_Z_2 n =
[ ((Neutralino n, Z, Neutralino n), FBF (1, Chibar, Coupling.A, Chi),
(G_NZN (n,n)) )]
(* For very compressed spectra, radiative decays of the next-to-lightest neutralino
become important. The formula can be found Haber/Wyler, 1989. In abuse, we
include this loop-induced coupling together in the same model variant with the
triangle Higgs couplings. *)
let neutral_A =
if Flags.higgs_triangle then
[ ((Neutralino N2, Ga, Neutralino N1), FBF (1, Chibar, TVAM, Chi), G_NNA) ]
else
[]
(*** REVISED: Compatible with CD+. ***)
let charged_Z c1 c2 =
let cc1 = conj_char c1 in
((Chargino cc1, Z, Chargino c2), FBF ((-1), Psibar, VA, Psi),
G_CZC (c1,c2))
(*** REVISED: Compatible with CD+. ***)
let yukawa_v =
[ ((Gluino, Gl, Gluino), FBF (1, Chibar, V, Chi), Gs) ]
(*** REVISED: Independent of the sign of CD. ***)
let yukawa_higgs g =
[ ((N (-g), Hp, L g), FBF (1, Psibar, Coupling.SR, Psi), G_YUK (6,g));
((L (-g), Hm, N g), FBF (1, Psibar, Coupling.SL, Psi), G_YUK (6,g));
((L (-g), H_Heavy, L g), FBF (1, Psibar, S, Psi), G_YUK (7,g));
((L (-g), H_Light, L g), FBF (1, Psibar, S, Psi), G_YUK (8,g));
((L (-g), A, L g), FBF (1, Psibar, P, Psi), G_YUK (9,g));
((U (-g), H_Heavy, U g), FBF (1, Psibar, S, Psi), G_YUK (10,g));
((U (-g), H_Light, U g), FBF (1, Psibar, S, Psi), G_YUK (11,g));
((U (-g), A, U g), FBF (1, Psibar, P, Psi), G_YUK (12,g));
((D (-g), H_Heavy, D g), FBF (1, Psibar, S, Psi), G_YUK (13,g));
((D (-g), H_Light, D g), FBF (1, Psibar, S, Psi), G_YUK (14,g));
((D (-g), A, D g), FBF (1, Psibar, P, Psi), G_YUK (15,g)) ]
(*** REVISED: Compatible with CD+ and GS+. ***)
let yukawa_goldstone g =
[ ((N (-g), Phip, L g), FBF (1, Psibar, Coupling.SR, Psi), G_YUK (19,g));
((L (-g), Phim, N g), FBF (1, Psibar, Coupling.SL, Psi), G_YUK (19,g));
((L (-g), Phi0, L g), FBF (1, Psibar, P, Psi), G_YUK (16,g));
((U (-g), Phi0, U g), FBF (1, Psibar, P, Psi), G_YUK (17,g));
((D (-g), Phi0, D g), FBF (1, Psibar, P, Psi), G_YUK (18,g)) ]
(*** REVISED: Independent of the sign of CD. ***)
let yukawa_higgs_quark (g,h) =
[ ((U (-g), Hp, D h), FBF (1, Psibar, SLR, Psi), G_YUK_1 (g, h));
((D (-h), Hm, U g), FBF (1, Psibar, SLR, Psi), G_YUK_2 (g, h)) ]
(*** REVISED: Compatible with CD+ and GS+. ***)
let yukawa_goldstone_quark g h =
[ ((U (-g), Phip, D h), FBF (1, Psibar, SLR, Psi), G_YUK_3 (g, h));
((D (-h), Phim, U g), FBF (1, Psibar, SLR, Psi), G_YUK_4 (g, h)) ]
(*** REVISED: Compatible with CD+. *)
let yukawa_higgs_2' (c1,c2) =
let cc1 = conj_char c1 in
[ ((Chargino cc1, H_Heavy, Chargino c2), FBF (1, Psibar, SLR, Psi),
G_CH2C (c1,c2));
((Chargino cc1, H_Light, Chargino c2), FBF (1, Psibar, SLR, Psi),
G_CH1C (c1,c2));
((Chargino cc1, A, Chargino c2), FBF (1, Psibar, SLR, Psi),
G_CAC (c1,c2)) ]
let yukawa_higgs_2'' c =
let cc = conj_char c in
[ ((Chargino cc, H_Heavy, Chargino c), FBF (1, Psibar, S, Psi),
G_CH2C (c,c));
((Chargino cc, H_Light, Chargino c), FBF (1, Psibar, S, Psi),
G_CH1C (c,c));
((Chargino cc, A, Chargino c), FBF (1, Psibar, P, Psi),
G_CAC (c,c)) ]
let yukawa_higgs_2 =
ThoList.flatmap yukawa_higgs_2' [(C1,C2);(C2,C1)] @
ThoList.flatmap yukawa_higgs_2'' [C1;C2]
(*** REVISED: Compatible with CD+ and GS+. ***)
let yukawa_goldstone_2' (c1,c2) =
let cc1 = conj_char c1 in
[ ((Chargino cc1, Phi0, Chargino c2), FBF (1, Psibar, SLR, Psi),
G_CGC (c1,c2)) ]
let yukawa_goldstone_2'' c =
let cc = conj_char c in
[ ((Chargino cc, Phi0, Chargino c), FBF (1, Psibar, P, Psi),
G_CGC (c,c)) ]
let yukawa_goldstone_2 =
ThoList.flatmap yukawa_goldstone_2' [(C1,C2);(C2,C1)] @
ThoList.flatmap yukawa_goldstone_2'' [C1;C2]
(*** REVISED: Compatible with CD+. ***)
let higgs_charg_neutr n c =
let cc = conj_char c in
[ ((Neutralino n, Hm, Chargino c), FBF (-1, Chibar, SLR, Psi),
G_NHC (n,c));
((Chargino cc, Hp, Neutralino n), FBF (-1, Psibar, SLR, Chi),
G_CHN (c,n)) ]
(*** REVISED: Compatible with CD+ and GS+. ***)
let goldstone_charg_neutr n c =
let cc = conj_char c in
[ ((Neutralino n, Phim, Chargino c), FBF (1, Chibar, SLR, Psi),
G_NGC (n,c));
((Chargino cc, Phip, Neutralino n), FBF (1, Psibar, SLR, Chi),
G_CGN (c,n)) ]
(*** REVISED: Compatible with CD+. ***)
let higgs_neutr' (n,m) =
[ ((Neutralino n, H_Heavy, Neutralino m), FBF (1, Chibar, SP, Chi),
G_CICIH2 (n,m));
((Neutralino n, H_Light, Neutralino m), FBF (1, Chibar, SP, Chi),
G_CICIH1 (n,m));
((Neutralino n, A, Neutralino m), FBF (1, Chibar, SP, Chi),
G_CICIA (n,m)) ]
let higgs_neutr'' n =
[ ((Neutralino n, H_Heavy, Neutralino n), FBF (1, Chibar, S, Chi),
G_CICIH2 (n,n));
((Neutralino n, H_Light, Neutralino n), FBF (1, Chibar, S, Chi),
G_CICIH1 (n,n));
((Neutralino n, A, Neutralino n), FBF (1, Chibar, P, Chi),
G_CICIA (n,n)) ]
let higgs_neutr =
ThoList.flatmap higgs_neutr' [(N1,N2);(N1,N3);(N1,N4);
(N2,N3);(N2,N4);(N3,N4)] @
ThoList.flatmap higgs_neutr'' [N1;N2;N3;N4]
(*** REVISED: Compatible with CD+ and GS+. ***)
let goldstone_neutr' (n,m) =
[ ((Neutralino n, Phi0, Neutralino m), FBF (1, Chibar, SP, Chi),
G_CICIG (n,m)) ]
let goldstone_neutr'' n =
[ ((Neutralino n, Phi0, Neutralino n), FBF (1, Chibar, P, Chi),
G_CICIG (n,n)) ]
let goldstone_neutr =
ThoList.flatmap goldstone_neutr' [(N1,N2);(N1,N3);(N1,N4);
(N2,N3);(N2,N4);(N3,N4)] @
ThoList.flatmap goldstone_neutr'' [N1;N2;N3;N4]
(*** REVISED: Compatible with CD+. ***)
let yukawa_n_1 n g =
[ ((Neutralino n, Slepton (M1,-g), L g), FBF (1, Chibar, Coupling.SL,
Psi), G_YUK_N (true,g,n,SL,M1));
((Neutralino n, Slepton (M2,-g), L g), FBF (1, Chibar, SR, Psi),
G_YUK_N (true,g,n,SL,M2));
((L (-g), Slepton (M1,g), Neutralino n), FBF (1, Psibar, SR, Chi),
G_YUK_N (false,g,n,SL,M1));
((L (-g), Slepton (M2,g), Neutralino n), FBF (1, Psibar, Coupling.SL,
Chi), G_YUK_N (false,g,n,SL,M2));
((Neutralino n, Sup (M1,-g), U g), FBF (1, Chibar, Coupling.SL,
Psi), G_YUK_N (true,g,n,SU,M1));
((Neutralino n, Sup (M2,-g), U g), FBF (1, Chibar, SR, Psi),
G_YUK_N (true,g,n,SU,M2));
((U (-g), Sup (M1,g), Neutralino n), FBF (1, Psibar, SR, Chi),
G_YUK_N (false,g,n,SU,M1));
((U (-g), Sup (M2,g), Neutralino n), FBF (1, Psibar, Coupling.SL,
Chi), G_YUK_N (false,g,n,SU,M2));
((Neutralino n, Sdown (M1,-g), D g), FBF (1, Chibar, Coupling.SL,
Psi), G_YUK_N (true,g,n,SD,M1));
((Neutralino n, Sdown (M2,-g), D g), FBF (1, Chibar, SR, Psi),
G_YUK_N (true,g,n,SD,M2));
((D (-g), Sdown (M1,g), Neutralino n), FBF (1, Psibar, SR, Chi),
G_YUK_N (false,g,n,SD,M1));
((D (-g), Sdown (M2,g), Neutralino n), FBF (1, Psibar, Coupling.SL,
Chi), G_YUK_N (false,g,n,SD,M2)) ]
let yukawa_n_2 n m =
[ ((Neutralino n, Slepton (m,-3), L 3), FBF (1, Chibar, SLR, Psi),
G_YUK_N (true,3,n,SL,m));
((L (-3), Slepton (m,3), Neutralino n), FBF (1, Psibar, SLR, Chi),
G_YUK_N (false,3,n,SL,m));
((Neutralino n, Sup (m,-3), U 3), FBF (1, Chibar, SLR, Psi),
G_YUK_N (true,3,n,SU,m));
((U (-3), Sup (m,3), Neutralino n), FBF (1, Psibar, SLR, Chi),
G_YUK_N (false,3,n,SU,m));
((Neutralino n, Sdown (m,-3), D 3), FBF (1, Chibar, SLR, Psi),
G_YUK_N (true,3,n,SD,m));
((D (-3), Sdown (m,3), Neutralino n), FBF (1, Psibar, SLR, Chi),
G_YUK_N (false,3,n,SD,m)) ]
let yukawa_n_3 n g =
[ ((Neutralino n, Sneutrino (-g), N g), FBF (1, Chibar, Coupling.SL,
Psi), G_YUK_N (true,g,n,SN,M1));
((N (-g), Sneutrino g, Neutralino n), FBF (1, Psibar, SR, Chi),
G_YUK_N (false,g,n,SN,M1)) ]
let yukawa_n_4 g =
[ ((U (-g), Sup (M1,g), Gluino), FBF ((-1), Psibar, SR, Chi), G_S_Sqrt);
((D (-g), Sdown (M1,g), Gluino), FBF ((-1), Psibar, SR, Chi), G_S_Sqrt);
((Gluino, Sup (M1,-g), U g), FBF ((-1), Chibar, Coupling.SL, Psi), G_S_Sqrt);
((Gluino, Sdown (M1,-g), D g), FBF ((-1), Chibar, Coupling.SL, Psi), G_S_Sqrt);
((U (-g), Sup (M2,g), Gluino), FBF (1, Psibar, Coupling.SL, Chi), G_S_Sqrt);
((D (-g), Sdown (M2,g), Gluino), FBF (1, Psibar, Coupling.SL, Chi), G_S_Sqrt);
((Gluino, Sup (M2,-g), U g), FBF (1, Chibar, SR, Psi), G_S_Sqrt);
((Gluino, Sdown (M2,-g), D g), FBF (1, Chibar, SR, Psi), G_S_Sqrt)]
let yukawa_n_5 m =
[ ((U (-3), Sup (m,3), Gluino), FBF (1, Psibar, SLR, Chi),
G_YUK_G (false,3,SU,m));
((D (-3), Sdown (m,3), Gluino), FBF (1, Psibar, SLR, Chi),
G_YUK_G (false,3,SD,m));
((Gluino, Sup (m,-3), U 3), FBF (1, Chibar, SLR, Psi),
G_YUK_G (true,3,SU,m));
((Gluino, Sdown (m,-3), D 3), FBF (1, Chibar, SLR, Psi),
G_YUK_G (true,3,SD,m))]
let yukawa_n =
List.flatten (Product.list2 yukawa_n_1 [N1;N2;N3;N4] [1;2]) @
List.flatten (Product.list2 yukawa_n_2 [N1;N2;N3;N4] [M1;M2]) @
List.flatten (Product.list2 yukawa_n_3 [N1;N2;N3;N4] [1;2;3]) @
ThoList.flatmap yukawa_n_4 [1;2] @
ThoList.flatmap yukawa_n_5 [M1;M2]
(*** REVISED: Compatible with CD+. ***)
let yukawa_c_1 c g =
let cc = conj_char c in
[ ((L (-g), Sneutrino g, Chargino cc), BBB (1, Psibar, Coupling.SR,
Psibar), G_YUK_C (true,g,c,SN,M1));
((Chargino c, Sneutrino (-g), L g), PBP (1, Psi, Coupling.SL, Psi),
G_YUK_C (false,g,c,SN,M1)) ]
let yukawa_c_2 c =
let cc = conj_char c in
[ ((L (-3), Sneutrino 3, Chargino cc), BBB (1, Psibar, SLR,
Psibar), G_YUK_C (true,3,c,SN,M1));
((Chargino c, Sneutrino (-3), L 3), PBP (1, Psi, SLR, Psi),
G_YUK_C (false,3,c,SN,M1)) ]
let yukawa_c_3 c m g =
let cc = conj_char c in
[ ((N (-g), Slepton (m,g), Chargino c), FBF (1, Psibar, Coupling.SR,
Psi), G_YUK_C (true,g,c,SL,m));
((Chargino cc, Slepton (m,-g), N g), FBF (1, Psibar, Coupling.SL,
Psi), G_YUK_C (false,g,c,SL,m)) ]
let yukawa_c c =
ThoList.flatmap (yukawa_c_1 c) [1;2] @
yukawa_c_2 c @
List.flatten (Product.list2 (yukawa_c_3 c) [M1] [1;2]) @
List.flatten (Product.list2 (yukawa_c_3 c) [M1;M2] [3])
(*** REVISED: Compatible with CD+. ***)
let yukawa_cq' c (g,h) m =
let cc = conj_char c in
[ ((Chargino c, Sup (m,-g), D h), PBP (1, Psi, SLR, Psi),
G_YUK_Q (false,g,h,c,SU,m));
((D (-h), Sup (m,g), Chargino cc), BBB (1, Psibar, SLR, Psibar),
G_YUK_Q (true,g,h,c,SU,m));
((Chargino cc, Sdown (m,-h), U g), FBF (1, Psibar, SLR, Psi),
G_YUK_Q (true,g,h,c,SD,m));
((U (-g), Sdown (m,h), Chargino c), FBF (1, Psibar, SLR, Psi),
G_YUK_Q (false,g,h,c,SD,m)) ]
let yukawa_cq'' c (g,h) =
let cc = conj_char c in
[ ((Chargino c, Sup (M1,-g), D h), PBP (1, Psi, Coupling.SL, Psi),
G_YUK_Q (false,g,h,c,SU,M1));
((D (-h), Sup (M1,g), Chargino cc),
BBB (1, Psibar, Coupling.SR, Psibar), G_YUK_Q (true,g,h,c,SU,M1));
((Chargino cc, Sdown (M1,-h), U g),
FBF (1, Psibar, Coupling.SL, Psi), G_YUK_Q (true,g,h,c,SD,M1));
((U (-g), Sdown (M1,h), Chargino c),
FBF (1, Psibar, Coupling.SR, Psi), G_YUK_Q (false,g,h,c,SD,M1)) ]
let yukawa_cq c =
if Flags.ckm_present then
List.flatten (Product.list2 (yukawa_cq' c) [(1,3);(2,3);(3,3);
(3,2);(3,1)] [M1;M2]) @
ThoList.flatmap (yukawa_cq'' c) [(1,1);(1,2);(2,1);(2,2)]
else
ThoList.flatmap (yukawa_cq' c (3,3)) [M1;M2] @
ThoList.flatmap (yukawa_cq'' c) [(1,1);(2,2)]
(*** REVISED: Compatible with CD+.
Remark: Singlet and octet gluon exchange. The coupling is divided by
sqrt(2) to account for the correct normalization of the Lie algebra
generators.
***)
let col_currents g =
[ ((D (-g), Gl, D g), FBF ((-1), Psibar, V, Psi), Gs);
((U (-g), Gl, U g), FBF ((-1), Psibar, V, Psi), Gs)]
(*** REVISED: Compatible with CD+.
Remark: Singlet and octet gluon exchange. The coupling is divided by
sqrt(2) to account for the correct normalization of the Lie algebra
generators.
***)
let col_sfermion_currents g m =
[ ((Gl, Sup (m,-g), Sup (m,g)), Vector_Scalar_Scalar (-1), Gs);
((Gl, Sdown (m,-g), Sdown (m,g)), Vector_Scalar_Scalar (-1), Gs)]
(* The gravitino coupling is generically $1/(4 M_{Pl.})$ *)
(*** Triple vertices containing graivitinos. ***)
let triple_gravitino' g =
[ ((Grino, Sneutrino (-g), N g), GBG (1, Gravbar, Coupling.SL, Psi), G_Grav_N);
((N (-g), Sneutrino g, Grino), GBG (1, Psibar, Coupling.SL, Grav), G_Grav_N)]
let triple_gravitino'' g m =
[ ((Grino, Slepton (m, -g), L g), GBG (1, Gravbar, SLR, Psi), G_Grav_L (g,m));
((L (-g), Slepton (m, g), Grino), GBG (1, Psibar, SLR, Grav), G_Grav_Lc (g,m));
((Grino, Sup (m, -g), U g), GBG (1, Gravbar, SLR, Psi), G_Grav_U (g,m));
((U (-g), Sup (m, g), Grino), GBG (1, Psibar, SLR, Grav), G_Grav_Uc (g,m));
((Grino, Sdown (m, -g), D g), GBG (1, Gravbar, SLR, Psi), G_Grav_D (g,m));
((D (-g), Sdown (m, g), Grino), GBG (1, Psibar, SLR, Grav), G_Grav_Dc (g,m)) ]
let higgs_ch_gravitino c =
let cc = conj_char c in
[ ((Grino, Hm, Chargino c), GBG (1, Gravbar, SLR, Psi), G_Gr_H_Ch c);
((Chargino cc, Hp, Grino), GBG (1, Psibar, SLR, Grav), G_Gr_H_Ch cc) ]
let higgs_neu_gravitino n =
[ ((Grino, H_Light, Neutralino n), GBG (1, Gravbar, SLR, Chi), G_Gr_H1_Neu n);
((Grino, H_Heavy, Neutralino n), GBG (1, Gravbar, SLR, Chi), G_Gr_H2_Neu n);
((Grino, A, Neutralino n), GBG (1, Gravbar, SLR, Chi), G_Gr_H3_Neu n) ]
let gravitino_gaugino_3 =
[ ((Grino, Gl, Gluino), GBG (1, Gravbar, V, Chi), G_Grav);
((Gluino, Gl, Grino), GBG (1, Chibar, V, Grav), G_Grav);
((Chargino C1c, Wp, Grino), GBG (1, Psibar, VLR, Grav), G_Gr_Ch C1);
((Chargino C2c, Wp, Grino), GBG (1, Psibar, VLR, Grav), G_Gr_Ch C2);
((Grino, Wm, Chargino C1), GBG (1, Gravbar, VLR, Psi), G_Gr_Ch C1c);
((Grino, Wm, Chargino C2), GBG (1, Gravbar, VLR, Psi), G_Gr_Ch C2c);
((Grino, Z, Neutralino N1), GBG (1, Gravbar, VLR, Chi), G_Gr_Z_Neu N1);
((Grino, Z, Neutralino N2), GBG (1, Gravbar, VLR, Chi), G_Gr_Z_Neu N2);
((Grino, Z, Neutralino N3), GBG (1, Gravbar, VLR, Chi), G_Gr_Z_Neu N3);
((Grino, Z, Neutralino N4), GBG (1, Gravbar, VLR, Chi), G_Gr_Z_Neu N4);
((Grino, Ga, Neutralino N1), GBG (1, Gravbar, VLR, Chi), G_Gr_A_Neu N1);
((Grino, Ga, Neutralino N2), GBG (1, Gravbar, VLR, Chi), G_Gr_A_Neu N2);
((Grino, Ga, Neutralino N3), GBG (1, Gravbar, VLR, Chi), G_Gr_A_Neu N3);
((Grino, Ga, Neutralino N4), GBG (1, Gravbar, VLR, Chi), G_Gr_A_Neu N4) ]
let triple_gravitino =
ThoList.flatmap triple_gravitino' [1;2;3] @
List.flatten (Product.list2 triple_gravitino'' [1;2;3] [M1; M2]) @
ThoList.flatmap higgs_ch_gravitino [C1; C2] @
ThoList.flatmap higgs_neu_gravitino [N1; N2; N3; N4] @
gravitino_gaugino_3
(*** REVISED: Compatible with CD+. ***)
let triple_gauge =
[ ((Ga, Wm, Wp), Gauge_Gauge_Gauge 1, I_Q_W);
((Z, Wm, Wp), Gauge_Gauge_Gauge 1, I_G_ZWW);
((Gl, Gl, Gl), Gauge_Gauge_Gauge 1, I_G_S)]
(*** REVISED: Independent of the sign of CD. ***)
let gauge4 = Vector4 [(2, C_13_42); (-1, C_12_34); (-1, C_14_23)]
let gluon4 = Vector4 [(-1, C_13_42); (-1, C_12_34); (-1, C_14_23)]
let minus_gauge4 = Vector4 [(-2, C_13_42); (1, C_12_34); (1, C_14_23)]
let quartic_gauge =
[ (Wm, Wp, Wm, Wp), gauge4, G_WWWW;
(Wm, Z, Wp, Z), minus_gauge4, G_ZZWW;
(Wm, Z, Wp, Ga), minus_gauge4, G_PZWW;
(Wm, Ga, Wp, Ga), minus_gauge4, G_PPWW;
(Gl, Gl, Gl, Gl), gauge4, G_SS]
(* The [Scalar_Vector_Vector] couplings do not depend on the choice of the
sign of the covariant derivative since they are quadratic in the
gauge couplings. *)
(*** REVISED: Compatible with CD+. ***)
(*** Revision: 2005-03-10: first two vertices corrected. ***)
let gauge_higgs =
[ ((Wm, Hp, A), Vector_Scalar_Scalar 1, G_GH 1);
((Wp, Hm, A), Vector_Scalar_Scalar 1, G_GH 1);
((Z, H_Heavy, A), Vector_Scalar_Scalar 1, G_GH 3);
((Z, H_Light, A), Vector_Scalar_Scalar 1, G_GH 2);
((H_Heavy, Wp, Wm), Scalar_Vector_Vector 1, G_GH 5);
((H_Light, Wp, Wm), Scalar_Vector_Vector 1, G_GH 4);
((Wm, Hp, H_Heavy), Vector_Scalar_Scalar 1, G_GH 7);
((Wp, Hm, H_Heavy), Vector_Scalar_Scalar (-1), G_GH 7);
((Wm, Hp, H_Light), Vector_Scalar_Scalar 1, G_GH 6);
((Wp, Hm, H_Light), Vector_Scalar_Scalar (-1), G_GH 6);
((H_Heavy, Z, Z), Scalar_Vector_Vector 1, G_GH 9);
((H_Light, Z, Z), Scalar_Vector_Vector 1, G_GH 8);
((Z, Hp, Hm), Vector_Scalar_Scalar 1, G_GH 10);
((Ga, Hp, Hm), Vector_Scalar_Scalar 1, G_GH 11) ] @
(if Flags.higgs_triangle then
[((H_Light, Gl, Gl), Dim5_Scalar_Gauge2 1, G_GLGLH);
((H_Heavy, Gl, Gl), Dim5_Scalar_Gauge2 1, G_GLGLHH);
((A, Gl, Gl), Dim5_Scalar_Gauge2_Skew 1, G_GLGLA);
((H_Light, Ga, Ga), Dim5_Scalar_Gauge2 1, G_PPH);
((H_Heavy, Ga, Ga), Dim5_Scalar_Gauge2 1, G_PPHH);
((A, Ga, Ga), Dim5_Scalar_Gauge2 1, G_PPA)]
else
[])
(*** REVISED: Compatible with CD+ and GS+. ***)
let gauge_higgs_gold =
[ ((Wp, Phi0, Phim), Vector_Scalar_Scalar 1, G_GH 1);
((Wm, Phi0, Phip), Vector_Scalar_Scalar 1, G_GH 1);
((Z, H_Heavy, Phi0), Vector_Scalar_Scalar 1, G_GH 2);
((Z, H_Light, Phi0), Vector_Scalar_Scalar (-1), G_GH 3);
((Wp, H_Heavy, Phim), Vector_Scalar_Scalar 1, G_GH 6);
((Wm, H_Heavy, Phip), Vector_Scalar_Scalar (-1), G_GH 6);
((Wp, H_Light, Phim), Vector_Scalar_Scalar (-1), G_GH 7);
((Wm, H_Light, Phip), Vector_Scalar_Scalar 1, G_GH 7);
((Phim, Wp, Ga), Scalar_Vector_Vector 1, G_GHGo 1);
((Phip, Wm, Ga), Scalar_Vector_Vector 1, G_GHGo 1);
((Phim, Wp, Z), Scalar_Vector_Vector 1, G_GHGo 2);
((Phip, Wm, Z), Scalar_Vector_Vector 1, G_GHGo 2);
((Z, Phip, Phim), Vector_Scalar_Scalar 1, G_GH 10);
((Ga, Phip, Phim), Vector_Scalar_Scalar 1, G_GH 11) ]
let gauge_higgs4 =
[ ((A, A, Z, Z), Scalar2_Vector2 1, G_GH4 1);
((H_Heavy, H_Heavy, Z, Z), Scalar2_Vector2 1, G_GH4 3);
((H_Light, H_Light, Z, Z), Scalar2_Vector2 1, G_GH4 2);
((Hp, Hm, Z, Z), Scalar2_Vector2 1, G_GH4 4);
((Hp, Hm, Ga, Ga), Scalar2_Vector2 1, G_GH4 5);
((Hp, Hm, Ga, Z), Scalar2_Vector2 1, G_GH4 6);
((Hp, H_Heavy, Wm, Z), Scalar2_Vector2 1, G_GH4 8);
((Hm, H_Heavy, Wp, Z), Scalar2_Vector2 1, G_GH4 8);
((Hp, H_Light, Wm, Z), Scalar2_Vector2 1, G_GH4 7);
((Hm, H_Light, Wp, Z), Scalar2_Vector2 1, G_GH4 7);
((Hp, H_Heavy, Wm, Ga), Scalar2_Vector2 1, G_GH4 10);
((Hm, H_Heavy, Wp, Ga), Scalar2_Vector2 1, G_GH4 10);
((Hp, H_Light, Wm, Ga), Scalar2_Vector2 1, G_GH4 9);
((Hm, H_Light, Wp, Ga), Scalar2_Vector2 1, G_GH4 9);
((A, A, Wp, Wm), Scalar2_Vector2 1, G_GH4 11);
((H_Heavy, H_Heavy, Wp, Wm), Scalar2_Vector2 1, G_GH4 13);
((H_Light, H_Light, Wp, Wm), Scalar2_Vector2 1, G_GH4 12);
((Hp, Hm, Wp, Wm), Scalar2_Vector2 1, G_GH4 14);
((Hp, A, Wm, Z), Scalar2_Vector2 1, G_GH4 15);
((Hm, A, Wp, Z), Scalar2_Vector2 (-1), G_GH4 15);
((Hp, A, Wm, Ga), Scalar2_Vector2 1, G_GH4 16);
((Hm, A, Wp, Ga), Scalar2_Vector2 (-1), G_GH4 16) ]
let gauge_higgs_gold4 =
[ ((Z, Z, Phi0, Phi0), Scalar2_Vector2 1, G_GHGo4 1);
((Z, Z, Phip, Phim), Scalar2_Vector2 1, G_GHGo4 2);
((Ga, Ga, Phip, Phim), Scalar2_Vector2 1, G_GHGo4 3);
((Z, Ga, Phip, Phim), Scalar2_Vector2 1, G_GHGo4 4);
((Wp, Wm, Phip, Phim), Scalar2_Vector2 1, G_GHGo4 5);
((Wp, Wm, Phi0, Phi0), Scalar2_Vector2 1, G_GHGo4 5);
((Wp, Z, Phim, Phi0), Scalar2_Vector2 1, G_GHGo4 6);
((Wm, Z, Phip, Phi0), Scalar2_Vector2 (-1), G_GHGo4 6);
((Wp, Ga, Phim, Phi0), Scalar2_Vector2 1, G_GHGo4 7);
((Wm, Ga, Phip, Phi0), Scalar2_Vector2 (-1), G_GHGo4 7);
((Wp, Z, Phim, H_Heavy), Scalar2_Vector2 1, G_GHGo4 9);
((Wm, Z, Phip, H_Heavy), Scalar2_Vector2 1, G_GHGo4 9);
((Wp, Ga, Phim, H_Heavy), Scalar2_Vector2 1, G_GHGo4 11);
((Wm, Ga, Phip, H_Heavy), Scalar2_Vector2 1, G_GHGo4 11);
((Wp, Z, Phim, H_Light), Scalar2_Vector2 1, G_GHGo4 8);
((Wm, Z, Phip, H_Light), Scalar2_Vector2 1, G_GHGo4 8);
((Wp, Ga, Phim, H_Light), Scalar2_Vector2 1, G_GHGo4 10);
((Wm, Ga, Phip, H_Light), Scalar2_Vector2 1, G_GHGo4 10) ]
let gauge_sfermion4' g m1 m2 =
[ ((Wp, Wm, Slepton (m1,g), Slepton (m2,-g)), Scalar2_Vector2 1,
G_WWSFSF (SL,g,m1,m2));
((Z, Ga, Slepton (m1,g), Slepton (m2,-g)), Scalar2_Vector2 1,
G_ZPSFSF (SL,g,m1,m2));
((Z, Z, Slepton (m1,g), Slepton (m2,-g)), Scalar2_Vector2 1, G_ZZSFSF
(SL,g,m1,m2));
((Wp, Wm, Sup (m1,g), Sup (m2,-g)), Scalar2_Vector2 1, G_WWSFSF
(SU,g,m1,m2));
((Wp, Wm, Sdown (m1,g), Sdown (m2,-g)), Scalar2_Vector2 1, G_WWSFSF
(SD,g,m1,m2));
((Z, Z, Sup (m1,g), Sup (m2,-g)), Scalar2_Vector2 1, G_ZZSFSF
(SU,g,m1,m2));
((Z, Z, Sdown (m1,g), Sdown (m2,-g)), Scalar2_Vector2 1, G_ZZSFSF
(SD,g,m1,m2));
((Z, Ga, Sup (m1,g), Sup (m2,-g)), Scalar2_Vector2 1, G_ZPSFSF
(SU,g,m1,m2));
((Z, Ga, Sdown (m1,g), Sdown (m2,-g)), Scalar2_Vector2 1, G_ZPSFSF
(SD,g,m1,m2)) ]
let gauge_sfermion4'' g m =
[ ((Wp, Ga, Slepton (m,g), Sneutrino (-g)), Scalar2_Vector2 1, G_WPSLSN
(false,g,m));
((Wm, Ga, Slepton (m,-g), Sneutrino g), Scalar2_Vector2 1,
G_WPSLSN (true,g,m));
((Wp, Z, Slepton (m,g), Sneutrino (-g)), Scalar2_Vector2 1, G_WZSLSN
(false,g,m));
((Wm, Z, Slepton (m,-g), Sneutrino g), Scalar2_Vector2 1,
G_WZSLSN (true,g,m));
((Ga, Ga, Slepton (m,g), Slepton (m,-g)), Scalar2_Vector2 1, G_PPSFSF SL);
((Ga, Ga, Sup (m,g), Sup (m,-g)), Scalar2_Vector2 1, G_PPSFSF SU);
((Ga, Ga, Sdown (m,g), Sdown (m,-g)), Scalar2_Vector2 1, G_PPSFSF SD)]
let gauge_sfermion4 g =
List.flatten (Product.list2 (gauge_sfermion4' g) [M1;M2] [M1;M2]) @
ThoList.flatmap (gauge_sfermion4'' g) [M1;M2] @
[ ((Wp, Wm, Sneutrino g, Sneutrino (-g)), Scalar2_Vector2 1, G_WWSFSF
(SN,g,M1,M1));
((Z, Z, Sneutrino g, Sneutrino (-g)), Scalar2_Vector2 1, G_ZZSFSF
(SN,g,M1,M1)) ]
let gauge_squark4'' g h m1 m2 =
[ ((Wp, Ga, Sup (m1,-g), Sdown (m2,h)), Scalar2_Vector2 1, G_WPSUSD
(false,m1,m2,g,h));
((Wm, Ga, Sup (m1,g), Sdown (m2,-h)), Scalar2_Vector2 1, G_WPSUSD
(true,m1,m2,g,h));
((Wp, Z, Sup (m1,-g), Sdown (m2,h)), Scalar2_Vector2 1, G_WZSUSD
(false,m1,m2,g,h));
((Wm, Z, Sup (m1,g), Sdown (m2,-h)), Scalar2_Vector2 1, G_WZSUSD
(true,m1,m2,g,h)) ]
let gauge_squark4' g h = List.flatten (Product.list2 (gauge_squark4'' g h)
[M1;M2] [M1;M2])
let gauge_squark4 =
if Flags.ckm_present then
List.flatten (Product.list2 gauge_squark4' [1;2;3] [1;2;3])
else
ThoList.flatmap (fun g -> gauge_squark4' g g) [1;2;3]
let gluon_w_squark'' g h m1 m2 =
[ ((Gl, Wp, Sup (m1,-g), Sdown (m2,h)),
Scalar2_Vector2 1, G_GlWSUSD (false,m1,m2,g,h));
((Gl, Wm, Sup (m1,g), Sdown (m2,-h)),
Scalar2_Vector2 1, G_GlWSUSD (true,m1,m2,g,h)) ]
let gluon_w_squark' g h =
List.flatten (Product.list2 (gluon_w_squark'' g h) [M1;M2] [M1;M2])
let gluon_w_squark =
if Flags.ckm_present then
List.flatten (Product.list2 gluon_w_squark' [1;2;3] [1;2;3])
else
ThoList.flatmap (fun g -> gluon_w_squark' g g) [1;2;3]
let gluon_gauge_squark' g m1 m2 =
[ ((Gl, Z, Sup (m1,g), Sup (m2,-g)), Scalar2_Vector2 2, G_GlZSFSF (SU,g,m1,m2));
((Gl, Z, Sdown (m1,g), Sdown (m2,-g)), Scalar2_Vector2 2, G_GlZSFSF (SD,g,m1,m2)) ]
let gluon_gauge_squark'' g m =
[ ((Gl, Ga, Sup (m,g), Sup (m,-g)), Scalar2_Vector2 2, G_GlPSQSQ);
((Gl, Ga, Sdown (m,g), Sdown (m,-g)), Scalar2_Vector2 (-1), G_GlPSQSQ) ]
let gluon_gauge_squark g =
List.flatten (Product.list2 (gluon_gauge_squark' g) [M1;M2] [M1;M2]) @
ThoList.flatmap (gluon_gauge_squark'' g) [M1;M2]
let gluon2_squark2 g m =
[ ((Gl, Gl, Sup (m,g), Sup (m,-g)), Scalar2_Vector2 1, G_GlGlSQSQ);
((Gl, Gl, Sdown (m,g), Sdown (m,-g)), Scalar2_Vector2 1, G_GlGlSQSQ)]
(*** REVISED: Independent of the sign of CD. ***)
let higgs =
[ ((Hp, Hm, H_Heavy), Scalar_Scalar_Scalar 1, G_H3 1);
((Hp, Hm, H_Light), Scalar_Scalar_Scalar 1, G_H3 2);
((H_Heavy, H_Heavy, H_Light), Scalar_Scalar_Scalar 1, G_H3 3);
((H_Heavy, H_Heavy, H_Heavy), Scalar_Scalar_Scalar 1, G_H3 4);
((H_Light, H_Light, H_Light), Scalar_Scalar_Scalar 1, G_H3 5);
((H_Heavy, H_Light, H_Light), Scalar_Scalar_Scalar 1, G_H3 6);
((H_Heavy, A, A), Scalar_Scalar_Scalar 1, G_H3 7);
((H_Light, A, A), Scalar_Scalar_Scalar 1, G_H3 8) ]
(*** REVISED: Compatible with GS+, independent of the sign of CD. ***)
let higgs_gold =
[ ((H_Heavy, A, Phi0), Scalar_Scalar_Scalar 1, G_HGo3 1);
((H_Light, A, Phi0), Scalar_Scalar_Scalar 1, G_HGo3 2);
((H_Heavy, Hp, Phim), Scalar_Scalar_Scalar 1, G_HGo3 3);
((H_Heavy, Hm, Phip), Scalar_Scalar_Scalar 1, G_HGo3 3);
((H_Light, Hp, Phim), Scalar_Scalar_Scalar 1, G_HGo3 4);
((H_Light, Hm, Phip), Scalar_Scalar_Scalar 1, G_HGo3 4);
((A, Hp, Phim), Scalar_Scalar_Scalar (-1), G_HGo3 5);
((A, Hm, Phip), Scalar_Scalar_Scalar 1, G_HGo3 5);
((H_Heavy, Phi0, Phi0), Scalar_Scalar_Scalar (-1), G_H3 7);
((H_Heavy, Phip, Phim), Scalar_Scalar_Scalar (-1), G_H3 7);
((H_Light, Phi0, Phi0), Scalar_Scalar_Scalar (-1), G_H3 8);
((H_Light, Phip, Phim), Scalar_Scalar_Scalar (-1), G_H3 8) ]
(* Here follow purely scalar quartic vertices which are only available for the
no-Whizard colored version. *)
(*** REVISED: Independent of the sign of CD. ***)
let higgs4 =
[ ((Hp, Hm, Hp, Hm), Scalar4 1, G_H4 1);
((Hp, Hm, H_Heavy, H_Heavy), Scalar4 1, G_H4 2);
((Hp, Hm, H_Light, H_Light), Scalar4 1, G_H4 3);
((Hp, Hm, H_Heavy, H_Light), Scalar4 1, G_H4 4);
((Hp, Hm, A, A), Scalar4 1, G_H4 5);
((H_Heavy, H_Heavy, H_Heavy, H_Heavy), Scalar4 1, G_H4 6);
((H_Light, H_Light, H_Light, H_Light), Scalar4 1, G_H4 6);
((H_Heavy, H_Heavy, H_Light, H_Light), Scalar4 1, G_H4 7);
((H_Heavy, H_Light, H_Light, H_Light), Scalar4 1, G_H4 8);
((H_Heavy, H_Heavy, H_Heavy, H_Light), Scalar4 (-1), G_H4 8);
((H_Heavy, H_Heavy, A, A), Scalar4 1, G_H4 9);
((H_Light, H_Light, A, A), Scalar4 (-1), G_H4 9);
((H_Heavy, H_Light, A, A), Scalar4 1, G_H4 10);
((A, A, A, A), Scalar4 1, G_H4 11) ]
(*** REVISED: Compatible with GS+, independent of the sign of CD. ***)
let higgs_gold4 =
[ ((H_Heavy, H_Heavy, A, Phi0), Scalar4 1, G_HGo4 1);
((H_Heavy, H_Light, A, Phi0), Scalar4 1, G_HGo4 2);
((H_Light, H_Light, A, Phi0), Scalar4 (-1), G_HGo4 1);
((A, A, A, Phi0), Scalar4 3, G_HGo4 3);
((Hp, Hm, A, Phi0), Scalar4 1, G_HGo4 3);
((H_Heavy, H_Heavy, Hp, Phim), Scalar4 1, G_HGo4 4);
((H_Heavy, H_Heavy, Hm, Phip), Scalar4 1, G_HGo4 4);
((H_Heavy, H_Light, Hp, Phim), Scalar4 1, G_HGo4 5);
((H_Heavy, H_Light, Hm, Phip), Scalar4 1, G_HGo4 5);
((H_Light, H_Light, Hp, Phim), Scalar4 (-1), G_HGo4 4);
((H_Light, H_Light, Hm, Phip), Scalar4 (-1), G_HGo4 4);
((A, A, Hp, Phim), Scalar4 1, G_HGo4 6);
((A, A, Hm, Phip), Scalar4 1, G_HGo4 6);
((H_Heavy, A, Hp, Phim), Scalar4 1, G_HGo4 7);
((H_Heavy, A, Hm, Phip), Scalar4 (-1), G_HGo4 7);
((H_Light, A, Hp, Phim), Scalar4 1, G_HGo4 8);
((H_Light, A, Hm, Phip), Scalar4 (-1), G_HGo4 8);
((Hp, Hm, Hp, Phim), Scalar4 2, G_HGo4 6);
((Hp, Hm, Hm, Phip), Scalar4 2, G_HGo4 6);
((H_Heavy, H_Heavy, Phi0, Phi0), Scalar4 (-1), G_H4 9);
((H_Heavy, H_Light, Phi0, Phi0), Scalar4 (-1), G_H4 10);
((H_Light, H_Light, Phi0, Phi0), Scalar4 1, G_H4 9);
((A, A, Phi0, Phi0), Scalar4 1, G_HGo4 9);
((Hp, Hm, Phi0, Phi0), Scalar4 1, G_HGo4 10);
((H_Heavy, Hp, Phim, Phi0), Scalar4 1, G_HGo4 8);
((H_Heavy, Hm, Phip, Phi0), Scalar4 (-1), G_HGo4 8);
((H_Light, Hp, Phim, Phi0), Scalar4 (-1), G_HGo4 7);
((H_Light, Hm, Phip, Phi0), Scalar4 1, G_HGo4 7);
((A, Hp, Phim, Phi0), Scalar4 1, G_HGo4 11);
((A, Hm, Phip, Phi0), Scalar4 1, G_HGo4 11);
((H_Heavy, H_Heavy, Phip, Phim), Scalar4 1, G_HGo4 12);
((H_Heavy, H_Light, Phip, Phim), Scalar4 1, G_HGo4 13);
((H_Light, H_Light, Phip, Phim), Scalar4 1, G_HGo4 14);
((A, A, Phip, Phim), Scalar4 1, G_HGo4 15);
((Hp, Hm, Phip, Phim), Scalar4 1, G_HGo4 16);
((Hp, Hp, Phim, Phim), Scalar4 1, G_HGo4 17);
((Hm, Hm, Phip, Phip), Scalar4 1, G_HGo4 17);
((Hp, Phim, Phi0, Phi0), Scalar4 (-1), G_HGo4 6);
((Hm, Phip, Phi0, Phi0), Scalar4 (-1), G_HGo4 6);
((A, Phi0, Phi0, Phi0), Scalar4 (-3), G_HGo4 6);
((A, Phi0, Phip, Phim), Scalar4 (-1), G_HGo4 6);
((Hp, Phim, Phip, Phim), Scalar4 (-2), G_HGo4 6);
((Hm, Phip, Phip, Phim), Scalar4 (-2), G_HGo4 6) ]
(*** REVISED: Independent of the sign of CD and GS. ***)
let goldstone4 =
[ ((Phi0, Phi0, Phi0, Phi0), Scalar4 1, G_GG4 1);
((Phip, Phim, Phi0, Phi0), Scalar4 1, G_GG4 2);
((Phip, Phim, Phip, Phim), Scalar4 1, G_GG4 3) ]
(* The vertices of the type Higgs - Sfermion - Sfermion are independent of
the choice of the CD sign since they are quadratic in the gauge
coupling. *)
(*** REVISED: Independent of the sign of CD. ***)
let higgs_sneutrino' g =
[ ((H_Heavy, Sneutrino g, Sneutrino (-g)), Scalar_Scalar_Scalar 1,
G_H2SFSF (SN,g,M1,M1));
((H_Light, Sneutrino g, Sneutrino (-g)), Scalar_Scalar_Scalar 1,
G_H1SFSF (SN,g,M1,M1));
((Hp, Sneutrino (-g), Slepton (M1,g)), Scalar_Scalar_Scalar 1,
G_HSNSL (false,g,M1));
((Hm, Sneutrino g, Slepton (M1,-g)), Scalar_Scalar_Scalar 1,
G_HSNSL (true,g,M1)) ]
let higgs_sneutrino'' =
[ ((Hp, Sneutrino (-3), Slepton (M2,3)), Scalar_Scalar_Scalar 1,
G_HSNSL (false,3,M2));
((Hm, Sneutrino 3, Slepton (M2,-3)), Scalar_Scalar_Scalar 1,
G_HSNSL (false,3,M2)) ]
let higgs_sneutrino =
ThoList.flatmap higgs_sneutrino' [1;2;3] @ higgs_sneutrino''
(* Under the assumption that there is no mixing between the left- and
right-handed sfermions for the first two generations there is only a
coupling of the form Higgs - sfermion1 - sfermion2 for the third
generation. All the others are suppressed by $m_f/M_W$. *)
(*** REVISED: Independent of the sign of CD. ***)
let higgs_sfermion' g m1 m2 =
[ ((H_Heavy, Slepton (m1,g), Slepton (m2,-g)), Scalar_Scalar_Scalar 1,
G_H2SFSF (SL,g,m1,m2));
((H_Light, Slepton (m1,g), Slepton (m2,-g)), Scalar_Scalar_Scalar 1,
G_H1SFSF (SL,g,m1,m2));
((H_Heavy, Sup (m1,g), Sup (m2,-g)), Scalar_Scalar_Scalar 1,
G_H2SFSF (SU,g,m1,m2));
((H_Heavy, Sdown (m1,g), Sdown (m2,-g)), Scalar_Scalar_Scalar 1,
G_H2SFSF (SD,g,m1,m2));
((H_Light, Sup (m1,g), Sup (m2,-g)), Scalar_Scalar_Scalar 1,
G_H1SFSF (SU,g,m1,m2));
((H_Light, Sdown (m1,g), Sdown (m2,-g)), Scalar_Scalar_Scalar 1,
G_H1SFSF (SD,g,m1,m2)) ]
let higgs_sfermion'' m1 m2 =
[ ((A, Slepton (m1,3), Slepton (m2,-3)), Scalar_Scalar_Scalar 1,
G_ASFSF (SL,3,m1,m2));
((A, Sup (m1,3), Sup (m2,-3)), Scalar_Scalar_Scalar 1,
G_ASFSF (SU,3,m1,m2));
((A, Sdown (m1,3), Sdown (m2,-3)), Scalar_Scalar_Scalar 1,
G_ASFSF (SD,3,m1,m2)) ]
let higgs_sfermion = List.flatten (Product.list2 (higgs_sfermion' 3)
[M1;M2] [M1;M2]) @
(higgs_sfermion' 1 M1 M1) @ (higgs_sfermion' 1 M2 M2) @
(higgs_sfermion' 2 M1 M1) @ (higgs_sfermion' 2 M2 M2) @
List.flatten (Product.list2 higgs_sfermion'' [M1;M2] [M1;M2])
(*i let higgs_sfermion g = List.flatten (Product.list2 (higgs_sfermion' g)
[M1;M2] [M1;M2]) i*)
(*** REVISED: Independent of the sign of CD, compatible with GS+. ***)
let goldstone_sfermion' g m1 m2 =
[ ((Phi0, Slepton (m1,g), Slepton (m2,-g)), Scalar_Scalar_Scalar 1,
G_GoSFSF (SL,g,m1,m2));
((Phi0, Sup (m1,g), Sup (m2,-g)), Scalar_Scalar_Scalar 1,
G_GoSFSF (SU,g,m1,m2));
((Phi0, Sdown (m1,g), Sdown (m2,-g)), Scalar_Scalar_Scalar 1,
G_GoSFSF (SD,g,m1,m2))]
let goldstone_sfermion'' g =
[ ((Phip, Sneutrino (-g), Slepton (M1,g)), Scalar_Scalar_Scalar 1,
G_GoSNSL (false,g,M1));
((Phim, Sneutrino g, Slepton (M1,-g)), Scalar_Scalar_Scalar 1,
G_GoSNSL (true,g,M1)) ]
let goldstone_sfermion''' g =
[ ((Phip, Sneutrino (-g), Slepton (M2,g)), Scalar_Scalar_Scalar 1,
G_GoSNSL (false,g,M2));
((Phim, Sneutrino g, Slepton (M2,-g)), Scalar_Scalar_Scalar 1,
G_GoSNSL (true,g,M2))]
let goldstone_sfermion =
List.flatten (Product.list2 (goldstone_sfermion' 3) [M1;M2] [M1;M2]) @
ThoList.flatmap goldstone_sfermion'' [1;2;3] @
goldstone_sfermion''' 3
(*** REVISED: Independent of the sign of CD. ***)
let higgs_squark' g h m1 m2 =
[ ((Hp, Sup (m1,-g), Sdown (m2,h)), Scalar_Scalar_Scalar 1,
G_HSUSD (false,m1,m2,g,h));
((Hm, Sup (m1,g), Sdown (m2,-h)), Scalar_Scalar_Scalar 1,
G_HSUSD (true,m1,m2,g,h)) ]
let higgs_squark_a g h = higgs_squark' g h M1 M1
let higgs_squark_b (g,h) = List.flatten (Product.list2 (higgs_squark' g h)
[M1;M2] [M1;M2])
let higgs_squark =
if Flags.ckm_present then
List.flatten (Product.list2 higgs_squark_a [1;2] [1;2]) @
ThoList.flatmap higgs_squark_b [(1,3);(2,3);(3,3);(3,1);(3,2)]
else
higgs_squark_a 1 1 @ higgs_squark_a 2 2 @ higgs_squark_b (3,3)
(*** REVISED: Independent of the sign of CD, compatible with GS+. ***)
let goldstone_squark' g h m1 m2 =
[ ((Phip, Sup (m1,-g), Sdown (m2,h)), Scalar_Scalar_Scalar 1,
G_GSUSD (false,m1,m2,g,h));
((Phim, Sup (m1,g), Sdown (m2,-h)), Scalar_Scalar_Scalar 1,
G_GSUSD (true,m1,m2,g,h)) ]
let goldstone_squark_a g h = goldstone_squark' g h M1 M1
let goldstone_squark_b (g,h) = List.flatten (Product.list2
(goldstone_squark' g h) [M1;M2] [M1;M2])
let goldstone_squark =
List.flatten (Product.list2 goldstone_squark_a [1;2] [1;2]) @
ThoList.flatmap goldstone_squark_b [(1,3);(2,3);(3,3);(3,1);(3,2)]
(* BAUSTELLE: For the quartic scalar coupligs we does not allow [whiz_col]. *)
let higgs_sneutrino4' g m =
[ ((Hp, H_Heavy, Slepton (m,g), Sneutrino (-g)), Scalar4 1,
G_HH2SLSN (false,m,g));
((Hm, H_Heavy, Slepton (m,-g), Sneutrino g), Scalar4 1,
G_HH2SLSN (true,m,g));
((Hp, H_Light, Slepton (m,g), Sneutrino (-g)), Scalar4 1,
G_HH1SLSN (false,m,g));
((Hm, H_Light, Slepton (m,-g), Sneutrino g), Scalar4 1,
G_HH1SLSN (true,m,g));
((Hp, A, Slepton (m,g), Sneutrino (-g)), Scalar4 1,
G_HASLSN (false,m,g));
((Hm, A, Slepton (m,-g), Sneutrino g), Scalar4 1,
G_HASLSN (true,m,g)) ]
let higgs_sneutrino4 g =
ThoList.flatmap (higgs_sneutrino4' g) [M1;M2] @
[ ((H_Heavy, H_Heavy, Sneutrino g, Sneutrino (-g)), Scalar4 1,
G_H2H2SFSF (SN,M1,M1,g));
((H_Heavy, H_Light, Sneutrino g, Sneutrino (-g)), Scalar4 1,
G_H1H2SFSF (SN,M1,M1,g));
((H_Light, H_Light, Sneutrino g, Sneutrino (-g)), Scalar4 1,
G_H1H1SFSF (SN,M1,M1,g));
((Hp, Hm, Sneutrino g, Sneutrino (-g)), Scalar4 1, G_HHSFSF (SN,M1,M1,g)) ]
let higgs_sfermion4' g m1 m2 =
[ ((H_Heavy, H_Heavy, Slepton (m1,g), Slepton (m2,-g)), Scalar4 1,
G_H2H2SFSF (SL,m1,m2,g));
((H_Heavy, H_Light, Slepton (m1,g), Slepton (m2,-g)), Scalar4 1,
G_H1H2SFSF (SL,m1,m2,g));
((H_Light, H_Light, Slepton (m1,g), Slepton (m2,-g)), Scalar4 1,
G_H1H1SFSF (SL,m1,m2,g));
((A, A, Slepton (m1,g), Slepton (m2,-g)), Scalar4 1,
G_AASFSF (SL,m1,m2,g));
((Hp, Hm, Slepton (m1,g), Slepton (m2,-g)), Scalar4 1,
G_HHSFSF (SL,m1,m2,g));
((H_Heavy, H_Heavy, Sup (m1,g), Sup (m2,-g)), Scalar4 1,
G_H2H2SFSF (SU,m1,m2,g));
((H_Heavy, H_Heavy, Sdown (m1,g), Sdown (m2,-g)), Scalar4 1,
G_H2H2SFSF (SD,m1,m2,g));
((H_Light, H_Light, Sup (m1,g), Sup (m2,-g)), Scalar4 1,
G_H1H1SFSF (SU,m1,m2,g));
((H_Light, H_Light, Sdown (m1,g), Sdown (m2,-g)), Scalar4 1,
G_H1H1SFSF (SD,m1,m2,g));
((H_Light, H_Heavy, Sup (m1,g), Sup (m2,-g)), Scalar4 1,
G_H1H2SFSF (SU,m1,m2,g));
((H_Light, H_Heavy, Sdown (m1,g), Sdown (m2,-g)), Scalar4 1,
G_H1H2SFSF (SD,m1,m2,g));
((Hp, Hm, Sup (m1,g), Sup (m2,-g)), Scalar4 1, G_HHSFSF (SU,m1,m2,g));
((Hp, Hm, Sdown (m1,g), Sdown (m2,-g)), Scalar4 1, G_HHSFSF (SD,m1,m2,g));
((A, A, Sup (m1,g), Sup (m2,-g)), Scalar4 1, G_AASFSF (SU,m1,m2,g));
((A, A, Sdown (m1,g), Sdown (m2,-g)), Scalar4 1, G_AASFSF (SD,m1,m2,g)) ]
let higgs_sfermion4 g = List.flatten (Product.list2 (higgs_sfermion4' g)
[M1;M2] [M1;M2])
let higgs_squark4' g h m1 m2 =
[ ((Hp, H_Light, Sup (m1,-g), Sdown (m2,h)), Scalar4 1,
G_HH1SUSD (false,m1,m2,g,h));
((Hm, H_Light, Sup (m1,g), Sdown (m2,-h)), Scalar4 1,
G_HH1SUSD (true,m1,m2,g,h));
((Hp, H_Heavy, Sup (m1,-g), Sdown (m2,h)), Scalar4 1,
G_HH2SUSD (false,m1,m2,g,h));
((Hm, H_Heavy, Sup (m1,g), Sdown (m2,-h)), Scalar4 1,
G_HH2SUSD (true,m1,m2,g,h));
((Hp, A, Sup (m1,-g), Sdown (m2,h)), Scalar4 1,
G_HASUSD (false,m1,m2,g,h));
((Hm, A, Sup (m1,g), Sdown (m2,-h)), Scalar4 1,
G_HASUSD (true,m1,m2,g,h)) ]
let higgs_squark4 g h = List.flatten (Product.list2 (higgs_squark4' g h)
[M1;M2] [M1;M2])
let higgs_gold_sneutrino' g m =
[ ((Hp, Phi0, Sneutrino (-g), Slepton (m,g)), Scalar4 1, G_HGSNSL (false,m,g));
((Hm, Phi0, Sneutrino g, Slepton (m,-g)), Scalar4 1, G_HGSNSL (true,m,g));
((H_Heavy, Phip, Sneutrino (-g), Slepton (m,g)), Scalar4 1,
G_H2GSNSL (false,m,g));
((H_Heavy, Phim, Sneutrino g, Slepton (m,-g)), Scalar4 1,
G_H2GSNSL (true,m,g));
((H_Light, Phip, Sneutrino (-g), Slepton (m,g)), Scalar4 1,
G_H1GSNSL (false,m,g));
((H_Light, Phim, Sneutrino g, Slepton (m,-g)), Scalar4 1,
G_H1GSNSL (true,m,g));
((A, Phip, Sneutrino (-g), Slepton (m,g)), Scalar4 1, G_AGSNSL (false,m,g));
((A, Phim, Sneutrino g, Slepton (m,-g)), Scalar4 1, G_AGSNSL (true,m,g));
((Phi0, Phip, Sneutrino (-g), Slepton (m,g)), Scalar4 1, G_GGSNSL (false,m,g));
((Phi0, Phim, Sneutrino g, Slepton (m,-g)), Scalar4 1, G_GGSNSL (true,m,g))]
let higgs_gold_sneutrino g =
ThoList.flatmap (higgs_gold_sneutrino' g) [M1;M2] @
[ ((A, Phi0, Sneutrino g, Sneutrino (-g)), Scalar4 1,
G_AG0SFSF (SN,M1,M1,g));
((Hp, Phim, Sneutrino g, Sneutrino (-g)), Scalar4 1,
G_HGSFSF (SN,M1,M1,g));
((Hm, Phip, Sneutrino g, Sneutrino (-g)), Scalar4 1,
G_HGSFSF (SN,M1,M1,g));
((Phip, Phim, Sneutrino g, Sneutrino (-g)), Scalar4 1,
G_GGSFSF (SN,M1,M1,g));
((Phi0, Phi0, Sneutrino g, Sneutrino (-g)), Scalar4 1,
G_G0G0SFSF (SN,M1,M1,g)) ]
let higgs_gold_sfermion' g m1 m2 =
[ ((A, Phi0, Slepton (m1,g), Slepton (m2,-g)), Scalar4 1,
G_AG0SFSF (SL,m1,m2,g));
((Hp, Phim, Slepton (m1,g), Slepton (m2,-g)), Scalar4 1,
G_HGSFSF (SL,m1,m2,g));
((Hm, Phip, Slepton (m1,g), Slepton (m2,-g)), Scalar4 1,
G_HGSFSF (SL,m1,m2,g));
((Phip, Phim, Slepton (m1,g), Slepton (m2,-g)), Scalar4 1,
G_GGSFSF (SL,m1,m2,g));
((Phi0, Phi0, Slepton (m1,g), Slepton (m2,-g)), Scalar4 1,
G_G0G0SFSF (SL,m1,m2,g));
((A, Phi0, Sup (m1,g), Sup (m2,-g)), Scalar4 1, G_AG0SFSF (SU,m1,m2,g));
((A, Phi0, Sdown (m1,g), Sdown (m2,-g)), Scalar4 1,
G_AG0SFSF (SD,m1,m2,g));
((Hp, Phim, Sup (m1,g), Sup (m2,-g)), Scalar4 1, G_HGSFSF (SU,m1,m2,g));
((Hm, Phip, Sup (m1,g), Sup (m2,-g)), Scalar4 1, G_HGSFSF (SU,m1,m2,g));
((Hp, Phim, Sdown (m1,g), Sdown (m2,-g)), Scalar4 1,
G_HGSFSF (SD,m1,m2,g));
((Hm, Phip, Sdown (m1,g), Sdown (m2,-g)), Scalar4 1,
G_HGSFSF (SD,m1,m2,g));
((Phip, Phim, Sup (m1,g), Sup (m2,-g)), Scalar4 1,
G_GGSFSF (SU,m1,m2,g));
((Phip, Phim, Sdown (m1,g), Sdown (m2,-g)), Scalar4 1,
G_GGSFSF (SD,m1,m2,g));
((Phi0, Phi0, Sup (m1,g), Sup (m2,-g)), Scalar4 1,
G_G0G0SFSF (SU,m1,m2,g));
((Phi0, Phi0, Sdown (m1,g), Sdown (m2,-g)), Scalar4 1,
G_G0G0SFSF (SD,m1,m2,g)) ]
let higgs_gold_sfermion g = List.flatten (Product.list2
(higgs_gold_sfermion' g) [M1;M2] [M1;M2])
let higgs_gold_squark' g h m1 m2 =
[ ((Hp, Phi0, Sup (m1,-g), Sdown (m2,h)), Scalar4 1,
G_HGSUSD (false,m1,m2,g,h));
((Hm, Phi0, Sup (m1,g), Sdown (m2,-h)), Scalar4 1,
G_HGSUSD (true,m1,m2,g,h));
((H_Heavy, Phip, Sup (m1,-g), Sdown (m2,h)), Scalar4 1,
G_H2GSUSD (false,m1,m2,g,h));
((H_Heavy, Phim, Sup (m1,g), Sdown (m2,-h)), Scalar4 1,
G_H2GSUSD (true,m1,m2,g,h));
((H_Light, Phip, Sup (m1,-g), Sdown (m2,h)), Scalar4 1,
G_H1GSUSD (false,m1,m2,g,h));
((H_Light, Phim, Sup (m1,g), Sdown (m2,-h)), Scalar4 1,
G_H1GSUSD (true,m1,m2,g,h));
((A, Phip, Sup (m1,-g), Sdown (m2,h)), Scalar4 1,
G_AGSUSD (false,m1,m2,g,h));
((A, Phim, Sup (m1,g), Sdown (m2,-h)), Scalar4 1,
G_AGSUSD (true,m1,m2,g,h));
((Phi0, Phip, Sup (m1,-g), Sdown (m2,h)), Scalar4 1,
G_GGSUSD (false,m1,m2,g,h));
((Phi0, Phim, Sup (m1,g), Sdown (m2,-h)), Scalar4 1,
G_GGSUSD (true,m1,m2,g,h)) ]
let higgs_gold_squark g h = List.flatten (Product.list2 (higgs_gold_squark'
g h) [M1;M2] [M1;M2])
let sneutrino4' (g,h) =
[ ((Sneutrino g, Sneutrino h, Sneutrino (-g), Sneutrino (-h)), Scalar4 1,
G_SN4 (g,h))]
let sneutrino4 = ThoList.flatmap sneutrino4'
[(1,1);(1,2);(1,3);(2,2);(2,3);(3,3)]
let sneu2_slep2_1' g h m1 m2 =
((Sneutrino (-g), Sneutrino g, Slepton (m1,-h), Slepton (m2,h)), Scalar4 1,
G_SN2SL2_1 (m1,m2,g,h))
let sneu2_slep2_2' (g,h) m1 m2 =
((Sneutrino g, Sneutrino (-h), Slepton (m1,-g), Slepton (m2,h)), Scalar4 1,
G_SN2SL2_2 (m1,m2,g,h))
let sneu2_slep2_1 g h = Product.list2 (sneu2_slep2_1' g h) [M1;M2] [M1;M2]
let sneu2_slep2_2 (g,h) = Product.list2 (sneu2_slep2_2' (g,h)) [M1;M2] [M1;M2]
(* The 4-slepton-vertices have the following structure: The sleptons come up in
pairs of a positive and a negative slepton of the same generation; there is
no vertex with e.g. two negative selectrons and two positive smuons, that of
course would be a contradiction to the conservation of the separate slepton
numbers of each generation which is not implemented in the MSSM. Because there
is no CKM-mixing for the sleptons (in case of massless neutrinos) we maximally
have two different generations of sleptons in a 4-slepton-vertex. *)
let slepton4_1gen' g (m1,m2,m3,m4) =
[ ((Slepton (m1,-g), Slepton (m2,g), Slepton (m3,-g), Slepton (m4,g)),
Scalar4 1, G_SL4 (m1,m2,m3,m4,g)) ]
let slepton4_1gen g = ThoList.flatmap (slepton4_1gen' g) [(M1,M1,M1,M1);
(M1,M1,M1,M2); (M1,M1,M2,M1); (M1,M1,M2,M2); (M1,M2,M1,M2); (M1,M2,M2,M1);
(M1,M2,M2,M2); (M2,M1,M2,M2); (M2,M2,M2,M2) ]
let slepton4_2gen' (g,h) (m1,m2) (m3,m4) =
((Slepton (m1,-g), Slepton (m2,g), Slepton (m3,-h), Slepton (m4,h)),
Scalar4 1, G_SL4_2 (m1,m2,m3,m4,g,h))
let slepton4_2gen (g,h) =
Product.list2 (slepton4_2gen' (g,h)) [(M1,M1);(M1,M2);(M2,M1);(M2,M2)]
[(M1,M1);(M1,M2);(M2,M1);(M2,M2)]
let sneu2_squark2' g h m1 m2 =
[ ((Sneutrino (-g), Sneutrino g, Sup (m1,-h), Sup (m2,h)), Scalar4 1,
G_SN2SQ2 (SU,m1,m2,g,h));
((Sneutrino (-g), Sneutrino g, Sdown (m1,-h), Sdown (m2,h)), Scalar4 1,
G_SN2SQ2 (SD,m1,m2,g,h)) ]
let sneu2_squark2 g h = List.flatten (Product.list2 (sneu2_squark2' g h)
[M1;M2] [M1;M2])
let slepton2_squark2'' g h m1 m2 m3 m4 =
[ ((Slepton (m1,-g), Slepton (m2,g), Sup (m3,-h), Sup (m4,h)), Scalar4 1,
G_SL2SQ2 (SU,m1,m2,m3,m4,g,h));
((Slepton (m1,-g), Slepton (m2,g), Sdown (m3,-h), Sdown (m4,h)),
Scalar4 1, G_SL2SQ2 (SD,m1,m2,m3,m4,g,h)) ]
let slepton2_squark2' g h m1 m2 =
List.flatten (Product.list2 (slepton2_squark2'' g h m1 m2) [M1;M2] [M1;M2])
let slepton2_squark2 g h =
List.flatten (Product.list2 (slepton2_squark2' g h) [M1;M2] [M1;M2])
let slep_sneu_squark2'' g1 g2 g3 m1 m2 m3 =
[ ((Sup (m1,-g1), Sdown (m2,g2), Slepton (m3,-g3), Sneutrino g3),
Scalar4 1, G_SUSDSNSL (false,m1,m2,m3,g1,g2,g3));
((Sup (m1,g1), Sdown (m2,-g2), Slepton (m3,g3), Sneutrino (-g3)),
Scalar4 1, G_SUSDSNSL (true,m1,m2,m3,g1,g2,g3)) ]
let slep_sneu_squark2' g1 g2 g3 m1 =
List.flatten (Product.list2 (slep_sneu_squark2'' g1 g2 g3 m1)
[M1;M2] [M1;M2])
let slep_sneu_squark2 g1 g2 =
List.flatten (Product.list2 (slep_sneu_squark2' g1 g2) [1;2;3] [M1;M2])
(* There are three kinds of 4-squark-vertices: Four up-Squarks, four down-squarks
or two up- and two down-squarks. *)
let sup4_1gen' g (m1,m2,m3,m4) =
[ ((Sup (m1,-g), Sup (m2,g), Sup (m3,-g), Sup (m4,g)), Scalar4 1,
G_SU4 (m1,m2,m3,m4,g)) ]
let sup4_1gen g = ThoList.flatmap (sup4_1gen' g) [(M1,M1,M1,M1);
(M1,M1,M1,M2); (M1,M1,M2,M1); (M1,M1,M2,M2); (M1,M2,M1,M2); (M1,M2,M2,M1);
(M1,M2,M2,M2); (M2,M1,M2,M2); (M2,M2,M2,M2) ]
let sup4_2gen' (g,h) (m1,m2) (m3,m4) =
((Sup (m1,-g), Sup (m2,g), Sup (m3,-h), Sup (m4,h)), Scalar4 1,
G_SU4_2 (m1,m2,m3,m4,g,h))
let sup4_2gen (g,h) =
Product.list2 (sup4_2gen' (g,h)) [(M1,M1);(M1,M2);(M2,M1);(M2,M2)]
[(M1,M1);(M1,M2);(M2,M1);(M2,M2)]
let sdown4_1gen' g (m1,m2,m3,m4) =
[ ((Sdown (m1,-g), Sdown (m2,g), Sdown (m3,-g), Sdown (m4,g)), Scalar4 1,
G_SD4 (m1,m2,m3,m4,g)) ]
let sdown4_1gen g = ThoList.flatmap (sdown4_1gen' g) [(M1,M1,M1,M1);
(M1,M1,M1,M2); (M1,M1,M2,M1); (M1,M1,M2,M2); (M1,M2,M1,M2); (M1,M2,M2,M1);
(M1,M2,M2,M2); (M2,M1,M2,M2); (M2,M2,M2,M2) ]
let sdown4_2gen' (g,h) (m1,m2) (m3,m4) =
((Sdown (m1,-g), Sdown (m2,g), Sdown (m3,-h), Sdown (m4,h)), Scalar4 1,
G_SD4_2 (m1,m2,m3,m4,g,h))
let sdown4_2gen (g,h) =
Product.list2 (sdown4_2gen' (g,h)) [(M1,M1);(M1,M2);(M2,M1);(M2,M2)]
[(M1,M1);(M1,M2);(M2,M1);(M2,M2)]
let sup2_sdown2_3 g1 g2 g3 g4 m1 m2 m3 m4 =
((Sup (m1,-g1), Sup (m2,g2), Sdown (m3,-g3), Sdown
(m4,g4)), Scalar4 1, G_SU2SD2 (m1,m2,m3,m4,g1,g2,g3,g4))
let sup2_sdown2_2 g1 g2 g3 g4 m1 m2 =
Product.list2 (sup2_sdown2_3 g1 g2 g3 g4 m1 m2) [M1;M2] [M1;M2]
let sup2_sdown2_1 g1 g2 g3 g4 =
List.flatten (Product.list2 (sup2_sdown2_2 g1 g2 g3 g4) [M1;M2] [M1;M2])
let sup2_sdown2 g1 g2 =
List.flatten (Product.list2 (sup2_sdown2_1 g1 g2) [1;2;3] [1;2;3])
let quartic_grav_gauge g m =
[ ((Grino, Slepton (m, -g), Ga, L g), GBBG (1, Gravbar, SLRV, Psi), G_Gr4A_Sl (g,m));
((L (-g), Slepton (m, g), Ga, Grino), GBBG (1, Psibar, SLRV, Grav), G_Gr4A_Slc (g,m));
((Grino, Sup (m, -g), Ga, U g), GBBG (1, Gravbar, SLRV, Psi), G_Gr4A_Su (g,m));
((U (-g), Sup (m, g), Ga, Grino), GBBG (1, Psibar, SLRV, Grav), G_Gr4A_Suc (g,m));
((Grino, Sdown (m, -g), Ga, D g), GBBG (1, Gravbar, SLRV, Psi), G_Gr4A_Sd (g,m));
((D (-g), Sdown (m, g), Ga, Grino), GBBG (1, Psibar, SLRV, Grav), G_Gr4A_Sdc (g,m));
((Grino, Slepton (m, -g), Z, L g), GBBG (1, Gravbar, SLRV, Psi), G_Gr4Z_Sl (g,m));
((L (-g), Slepton (m, g), Z, Grino), GBBG (1, Psibar, SLRV, Grav), G_Gr4Z_Slc (g,m));
((Grino, Sup (m, -g), Z, U g), GBBG (1, Gravbar, SLRV, Psi), G_Gr4Z_Su (g,m));
((U (-g), Sup (m, g), Z, Grino), GBBG (1, Psibar, SLRV, Grav), G_Gr4Z_Suc (g,m));
((Grino, Sdown (m, -g), Z, D g), GBBG (1, Gravbar, SLRV, Psi), G_Gr4Z_Sd (g,m));
((D (-g), Sdown (m, g), Z, Grino), GBBG (1, Psibar, SLRV, Grav), G_Gr4Z_Sdc (g,m));
((Grino, Sup (m, -g), Gl, U g), GBBG (1, Gravbar, SLRV, Psi), G_Gr4Gl_Su (g,m));
((U (-g), Sup (m, g), Gl, Grino), GBBG (1, Psibar, SLRV, Grav), G_Gr4Gl_Suc (g,m));
((Grino, Sdown (m, -g), Gl, D g), GBBG (1, Gravbar, SLRV, Psi), G_Gr4Gl_Sd (g,m));
((D (-g), Sdown (m, g), Gl, Grino), GBBG (1, Psibar, SLRV, Grav), G_Gr4Gl_Sdc (g,m));
((Grino, Slepton (m, -g), Wm, N g), GBBG (1, Gravbar, SLV, Psi), G_Gr4W_Sl (g,m));
((N (-g), Slepton (m, g), Wp, Grino), GBBG (1, Psibar, SLV, Grav), G_Gr4Z_Slc (g,m));
((Grino, Sup (m, -g), Wp, D g), GBBG (1, Gravbar, SLV, Psi), G_Gr4W_Su (g,m));
((D (-g), Sup (m, g), Wm, Grino), GBBG (1, Psibar, SLV, Grav), G_Gr4W_Suc (g,m));
((Grino, Sdown (m, -g), Wm, U g), GBBG (1, Gravbar, SLV, Psi), G_Gr4W_Sd (g,m));
((U (-g), Sdown (m, g), Wp, Grino), GBBG (1, Psibar, SLV, Grav), G_Gr4W_Sdc (g,m)) ]
let quartic_grav_sneutrino g =
[ ((Grino, Sneutrino (-g), Z, N g), GBBG (1, Gravbar, SLV, Psi), G_Gr4Z_Sn);
((N (-g), Sneutrino g, Z, Grino), GBBG (1, Psibar, SLV, Grav), G_Gr4Z_Snc);
((Grino, Sneutrino (-g), Wp, L g), GBBG (1, Gravbar, SLV, Psi), G_Gr4W_Sn);
((L (-g), Sneutrino g, Wm, Grino), GBBG (1, Psibar, SLV, Grav), G_Gr4W_Snc) ]
let quartic_grav_neu n =
[ ((Grino, Wp, Wm, Neutralino n), GBBG (1, Gravbar, V2LR, Chi), G_Gr4_Neu n);
((Grino, H_Light, Z, Neutralino n), GBBG (1, Gravbar, SLRV, Chi), G_Gr4_Z_H1 n);
((Grino, H_Heavy, Z, Neutralino n), GBBG (1, Gravbar, SLRV, Chi), G_Gr4_Z_H2 n);
((Grino, A, Z, Neutralino n), GBBG (1, Gravbar, SLRV, Chi), G_Gr4_Z_H3 n);
((Grino, Hm, Wp, Neutralino n), GBBG (1, Gravbar, SLRV, Chi), G_Gr4_W_H n);
((Grino, Hp, Wm, Neutralino n), GBBG (1, Gravbar, SLRV, Chi), G_Gr4_W_Hc n) ]
let quartic_grav_char c =
let cc = conj_char c in
[ ((Grino, Wm, Ga, Chargino c), GBBG (1, Gravbar, V2LR, Psi), G_Gr4_A_Ch c);
((Grino, Wm, Z, Chargino c), GBBG (1, Gravbar, V2LR, Psi), G_Gr4_Z_Ch c);
((Chargino cc, Wp, Ga, Grino), GBBG ((-1), Psibar, V2LR, Grav), G_Gr4_A_Ch cc);
((Chargino cc, Wp, Z, Grino), GBBG ((-1), Psibar, V2LR, Grav), G_Gr4_Z_Ch cc);
((Grino, Hm, Ga, Chargino c), GBBG (1, Gravbar, SLRV, Psi), G_Gr4_H_A c);
((Chargino cc, Hp, Ga, Grino), GBBG (1, Psibar, SLRV, Grav), G_Gr4_H_A cc);
((Grino, Hm, Z, Chargino c), GBBG (1, Gravbar, SLRV, Psi), G_Gr4_H_Z c);
((Chargino cc, Hp, Z, Grino), GBBG (1, Psibar, SLRV, Grav), G_Gr4_H_Z cc)]
let quartic_gravitino =
[ ((Grino, Gl, Gl, Gluino), GBBG (1, Gravbar, V2, Chi), G_GravGl)] @
ThoList.flatmap quartic_grav_neu [N1; N2; N3; N4] @
ThoList.flatmap quartic_grav_char [C1; C2] @
List.flatten (Product.list2 quartic_grav_gauge [1; 2; 3] [M1; M2]) @
ThoList.flatmap quartic_grav_sneutrino [1; 2; 3]
let vertices3'' =
if Flags.ckm_present then
(ThoList.flatmap electromagnetic_currents_3 [1;2;3] @
ThoList.flatmap electromagnetic_currents_2 [C1;C2] @
List.flatten (Product.list2
electromagnetic_sfermion_currents [1;2;3] [M1;M2]) @
ThoList.flatmap neutral_currents [1;2;3] @
ThoList.flatmap neutral_sfermion_currents [1;2;3] @
ThoList.flatmap charged_currents [1;2;3] @
List.flatten (Product.list2 charged_slepton_currents [1;2;3]
[M1;M2]) @
List.flatten (Product.list2 charged_quark_currents [1;2;3]
[1;2;3]) @
List.flatten (Product.list2 charged_squark_currents [1;2;3]
[1;2;3]) @
ThoList.flatmap yukawa_higgs_quark [(1,3);(2,3);(3,3);(3,1);(3,2)] @
yukawa_higgs 3 @ yukawa_n @
ThoList.flatmap yukawa_c [C1;C2] @
ThoList.flatmap yukawa_cq [C1;C2] @
List.flatten (Product.list2 charged_chargino_currents [N1;N2;N3;N4]
[C1;C2]) @ triple_gauge @
ThoList.flatmap neutral_Z_1 [(N1,N2);(N1,N3);(N1,N4);(N2,N3);(N2,N4);
(N3,N4)] @
ThoList.flatmap neutral_Z_2 [N1;N2;N3;N4] @ neutral_A @
Product.list2 charged_Z [C1;C2] [C1;C2] @
gauge_higgs @ higgs @ yukawa_higgs_2 @
List.flatten (Product.list2 higgs_charg_neutr [N1;N2;N3;N4] [C1;C2]) @
higgs_neutr @ higgs_sneutrino @ higgs_sfermion @
higgs_squark @ yukawa_v @
ThoList.flatmap col_currents [1;2;3] @
List.flatten (Product.list2 col_sfermion_currents [1;2;3] [M1;M2]))
else
(ThoList.flatmap electromagnetic_currents_3 [1;2;3] @
ThoList.flatmap electromagnetic_currents_2 [C1;C2] @
List.flatten (Product.list2
electromagnetic_sfermion_currents [1;2;3] [M1;M2]) @
ThoList.flatmap neutral_currents [1;2;3] @
ThoList.flatmap neutral_sfermion_currents [1;2;3] @
ThoList.flatmap charged_currents [1;2;3] @
List.flatten (Product.list2 charged_slepton_currents [1;2;3]
[M1;M2]) @
charged_quark_currents 1 1 @
charged_quark_currents 2 2 @
charged_quark_currents 3 3 @
charged_squark_currents 1 1 @
charged_squark_currents 2 2 @
charged_squark_currents 3 3 @
ThoList.flatmap yukawa_higgs_quark [(3,3)] @
yukawa_higgs 3 @ yukawa_n @
ThoList.flatmap yukawa_c [C1;C2] @
ThoList.flatmap yukawa_cq [C1;C2] @
List.flatten (Product.list2 charged_chargino_currents [N1;N2;N3;N4]
[C1;C2]) @ triple_gauge @
ThoList.flatmap neutral_Z_1 [(N1,N2);(N1,N3);(N1,N4);(N2,N3);(N2,N4);
(N3,N4)] @
ThoList.flatmap neutral_Z_2 [N1;N2;N3;N4] @ neutral_A @
Product.list2 charged_Z [C1;C2] [C1;C2] @
gauge_higgs @ higgs @ yukawa_higgs_2 @
List.flatten (Product.list2 higgs_charg_neutr [N1;N2;N3;N4] [C1;C2]) @
higgs_neutr @ higgs_sneutrino @ higgs_sfermion @
higgs_squark @ yukawa_v @
ThoList.flatmap col_currents [1;2;3] @
List.flatten (Product.list2 col_sfermion_currents [1;2;3] [M1;M2]))
let vertices3' =
if Flags.gravitino then (vertices3'' @ triple_gravitino)
else vertices3''
let vertices3 =
if Flags.include_goldstone then
(vertices3' @ yukawa_goldstone 3 @
gauge_higgs_gold @ higgs_gold @ yukawa_goldstone_2 @
(if Flags.ckm_present then
List.flatten (Product.list2 yukawa_goldstone_quark [1;2;3]
[1;2;3]) @
List.flatten (Product.list2 goldstone_charg_neutr [N1;N2;N3;N4]
[C1;C2])
else
yukawa_goldstone_quark 1 1 @
yukawa_goldstone_quark 2 2 @
yukawa_goldstone_quark 3 3) @
goldstone_neutr @ goldstone_sfermion @ goldstone_squark)
else vertices3'
let vertices4''' =
(quartic_gauge @ higgs4 @ gauge_higgs4 @
ThoList.flatmap gauge_sfermion4 [1;2;3] @
gauge_squark4 @ gluon_w_squark @
List.flatten (Product.list2 gluon2_squark2 [1;2;3] [M1;M2]) @
ThoList.flatmap gluon_gauge_squark [1;2;3])
let vertices4'' =
if Flags.gravitino then (vertices4''' @ quartic_gravitino)
else vertices4'''
let vertices4' =
if Flags.include_four then
(vertices4'' @
ThoList.flatmap higgs_sfermion4 [1;2;3] @
ThoList.flatmap higgs_sneutrino4 [1;2;3] @
List.flatten (Product.list2 higgs_squark4 [1;2;3] [1;2;3]) @
sneutrino4 @
List.flatten (Product.list2 sneu2_slep2_1 [1;2;3] [1;2;3]) @
ThoList.flatmap sneu2_slep2_2 [(1,2);(1,3);(2,3);(2,1);(3,1);(3,2)] @
ThoList.flatmap slepton4_1gen [1;2;3] @
ThoList.flatmap slepton4_2gen [(1,2);(1,3);(2,3)] @
List.flatten (Product.list2 sneu2_squark2 [1;2;3] [1;2;3]) @
List.flatten (Product.list2 slepton2_squark2 [1;2;3] [1;2;3]) @
List.flatten (Product.list2 slep_sneu_squark2 [1;2;3] [1;2;3]) @
ThoList.flatmap sup4_1gen [1;2;3] @
ThoList.flatmap sup4_2gen [(1,2);(1,3);(2,3)] @
ThoList.flatmap sdown4_1gen [1;2;3] @
ThoList.flatmap sdown4_2gen [(1,2);(1,3);(2,3)] @
List.flatten (Product.list2 sup2_sdown2 [1;2;3] [1;2;3]))
else
vertices4''
let vertices4 =
if Flags.include_goldstone then
(vertices4' @ higgs_gold4 @ gauge_higgs_gold4 @ goldstone4 @
ThoList.flatmap higgs_gold_sneutrino [1;2;3] @
ThoList.flatmap higgs_gold_sfermion [1;2;3] @
List.flatten (Product.list2 higgs_gold_squark [1;2;3] [1;2;3]))
else
vertices4'
let vertices () = (vertices3, vertices4, [])
let table = F.of_vertices (vertices ())
let fuse2 = F.fuse2 table
let fuse3 = F.fuse3 table
let fuse = F.fuse table
let max_degree () = 4
let flavor_of_string s =
match s with
| "e-" -> L 1 | "e+" -> L (-1)
| "mu-" -> L 2 | "mu+" -> L (-2)
| "tau-" -> L 3 | "tau+" -> L (-3)
| "nue" -> N 1 | "nuebar" -> N (-1)
| "numu" -> N 2 | "numubar" -> N (-2)
| "nutau" -> N 3 | "nutaubar" -> N (-3)
| "se1-" -> Slepton (M1,1) | "se1+" -> Slepton (M1,-1)
| "smu1-" -> Slepton (M1,2) | "smu1+" -> Slepton (M1,-2)
| "stau1-" -> Slepton (M1,3) | "stau1+" -> Slepton (M1,-3)
| "se2-" -> Slepton (M2,1) | "se2+" -> Slepton (M2,-1)
| "smu2-" -> Slepton (M2,2) | "smu2+" -> Slepton (M2,-2)
| "stau2-" -> Slepton (M2,3) | "stau2+" -> Slepton (M2,-3)
| "snue" -> Sneutrino 1 | "snue*" -> Sneutrino (-1)
| "snumu" -> Sneutrino 2 | "snumu*" -> Sneutrino (-2)
| "snutau" -> Sneutrino 3 | "snutau*" -> Sneutrino (-3)
| "u" -> U 1 | "ubar" -> U (-1)
| "c" -> U 2 | "cbar" -> U (-2)
| "t" -> U 3 | "tbar" -> U (-3)
| "d" -> D 1 | "dbar" -> D (-1)
| "s" -> D 2 | "sbar" -> D (-2)
| "b" -> D 3 | "bbar" -> D (-3)
| "A" -> Ga | "Z" | "Z0" -> Z
| "W+" -> Wp | "W-" -> Wm
| "gl" | "g" -> Gl
| "H" -> H_Heavy | "h" -> H_Light | "A0" -> A
| "H+" -> Hp | "H-" -> Hm
| "phi0" -> Phi0 | "phi+" -> Phip | "phim" -> Phim
| "su1" -> Sup (M1,1) | "su1c" -> Sup (M1,-1)
| "sc1" -> Sup (M1,2) | "sc1c" -> Sup (M1,-2)
| "st1" -> Sup (M1,3) | "st1c" -> Sup (M1,-3)
| "su2" -> Sup (M2,1) | "su2c" -> Sup (M2,-1)
| "sc2" -> Sup (M2,2) | "sc2c" -> Sup (M2,-2)
| "st2" -> Sup (M2,3) | "st2c" -> Sup (M2,-3)
| "sgl" | "sg" -> Gluino
| "sd1" -> Sdown (M1,1) | "sd1c" -> Sdown (M1,-1)
| "ss1" -> Sdown (M1,2) | "ss1c" -> Sdown (M1,-2)
| "sb1" -> Sdown (M1,3) | "sb1c" -> Sdown (M1,-3)
| "sd2" -> Sdown (M2,1) | "sd2c" -> Sdown (M2,-1)
| "ss2" -> Sdown (M2,2) | "ss2c" -> Sdown (M2,-2)
| "sb2" -> Sdown (M2,3) | "sb2c" -> Sdown (M2,-3)
| "neu1" -> Neutralino N1 | "neu2" -> Neutralino N2
| "neu3" -> Neutralino N3 | "neu4" -> Neutralino N4
| "ch1+" -> Chargino C1 | "ch2+" -> Chargino C2
| "ch1-" -> Chargino C1c | "ch2-" -> Chargino C2c
| "GR" -> Grino
| _ -> invalid_arg "Modellib_MSSM.MSSM.flavor_of_string"
let flavor_to_string = function
| L 1 -> "e-" | L (-1) -> "e+"
| L 2 -> "mu-" | L (-2) -> "mu+"
| L 3 -> "tau-" | L (-3) -> "tau+"
| N 1 -> "nue" | N (-1) -> "nuebar"
| N 2 -> "numu" | N (-2) -> "numubar"
| N 3 -> "nutau" | N (-3) -> "nutaubar"
| U 1 -> "u" | U (-1) -> "ubar"
| U 2 -> "c" | U (-2) -> "cbar"
| U 3 -> "t" | U (-3) -> "tbar"
| D 1 -> "d" | D (-1) -> "dbar"
| D 2 -> "s" | D (-2) -> "sbar"
| D 3 -> "b" | D (-3) -> "bbar"
| L _ -> invalid_arg
"Modellib_MSSM.MSSM.flavor_to_string: invalid lepton"
| N _ -> invalid_arg
"Modellib_MSSM.MSSM.flavor_to_string: invalid neutrino"
| U _ -> invalid_arg
"Modellib_MSSM.MSSM.flavor_to_string: invalid up type quark"
| D _ -> invalid_arg
"Modellib_MSSM.MSSM.flavor_to_string: invalid down type quark"
| Gl -> "gl" | Gluino -> "sgl"
| Ga -> "A" | Z -> "Z" | Wp -> "W+" | Wm -> "W-"
| Phip -> "phi+" | Phim -> "phi-" | Phi0 -> "phi0"
| H_Heavy -> "H" | H_Light -> "h" | A -> "A0"
| Hp -> "H+" | Hm -> "H-"
| Slepton (M1,1) -> "se1-" | Slepton (M1,-1) -> "se1+"
| Slepton (M1,2) -> "smu1-" | Slepton (M1,-2) -> "smu1+"
| Slepton (M1,3) -> "stau1-" | Slepton (M1,-3) -> "stau1+"
| Slepton (M2,1) -> "se2-" | Slepton (M2,-1) -> "se2+"
| Slepton (M2,2) -> "smu2-" | Slepton (M2,-2) -> "smu2+"
| Slepton (M2,3) -> "stau2-" | Slepton (M2,-3) -> "stau2+"
| Sneutrino 1 -> "snue" | Sneutrino (-1) -> "snue*"
| Sneutrino 2 -> "snumu" | Sneutrino (-2) -> "snumu*"
| Sneutrino 3 -> "snutau" | Sneutrino (-3) -> "snutau*"
| Sup (M1,1) -> "su1" | Sup (M1,-1) -> "su1c"
| Sup (M1,2) -> "sc1" | Sup (M1,-2) -> "sc1c"
| Sup (M1,3) -> "st1" | Sup (M1,-3) -> "st1c"
| Sup (M2,1) -> "su2" | Sup (M2,-1) -> "su2c"
| Sup (M2,2) -> "sc2" | Sup (M2,-2) -> "sc2c"
| Sup (M2,3) -> "st2" | Sup (M2,-3) -> "st2c"
| Sdown (M1,1) -> "sd1" | Sdown (M1,-1) -> "sd1c"
| Sdown (M1,2) -> "ss1" | Sdown (M1,-2) -> "ss1c"
| Sdown (M1,3) -> "sb1" | Sdown (M1,-3) -> "sb1c"
| Sdown (M2,1) -> "sd2" | Sdown (M2,-1) -> "sd2c"
| Sdown (M2,2) -> "ss2" | Sdown (M2,-2) -> "ss2c"
| Sdown (M2,3) -> "sb2" | Sdown (M2,-3) -> "sb2c"
| Neutralino N1 -> "neu1"
| Neutralino N2 -> "neu2"
| Neutralino N3 -> "neu3"
| Neutralino N4 -> "neu4"
| Slepton _ -> invalid_arg
"Modellib_MSSM.MSSM.flavor_to_string: invalid slepton"
| Sneutrino _ -> invalid_arg
"Modellib_MSSM.MSSM.flavor_to_string: invalid sneutrino"
| Sup _ -> invalid_arg
"Modellib_MSSM.MSSM.flavor_to_string: invalid up type squark"
| Sdown _ -> invalid_arg
"Modellib_MSSM.MSSM.flavor_to_string: invalid down type squark"
| Chargino C1 -> "ch1+" | Chargino C1c -> "ch1-"
| Chargino C2 -> "ch2+" | Chargino C2c -> "ch2-"
| Grino -> "GR"
let flavor_symbol = function
| L g when g > 0 -> "l" ^ string_of_int g
| L g -> "l" ^ string_of_int (abs g) ^ "b"
| N g when g > 0 -> "n" ^ string_of_int g
| N g -> "n" ^ string_of_int (abs g) ^ "b"
| U g when g > 0 -> "u" ^ string_of_int g
| U g -> "u" ^ string_of_int (abs g) ^ "b"
| D g when g > 0 -> "d" ^ string_of_int g
| D g -> "d" ^ string_of_int (abs g) ^ "b"
| Gl -> "gl" | Ga -> "a" | Z -> "z"
| Wp -> "wp" | Wm -> "wm"
| Slepton (M1,g) when g > 0 -> "sl1" ^ string_of_int g
| Slepton (M1,g) -> "sl1c" ^ string_of_int (abs g)
| Slepton (M2,g) when g > 0 -> "sl2" ^ string_of_int g
| Slepton (M2,g) -> "sl2c" ^ string_of_int (abs g)
| Sneutrino g when g > 0 -> "sn" ^ string_of_int g
| Sneutrino g -> "snc" ^ string_of_int (abs g)
| Sup (M1,g) when g > 0 -> "su1" ^ string_of_int g
| Sup (M1,g) -> "su1c" ^ string_of_int (abs g)
| Sup (M2,g) when g > 0 -> "su2" ^ string_of_int g
| Sup (M2,g) -> "su2c" ^ string_of_int (abs g)
| Sdown (M1,g) when g > 0 -> "sd1" ^ string_of_int g
| Sdown (M1,g) -> "sd1c" ^ string_of_int (abs g)
| Sdown (M2,g) when g > 0 -> "sd2" ^ string_of_int g
| Sdown (M2,g) -> "sd2c" ^ string_of_int (abs g)
| Neutralino n -> "neu" ^ (string_of_neu n)
| Chargino c when (int_of_char c) > 0 -> "cp" ^ string_of_char c
| Chargino c -> "cm" ^ string_of_int (abs (int_of_char c))
| Gluino -> "sgl" | Phip -> "pp" | Phim -> "pm" | Phi0 -> "p0"
| H_Heavy -> "h0h" | H_Light -> "h0l" | A -> "a0"
| Hp -> "hp" | Hm -> "hm" | Grino -> "gv"
let flavor_to_TeX = function
| L 1 -> "e^-" | L (-1) -> "e^+"
| L 2 -> "\\mu^-" | L (-2) -> "\\mu^+"
| L 3 -> "\\tau^-" | L (-3) -> "\\tau^+"
| N 1 -> "\\nu_e" | N (-1) -> "\\bar{\\nu}_e"
| N 2 -> "\\nu_\\mu" | N (-2) -> "\\bar{\\nu}_\\mu"
| N 3 -> "\\nu_\\tau" | N (-3) -> "\\bar{\\nu}_\\tau"
| U 1 -> "u" | U (-1) -> "\\bar{u}"
| U 2 -> "c" | U (-2) -> "\\bar{c}"
| U 3 -> "t" | U (-3) -> "\\bar{t}"
| D 1 -> "d" | D (-1) -> "\\bar{d}"
| D 2 -> "s" | D (-2) -> "\\bar{s}"
| D 3 -> "b" | D (-3) -> "\\bar{b}"
| L _ -> invalid_arg
"Modellib_MSSM.MSSM.flavor_to_TeX: invalid lepton"
| N _ -> invalid_arg
"Modellib_MSSM.MSSM.flavor_to_TeX: invalid neutrino"
| U _ -> invalid_arg
"Modellib_MSSM.MSSM.flavor_to_TeX: invalid up type quark"
| D _ -> invalid_arg
"Modellib_MSSM.MSSM.flavor_to_TeX: invalid down type quark"
| Gl -> "g" | Gluino -> "\\widetilde{g}"
| Ga -> "\\gamma" | Z -> "Z" | Wp -> "W^+" | Wm -> "W^-"
| Phip -> "\\phi^+" | Phim -> "\\phi^-" | Phi0 -> "\\phi^0"
| H_Heavy -> "H^0" | H_Light -> "h^0" | A -> "A^0"
| Hp -> "H^+" | Hm -> "H^-"
| Slepton (M1,1) -> "\\widetilde{e}_1^-"
| Slepton (M1,-1) -> "\\widetilde{e}_1^+"
| Slepton (M1,2) -> "\\widetilde{\\mu}_1^-"
| Slepton (M1,-2) -> "\\widetilde{\\mu}_1^+"
| Slepton (M1,3) -> "\\widetilde{\\tau}_1^-"
| Slepton (M1,-3) -> "\\widetilde{\\tau}_1^+"
| Slepton (M2,1) -> "\\widetilde{e}_2^-"
| Slepton (M2,-1) -> "\\widetilde{e}_2^+"
| Slepton (M2,2) -> "\\widetilde{\\mu}_2^-"
| Slepton (M2,-2) -> "\\widetilde{\\mu}_2^+"
| Slepton (M2,3) -> "\\widetilde{\\tau}_2^-"
| Slepton (M2,-3) -> "\\widetilde{\\tau}_2^+"
| Sneutrino 1 -> "\\widetilde{\\nu}_e"
| Sneutrino (-1) -> "\\widetilde{\\nu}_e^*"
| Sneutrino 2 -> "\\widetilde{\\nu}_\\mu"
| Sneutrino (-2) -> "\\widetilde{\\nu}_\\mu^*"
| Sneutrino 3 -> "\\widetilde{\\nu}_\\tau"
| Sneutrino (-3) -> "\\widetilde{\\nu}_\\tau^*"
| Sup (M1,1) -> "\\widetilde{u}_1"
| Sup (M1,-1) -> "\\widetilde{u}_1^*"
| Sup (M1,2) -> "\\widetilde{c}_1"
| Sup (M1,-2) -> "\\widetilde{c}_1^*"
| Sup (M1,3) -> "\\widetilde{t}_1"
| Sup (M1,-3) -> "\\widetilde{t}_1^*"
| Sup (M2,1) -> "\\widetilde{u}_2"
| Sup (M2,-1) -> "\\widetilde{u}_2^*"
| Sup (M2,2) -> "\\widetilde{c}_2"
| Sup (M2,-2) -> "\\widetilde{c}_2^*"
| Sup (M2,3) -> "\\widetilde{t}_2"
| Sup (M2,-3) -> "\\widetilde{t}_2^*"
| Sdown (M1,1) -> "\\widetilde{d}_1"
| Sdown (M1,-1) -> "\\widetilde{d}_1^*"
| Sdown (M1,2) -> "\\widetilde{s}_1"
| Sdown (M1,-2) -> "\\widetilde{s}_1^*"
| Sdown (M1,3) -> "\\widetilde{b}_1"
| Sdown (M1,-3) -> "\\widetilde{b}_1^*"
| Sdown (M2,1) -> "\\widetilde{d}_2"
| Sdown (M2,-1) -> "\\widetilde{d}_2^*"
| Sdown (M2,2) -> "\\widetilde{s}_2"
| Sdown (M2,-2) -> "\\widetilde{s}_2^*"
| Sdown (M2,3) -> "\\widetilde{b}_2"
| Sdown (M2,-3) -> "\\widetilde{b}_2^*"
| Neutralino N1 -> "\\widetilde{\\chi}^0_1"
| Neutralino N2 -> "\\widetilde{\\chi}^0_2"
| Neutralino N3 -> "\\widetilde{\\chi}^0_3"
| Neutralino N4 -> "\\widetilde{\\chi}^0_4"
| Slepton _ -> invalid_arg
"Modellib_MSSM.MSSM.flavor_to_TeX: invalid slepton"
| Sneutrino _ -> invalid_arg
"Modellib_MSSM.MSSM.flavor_to_TeX: invalid sneutrino"
| Sup _ -> invalid_arg
"Modellib_MSSM.MSSM.flavor_to_TeX: invalid up type squark"
| Sdown _ -> invalid_arg
"Modellib_MSSM.MSSM.flavor_to_TeX: invalid down type squark"
| Chargino C1 -> "\\widetilde{\\chi}_1^+"
| Chargino C1c -> "\\widetilde{\\chi}_1^-"
| Chargino C2 -> "\\widetilde{\\chi}_2^+"
| Chargino C2c -> "\\widetilde{\\chi}_2^-"
| Grino -> "\\widetilde{G}"
let pdg = function
| L g when g > 0 -> 9 + 2*g
| L g -> - 9 + 2*g
| N g when g > 0 -> 10 + 2*g
| N g -> - 10 + 2*g
| U g when g > 0 -> 2*g
| U g -> 2*g
| D g when g > 0 -> - 1 + 2*g
| D g -> 1 + 2*g
| Gl -> 21 | Ga -> 22 | Z -> 23
| Wp -> 24 | Wm -> (-24)
| H_Light -> 25 | H_Heavy -> 35 | A -> 36
| Hp -> 37 | Hm -> (-37)
| Phip | Phim -> 27 | Phi0 -> 26
| Slepton (M1,g) when g > 0 -> 1000009 + 2*g
| Slepton (M1,g) -> - 1000009 + 2*g
| Slepton (M2,g) when g > 0 -> 2000009 + 2*g
| Slepton (M2,g) -> - 2000009 + 2*g
| Sneutrino g when g > 0 -> 1000010 + 2*g
| Sneutrino g -> - 1000010 + 2*g
| Sup (M1,g) when g > 0 -> 1000000 + 2*g
| Sup (M1,g) -> - 1000000 + 2*g
| Sup (M2,g) when g > 0 -> 2000000 + 2*g
| Sup (M2,g) -> - 2000000 + 2*g
| Sdown (M1,g) when g > 0 -> 999999 + 2*g
| Sdown (M1,g) -> - 999999 + 2*g
| Sdown (M2,g) when g > 0 -> 1999999 + 2*g
| Sdown (M2,g) -> - 1999999 + 2*g
| Gluino -> 1000021
| Grino -> 1000039
| Chargino C1 -> 1000024 | Chargino C1c -> (-1000024)
| Chargino C2 -> 1000037 | Chargino C2c -> (-1000037)
| Neutralino N1 -> 1000022 | Neutralino N2 -> 1000023
| Neutralino N3 -> 1000025 | Neutralino N4 -> 1000035
(* We must take care of the pdg numbers for the two different kinds of
sfermions in the MSSM. The particle data group in its Monte Carlo particle
numbering scheme takes only into account mixtures of the third generation
squarks and the stau. For the other sfermions we will use the number of the
lefthanded field for the lighter mixed state and the one for the righthanded
for the heavier. Below are the official pdg numbers from the Particle
Data Group. In order not to produce arrays with some million entries in
the Fortran code for the masses and the widths we introduce our private
pdg numbering scheme which only extends not too far beyond 42.
Our private scheme then has the following pdf numbers (for the sparticles
the subscripts $L/R$ and $1/2$ are taken synonymously):
\begin{center}
\renewcommand{\arraystretch}{1.2}
\begin{tabular}{|r|l|l|}\hline
$d$ & down-quark & 1 \\\hline
$u$ & up-quark & 2 \\\hline
$s$ & strange-quark & 3 \\\hline
$c$ & charm-quark & 4 \\\hline
$b$ & bottom-quark & 5 \\\hline
$t$ & top-quark & 6 \\\hline\hline
$e^-$ & electron & 11 \\\hline
$\nu_e$ & electron-neutrino & 12 \\\hline
$\mu^-$ & muon & 13 \\\hline
$\nu_\mu$ & muon-neutrino & 14 \\\hline
$\tau^-$ & tau & 15 \\\hline
$\nu_\tau$ & tau-neutrino & 16 \\\hline\hline
$g$ & gluon & (9) 21 \\\hline
$\gamma$ & photon & 22 \\\hline
$Z^0$ & Z-boson & 23 \\\hline
$W^+$ & W-boson & 24 \\\hline\hline
$h^0$ & light Higgs boson & 25 \\\hline
$H^0$ & heavy Higgs boson & 35 \\\hline
$A^0$ & pseudoscalar Higgs & 36 \\\hline
$H^+$ & charged Higgs & 37 \\\hline\hline
$\widetilde{\psi}_\mu$ & gravitino & 39 \\\hline\hline
$\widetilde{d}_L$ & down-squark 1 & 41 \\\hline
$\widetilde{u}_L$ & up-squark 1 & 42 \\\hline
$\widetilde{s}_L$ & strange-squark 1 & 43 \\\hline
$\widetilde{c}_L$ & charm-squark 1 & 44 \\\hline
$\widetilde{b}_L$ & bottom-squark 1 & 45 \\\hline
$\widetilde{t}_L$ & top-squark 1 & 46 \\\hline
$\widetilde{d}_R$ & down-squark 2 & 47 \\\hline
$\widetilde{u}_R$ & up-squark 2 & 48 \\\hline
$\widetilde{s}_R$ & strange-squark 2 & 49 \\\hline
$\widetilde{c}_R$ & charm-squark 2 & 50 \\\hline
$\widetilde{b}_R$ & bottom-squark 2 & 51 \\\hline
$\widetilde{t}_R$ & top-squark 2 & 52 \\\hline\hline
$\widetilde{e}_L$ & selectron 1 & 53 \\\hline
$\widetilde{\nu}_{e,L}$ & electron-sneutrino & 54 \\\hline
$\widetilde{\mu}_L$ & smuon 1 & 55 \\\hline
$\widetilde{\nu}_{\mu,L}$ & muon-sneutrino & 56 \\\hline
$\widetilde{\tau}_L$ & stau 1 & 57 \\\hline
$\widetilde{\nu}_{\tau,L}$ & tau-sneutrino & 58 \\\hline
$\widetilde{e}_R$ & selectron 2 & 59 \\\hline
$\widetilde{\mu}_R$ & smuon 2 & 61 \\\hline
$\widetilde{\tau}_R$ & stau 2 & 63 \\\hline\hline
$\widetilde{g}$ & gluino & 64 \\\hline
$\widetilde{\chi}^0_1$ & neutralino 1 & 65 \\\hline
$\widetilde{\chi}^0_2$ & neutralino 2 & 66 \\\hline
$\widetilde{\chi}^0_3$ & neutralino 3 & 67 \\\hline
$\widetilde{\chi}^0_4$ & neutralino 4 & 68 \\\hline
$\widetilde{\chi}^+_1$ & chargino 1 & 69 \\\hline
$\widetilde{\chi}^+_2$ & chargino 2 & 70 \\\hline\hline
\end{tabular}
\end{center} *)
let pdg_mw = function
| L g when g > 0 -> 9 + 2*g
| L g -> - 9 + 2*g
| N g when g > 0 -> 10 + 2*g
| N g -> - 10 + 2*g
| U g when g > 0 -> 2*g
| U g -> 2*g
| D g when g > 0 -> - 1 + 2*g
| D g -> 1 + 2*g
| Gl -> 21 | Ga -> 22 | Z -> 23
| Wp -> 24 | Wm -> (-24)
| H_Light -> 25 | H_Heavy -> 35 | A -> 36
| Hp -> 37 | Hm -> (-37)
| Phip | Phim -> 27 | Phi0 -> 26
| Sup (M1,g) when g > 0 -> 40 + 2*g
| Sup (M1,g) -> - 40 + 2*g
| Sup (M2,g) when g > 0 -> 46 + 2*g
| Sup (M2,g) -> - 46 + 2*g
| Sdown (M1,g) when g > 0 -> 39 + 2*g
| Sdown (M1,g) -> - 39 + 2*g
| Sdown (M2,g) when g > 0 -> 45 + 2*g
| Sdown (M2,g) -> - 45 + 2*g
| Slepton (M1,g) when g > 0 -> 51 + 2*g
| Slepton (M1,g) -> - 51 + 2*g
| Slepton (M2,g) when g > 0 -> 57 + 2*g
| Slepton (M2,g) -> - 57 + 2*g
| Sneutrino g when g > 0 -> 52 + 2*g
| Sneutrino g -> - 52 + 2*g
| Grino -> 39
| Gluino -> 64
| Chargino C1 -> 69 | Chargino C1c -> (-69)
| Chargino C2 -> 70 | Chargino C2c -> (-70)
| Neutralino N1 -> 65 | Neutralino N2 -> 66
| Neutralino N3 -> 67 | Neutralino N4 -> 68
let mass_symbol f =
"mass(" ^ string_of_int (abs (pdg_mw f)) ^ ")"
let width_symbol f =
"width(" ^ string_of_int (abs (pdg_mw f)) ^ ")"
let conj_symbol = function
| false, str -> str
| true, str -> str ^ "_c"
let constant_symbol = function
| Unit -> "unit" | Pi -> "PI"
| Alpha_QED -> "alpha" | E -> "e" | G -> "g" | Vev -> "vev"
| Sin2thw -> "sin2thw" | Eidelta -> "eidelta" | Mu -> "mu" | G_Z -> "gz"
| Sin a -> "sin" ^ string_of_angle a | Cos a -> "cos" ^ string_of_angle a
| Sin2am2b -> "sin2am2b" | Cos2am2b -> "cos2am2b" | Sinamb -> "sinamb"
| Sinapb -> "sinapb" | Cosamb -> "cosamb" | Cosapb -> "cosapb"
| Cos4be -> "cos4be" | Sin4be -> "sin4be" | Sin4al -> "sin4al"
| Sin2al -> "sin2al" | Cos2al -> "cos2al" | Sin2be -> "sin2be"
| Cos2be -> "cos2be" | Tana -> "tana" | Tanb -> "tanb"
| Q_lepton -> "qlep" | Q_up -> "qup" | Q_down -> "qdwn"
| Q_charg -> "qchar"
| V_CKM (g1,g2) -> "vckm_" ^ string_of_int g1 ^ string_of_int g2
| M_SF (f,g,m1,m2) -> "mix_" ^ string_of_sff f ^ string_of_int g
^ string_of_sfm m1 ^ string_of_sfm m2
| AL g -> "al_" ^ string_of_int g
| AD g -> "ad_" ^ string_of_int g
| AU g -> "au_" ^ string_of_int g
| A_0 (n1,n2) -> "a0_" ^ string_of_neu n1 ^ string_of_neu n2
| A_P (c1,c2) -> "ap_" ^ string_of_char c1 ^ string_of_char c2
| V_0 (n1,n2) -> "v0_" ^ string_of_neu n1 ^ string_of_neu n2
| V_P (c1,c2) -> "vp_" ^ string_of_char c1 ^ string_of_char c2
| M_N (n1,n2) -> "mn_" ^ string_of_neu n1 ^ string_of_neu n2
| M_U (c1,c2) -> "mu_" ^ string_of_char c1 ^ string_of_char c2
| M_V (c1,c2) -> "mv_" ^ string_of_char c1 ^ string_of_char c2
| L_NC (n,c) -> "lnc_" ^ string_of_neu n ^ string_of_char c
| R_NC (n,c) -> "rnc_" ^ string_of_neu n ^ string_of_char c
| L_CN (c,n) -> "lcn_" ^ string_of_char c ^ string_of_neu n
| R_CN (c,n) -> "rcn_" ^ string_of_char c ^ string_of_neu n
| L_NCH (n,c) -> "lnch_" ^ string_of_neu n ^ string_of_char c
| R_NCH (n,c) -> "rnch_" ^ string_of_neu n ^ string_of_char c
| L_CNG (c,n) -> "lcng_" ^ string_of_char c ^ string_of_neu n
| R_CNG (c,n) -> "rcng_" ^ string_of_char c ^ string_of_neu n
| S_NNA (n1,n2) -> "snna_" ^ string_of_neu n1 ^ string_of_neu n2
| P_NNA (n1,n2) -> "pnna_" ^ string_of_neu n1 ^ string_of_neu n2
| S_NNG (n1,n2) -> "snng_" ^ string_of_neu n1 ^ string_of_neu n2
| P_NNG (n1,n2) -> "pnng_" ^ string_of_neu n1 ^ string_of_neu n2
| S_NNH1 (n1,n2) -> "snnh1_" ^ string_of_neu n1 ^ string_of_neu n2
| P_NNH1 (n1,n2) -> "pnnh1_" ^ string_of_neu n1 ^ string_of_neu n2
| S_NNH2 (n1,n2) -> "snnh2_" ^ string_of_neu n1 ^ string_of_neu n2
| P_NNH2 (n1,n2) -> "pnnh2_" ^ string_of_neu n1 ^ string_of_neu n2
| G_NC_lepton -> "gnclep" | G_NC_neutrino -> "gncneu"
| G_NC_up -> "gncup" | G_NC_down -> "gncdwn"
| G_CC -> "gcc"
| G_CCQ (vc,g1,g2) -> conj_symbol (vc, "gccq_" ^ string_of_int g1 ^ "_"
^ string_of_int g2)
| I_Q_W -> "iqw" | I_G_ZWW -> "igzww"
| G_WWWW -> "gw4" | G_ZZWW -> "gzzww"
| G_PZWW -> "gpzww" | G_PPWW -> "gppww"
| G_GH 1 -> "ghaw"
| G_GH 2 -> "gh1az" | G_GH 3 -> "gh2az"
| G_GH 4 -> "gh1ww" | G_GH 5 -> "gh2ww"
| G_GH 6 -> "ghh1w" | G_GH 7 -> "ghh2w"
| G_GH 8 -> "gh1zz" | G_GH 9 -> "gh2zz"
| G_GH 10 -> "ghhz" | G_GH 11 -> "ghhp"
| G_GH _ -> failwith "this G_GH coupling is not available"
| G_GLGLH -> "gglglh" | G_GLGLHH -> "gglglhh"
| G_GLGLA -> "gglgla" | G_PPH -> "gpph"
| G_PPHH -> "gpphh" | G_PPA -> "gppa"
| G_GHGo n -> "g_hgh(" ^ string_of_int n ^ ")"
| G_GH4 1 -> "gaazz" | G_GH4 2 -> "gh1h1zz" | G_GH4 3 -> "gh2h2zz"
| G_GH4 4 -> "ghphmzz" | G_GH4 5 -> "ghphmpp" | G_GH4 6 -> "ghphmpz"
| G_GH4 7 -> "ghh1wz" | G_GH4 8 -> "ghh2wz"
| G_GH4 9 -> "ghh1wp" | G_GH4 10 -> "ghh2wp"
| G_GH4 11 -> "gaaww" | G_GH4 12 -> "gh1h1ww" | G_GH4 13 -> "gh2h2ww"
| G_GH4 14 -> "ghhww" | G_GH4 15 -> "ghawz" | G_GH4 16 -> "ghawp"
| G_GH4 _ -> failwith "this G_GH4 coupling is not available"
| G_CICIH1 (n1,n2) -> "gcicih1_" ^ string_of_neu n1 ^ "_"
^ string_of_neu n2
| G_CICIH2 (n1,n2) -> "gcicih2_" ^ string_of_neu n1 ^ "_"
^ string_of_neu n2
| G_CICIA (n1,n2) -> "gcicia_" ^ string_of_neu n1 ^ "_"
^ string_of_neu n2
| G_CICIG (n1,n2) -> "gcicig_" ^ string_of_neu n1 ^ "_"
^ string_of_neu n2
| G_H3 n -> "gh3_" ^ string_of_int n
| G_H4 n -> "gh4_" ^ string_of_int n
| G_HGo3 n -> "ghg3_" ^ string_of_int n
| G_HGo4 n -> "ghg4_" ^ string_of_int n
| G_GG4 n -> "ggg4_" ^ string_of_int n
| G_strong -> "gs" | G_SS -> "gs**2"
| Gs -> "gs"
| I_G_S -> "igs"
| G_S_Sqrt -> "gssq"
| G_NWC (n,c) -> "gnwc_" ^ string_of_neu n ^ "_" ^ string_of_char c
| G_CWN (c,n) -> "gcwn_" ^ string_of_char c ^ "_" ^ string_of_neu n
| G_CH1C (c1,c2) -> "gch1c_" ^ string_of_char c1 ^ "_" ^ string_of_char c2
| G_CH2C (c1,c2) -> "gch2c_" ^ string_of_char c1 ^ "_" ^ string_of_char c2
| G_CAC (c1,c2) -> "gcac_" ^ string_of_char c1 ^ "_" ^ string_of_char c2
| G_CGC (c1,c2) -> "gcgc_" ^ string_of_char c1 ^ "_" ^ string_of_char c2
| G_YUK (i,g) -> "g_yuk" ^ string_of_int i ^ "_" ^ string_of_int g
| G_NZN (n1,n2) -> "gnzn_" ^ string_of_neu n1 ^ "_" ^ string_of_neu n2
| G_NNA -> "gnna"
| G_CZC (c1,c2) -> "gczc_" ^ string_of_char c1 ^ "_" ^ string_of_char
c2
| G_YUK_1 (n,m) -> "g_yuk1_" ^ string_of_int n ^ "_" ^ string_of_int m
| G_YUK_2 (n,m) -> "g_yuk2_" ^ string_of_int n ^ "_" ^ string_of_int m
| G_YUK_3 (n,m) -> "g_yuk3_" ^ string_of_int n ^ "_" ^ string_of_int m
| G_YUK_4 (n,m) -> "g_yuk4_" ^ string_of_int n ^ "_" ^ string_of_int m
| G_YUK_C (vc,g,c,sf,m) -> conj_symbol (vc, "g_yuk_ch" ^ string_of_char c
^ "_" ^ string_of_sff sf ^ string_of_sfm m ^ "_" ^ string_of_int g )
| G_YUK_N (vc,g,n,sf,m) -> conj_symbol (vc, "g_yuk_n" ^ string_of_neu n
^ "_" ^ string_of_sff sf ^ string_of_sfm m ^ "_" ^ string_of_int g )
| G_YUK_G (vc,g,sf,m) -> conj_symbol (vc, "g_yuk_g" ^ string_of_sff sf
^ string_of_sfm m ^ "_" ^ string_of_int g)
| G_YUK_Q (vc,g1,g2,c,sf,m) -> conj_symbol (vc, "g_yuk_ch" ^ string_of_char c
^ "_" ^ string_of_sff sf ^ string_of_sfm m ^ "_" ^ string_of_int g1
^ "_" ^ string_of_int g2)
| G_NHC (n,c) -> "g_nhc_" ^ string_of_neu n ^ "_" ^ string_of_char c
| G_CHN (c,n) -> "g_chn_" ^ string_of_neu n ^ "_" ^ string_of_char c
| G_NGC (n,c) -> "g_ngc_" ^ string_of_neu n ^ string_of_char c
| G_CGN (c,n) -> "g_cgn_" ^ string_of_char c ^ string_of_neu n
| SUM_1 -> "sum1"
| G_SLSNW (vc,g,m) -> conj_symbol (vc, "gsl" ^ string_of_sfm m ^ "_"
^ string_of_int g ^ "snw")
| G_ZSF (f,g,m1,m2) -> "g" ^ string_of_sff f ^ string_of_sfm m1 ^ "z"
^ string_of_sff f ^ string_of_sfm m2 ^ "_" ^ string_of_int g
| G_WWSFSF (f,g,m1,m2) -> "gww" ^ string_of_sff f ^ string_of_sfm m1
^ string_of_sff f ^ string_of_sfm m2 ^ "_" ^ string_of_int g
| G_WPSLSN (vc,g,m) -> conj_symbol (vc, "gpwsl" ^ string_of_sfm m
^ "sn_" ^ string_of_int g)
| G_WZSLSN (vc,g,m) -> conj_symbol (vc, "gwzsl" ^ string_of_sfm m
^ "sn_" ^ string_of_int g)
| G_H1SFSF (f,g,m1,m2) -> "gh1" ^ string_of_sff f ^ string_of_sfm m1
^ string_of_sff f ^ string_of_sfm m2 ^ "_" ^ string_of_int g
| G_H2SFSF (f,g,m1,m2) -> "gh2" ^ string_of_sff f ^ string_of_sfm m1
^ string_of_sff f ^ string_of_sfm m2 ^ "_" ^ string_of_int g
| G_ASFSF (f,g,m1,m2) -> "ga" ^ string_of_sff f ^ string_of_sfm m1
^ string_of_sff f ^ string_of_sfm m2 ^ "_" ^ string_of_int g
| G_HSNSL (vc,g,m) -> conj_symbol (vc, "ghsnsl" ^ string_of_sfm m ^ "_"
^ string_of_int g)
| G_GoSFSF (f,g,m1,m2) -> "ggo" ^ string_of_sff f ^ string_of_sfm m1
^ string_of_sff f ^ string_of_sfm m2 ^ "_" ^ string_of_int g
| G_GoSNSL (vc,g,m) -> conj_symbol (vc, "ggosnsl" ^ string_of_sfm m ^ "_"
^ string_of_int g)
| G_HSUSD (vc,m1,m2,g1,g2) -> conj_symbol (vc, "ghsu" ^ string_of_sfm m1
^ "sd" ^ string_of_sfm m2 ^ "_" ^ string_of_int g1 ^ "_"
^ string_of_int g2)
| G_GSUSD (vc,m1,m2,g1,g2) -> conj_symbol (vc, "ggsu" ^ string_of_sfm m1
^ "sd" ^ string_of_sfm m2 ^ "_" ^ string_of_int g1 ^ "_"
^ string_of_int g2)
| G_WPSUSD (vc,m1,m2,n,m) -> conj_symbol (vc, "gpwpsu" ^ string_of_sfm m1
^ "sd" ^ string_of_sfm m2 ^ "_" ^ string_of_int n ^ "_"
^ string_of_int m)
| G_WZSUSD (vc,m1,m2,n,m) -> conj_symbol (vc, "gzwpsu" ^ string_of_sfm m1
^ "sd" ^ string_of_sfm m2 ^ "_" ^ string_of_int n ^ "_"
^ string_of_int m)
| G_SWS (vc,g1,g2,m1,m2) -> conj_symbol (vc, "gs" ^ string_of_sfm m1 ^ "ws"
^ string_of_sfm m2 ^ "_" ^ string_of_int g1 ^ "_" ^ string_of_int g2)
| G_GlGlSQSQ -> "gglglsqsq"
| G_PPSFSF f -> "gpp" ^ string_of_sff f ^ string_of_sff f
| G_ZZSFSF (f,g,m1,m2) -> "gzz" ^ string_of_sff f ^ string_of_sfm m1
^ string_of_sff f ^ string_of_sfm m2 ^ "_" ^ string_of_int g
| G_ZPSFSF (f,g,m1,m2) -> "gzp" ^ string_of_sff f ^ string_of_sfm m1
^ string_of_sff f ^ string_of_sfm m2 ^ "_" ^ string_of_int g
| G_GlPSQSQ -> "gglpsqsq"
| G_GlZSFSF (f,g,m1,m2) -> "ggl" ^ string_of_sff f ^ string_of_sfm m1
^ string_of_sff f ^ string_of_sfm m2 ^ "_" ^ string_of_int g
| G_GlWSUSD (vc,m1,m2,g1,g2) -> conj_symbol (vc, "gglwsu"
^ string_of_sfm m1 ^ "sd" ^ string_of_sfm m2 ^ "_" ^ string_of_int g1
^ "_" ^ string_of_int g2)
| G_GHGo4 1 -> "gzzg0g0" | G_GHGo4 2 -> "gzzgpgm"
| G_GHGo4 3 -> "gppgpgm" | G_GHGo4 4 -> "gzpgpgm"
| G_GHGo4 5 -> "gwwgpgm" | G_GHGo4 6 -> "gwwg0g0"
| G_GHGo4 7 -> "gwzg0g" | G_GHGo4 8 -> "gwzg0g"
| G_GHGo4 9 -> "gwzh1g" | G_GHGo4 10 -> "gwzh2g"
| G_GHGo4 11 -> "gwph1g" | G_GHGo4 12 -> "gwph2g"
| G_GHGo4 _ -> failwith "Coupling G_GHGo4 is not available"
| G_HSF31 (h,g,m1,m2,f1,f2) -> "g_" ^ string_of_higgs h ^
string_of_int g ^ string_of_sfm m1 ^ string_of_sfm m2 ^
string_of_sff f1 ^ string_of_sff f2
| G_HSF32 (h,g1,g2,m1,m2,f1,f2) -> "g_" ^ string_of_higgs h ^
string_of_int g1 ^ "_" ^ string_of_int g2 ^ string_of_sfm m1 ^
string_of_sfm m2 ^ string_of_sff f1 ^ string_of_sff f2
| G_HSF41 (h,g,m1,m2,f1,f2) -> "g_" ^ string_of_higgs h ^
string_of_int g ^ string_of_sfm m1 ^ string_of_sfm m2 ^
string_of_sff f1 ^ string_of_sff f2
| G_HSF42 (h,g1,g2,m1,m2,f1,f2) -> "g_" ^ string_of_higgs h ^
string_of_int g1 ^ "_" ^ string_of_int g2 ^ string_of_sfm m1 ^
string_of_sfm m2 ^ string_of_sff f1 ^ string_of_sff f2
| G_H1H1SFSF (f,m1,m2,n) -> "gh1h1" ^ string_of_sff f ^ string_of_sfm
m1 ^ string_of_sff f ^ string_of_sfm m2 ^ "_" ^ string_of_int n
| G_H1H2SFSF (f,m1,m2,n) -> "gh1h2" ^ string_of_sff f ^ string_of_sfm
m1 ^ string_of_sff f ^ string_of_sfm m2 ^ "_" ^ string_of_int n
| G_H2H2SFSF (f,m1,m2,n) -> "gh2h2" ^ string_of_sff f ^ string_of_sfm
m1 ^ string_of_sff f ^ string_of_sfm m2 ^ "_" ^ string_of_int n
| G_HHSFSF (f,m1,m2,n) -> "ghh" ^ string_of_sff f ^ string_of_sfm m1
^ string_of_sff f ^ string_of_sfm m2 ^ "_" ^ string_of_int n
| G_AASFSF (f,m1,m2,n) -> "gaa" ^ string_of_sff f ^ string_of_sfm m1
^ string_of_sff f ^ string_of_sfm m2 ^ "_" ^ string_of_int n
| G_HH1SUSD (vc,m1,m2,g1,g2) -> conj_symbol (vc, "ghh1su"
^ string_of_sfm m1 ^ "sd" ^ string_of_sfm m2 ^ "_" ^ string_of_int g1
^ "_" ^ string_of_int g2)
| G_HH2SUSD (vc,m1,m2,g1,g2) -> conj_symbol (vc, "ghh2su"
^ string_of_sfm m1 ^ "sd" ^ string_of_sfm m2 ^ "_" ^ string_of_int g1
^ "_" ^ string_of_int g2)
| G_HASUSD (vc,m1,m2,g1,g2) -> conj_symbol (vc, "ghasu"
^ string_of_sfm m1 ^ "sd" ^ string_of_sfm m2 ^ "_"
^ string_of_int g1 ^ "_" ^ string_of_int g2 ^ "_c")
| G_HH1SLSN (vc,m,g) -> conj_symbol (vc, "ghh1sl" ^ string_of_sfm m
^ "sn_" ^ string_of_int g)
| G_HH2SLSN (vc,m,g) -> conj_symbol (vc, "ghh2sl" ^ string_of_sfm m
^ "sn_" ^ string_of_int g)
| G_HASLSN (vc,m,g) -> conj_symbol (vc, "ghasl" ^ string_of_sfm m
^ "sn_" ^ string_of_int g)
| G_AG0SFSF (f,m1,m2,n) -> "gag0" ^ string_of_sff f ^ string_of_sfm m1
^ string_of_sff f ^ string_of_sfm m2 ^ "_" ^ string_of_int n
| G_HGSFSF (f,m1,m2,n) -> "ghg" ^ string_of_sff f ^ string_of_sfm m1
^ string_of_sff f ^ string_of_sfm m1 ^ "_" ^ string_of_int n
| G_GGSFSF (f,m1,m2,n) -> "ggg" ^ string_of_sff f ^ string_of_sfm m1
^ string_of_sff f ^ string_of_sfm m2 ^ "_" ^ string_of_int n
| G_G0G0SFSF (f,m1,m2,n) -> "gg0g0" ^ string_of_sff f ^ string_of_sfm m1
^ string_of_sff f ^ string_of_sfm m2 ^ "_" ^ string_of_int n
| G_HGSNSL (vc,m,n) -> conj_symbol (vc, "ghgsnsl" ^ string_of_sfm m ^ "_"
^ string_of_int n)
| G_H1GSNSL (vc,m,n) -> conj_symbol (vc, "gh1gsnsl" ^ string_of_sfm m ^ "_"
^ string_of_int n)
| G_H2GSNSL (vc,m,n) -> conj_symbol (vc, "gh2gsnsl" ^ string_of_sfm m ^ "_"
^ string_of_int n)
| G_AGSNSL (vc,m,n) -> conj_symbol (vc, "gagsnsl" ^ string_of_sfm m ^ "_"
^ string_of_int n)
| G_GGSNSL (vc,m,n) -> conj_symbol (vc, "gggsnsl" ^ string_of_sfm m ^ "_"
^ string_of_int n)
| G_HGSUSD (vc,m1,m2,g1,g2) -> conj_symbol (vc, "gghpsu" ^ string_of_sfm m1
^ "sd" ^ string_of_sfm m2 ^ "_" ^ string_of_int g1 ^ "_"
^ string_of_int g2)
| G_H1GSUSD (vc,m1,m2,g1,g2) -> conj_symbol (vc, "gh1gpsu" ^ string_of_sfm m1
^ "sd" ^ string_of_sfm m2 ^ "_" ^ string_of_int g1 ^ "_"
^ string_of_int g2)
| G_H2GSUSD (vc,m1,m2,g1,g2) -> conj_symbol (vc, "gh2gpsu" ^ string_of_sfm m1
^ "sd" ^ string_of_sfm m2 ^ "_" ^ string_of_int g1 ^ "_"
^ string_of_int g2)
| G_AGSUSD (vc,m1,m2,g1,g2) -> conj_symbol (vc, "gagpsu" ^ string_of_sfm m1
^ "sd" ^ string_of_sfm m2 ^ "_" ^ string_of_int g1 ^ "_"
^ string_of_int g2)
| G_GGSUSD (vc,m1,m2,g1,g2) -> conj_symbol (vc, "gggpsu" ^ string_of_sfm m1
^ "sd" ^ string_of_sfm m2 ^ "_" ^ string_of_int g1 ^ "_"
^ string_of_int g2)
| G_SN4 (g1,g2) -> "gsn4_" ^ string_of_int g1 ^ "_" ^ string_of_int g2
| G_SN2SL2_1 (m1,m2,g1,g2) -> "gsl_" ^ string_of_int g1 ^ "_sl_"
^ string_of_int g1 ^ "_sl" ^ string_of_sfm m1 ^ "_" ^ string_of_int g2
^ "_sl" ^ string_of_sfm m2 ^ "_" ^ string_of_int g2
| G_SN2SL2_2 (m1,m2,g1,g2) -> "gsl_" ^ string_of_int g1 ^ "_sl_"
^ string_of_int g2 ^ "_sl" ^ string_of_sfm m1 ^ "_" ^ string_of_int g1
^ "_sl" ^ string_of_sfm m2 ^ "_" ^ string_of_int g2 ^ "_mix"
| G_SF4 (f1,f2,m1,m2,m3,m4,g1,g2) -> "gsf" ^ string_of_sff f1 ^
string_of_sff f2 ^ string_of_sfm m1 ^ string_of_sfm m2 ^
string_of_sfm m3 ^ string_of_sfm m4 ^ string_of_int g1 ^
string_of_int g2
| G_SF4_3 (f1,f2,m1,m2,m3,m4,g1,g2,g3) -> "gsf" ^ string_of_sff f1 ^
string_of_sff f2 ^ string_of_sfm m1 ^ string_of_sfm m2 ^
string_of_sfm m3 ^ string_of_sfm m4 ^ string_of_int g1 ^
string_of_int g2 ^ "_" ^ string_of_int g3
| G_SF4_4 (f1,f2,m1,m2,m3,m4,g1,g2,g3,g4) -> "gsf" ^ string_of_sff f1 ^
string_of_sff f2 ^ string_of_sfm m1 ^ string_of_sfm m2 ^
string_of_sfm m3 ^ string_of_sfm m4 ^ string_of_int g1 ^ "_" ^
string_of_int g2 ^ string_of_int g3 ^ "_" ^ string_of_int g4
| G_SL4 (m1,m2,m3,m4,g) -> "gsl" ^ string_of_sfm m1 ^ "_"
^ "sl" ^ string_of_sfm m2 ^ "_" ^ "sl" ^ string_of_sfm m3 ^ "_"
^ "sl" ^ string_of_sfm m4 ^ "_" ^ string_of_int g
| G_SL4_2 (m1,m2,m3,m4,g1,g2) -> "gsl" ^ string_of_sfm m1 ^ "_"
^ "sl" ^ string_of_sfm m2 ^ "_" ^ "sl" ^ string_of_sfm m3 ^ "_"
^ "sl" ^ string_of_sfm m4 ^ "_" ^ string_of_int g1 ^ "_" ^
string_of_int g2
| G_SN2SQ2 (f,m1,m2,g1,g2) -> "gsn_" ^ string_of_int g1 ^ "_sn_"
^ string_of_int g1 ^ "_" ^ string_of_sff f ^ string_of_sfm m1 ^ "_"
^ string_of_int g2 ^ "_" ^ string_of_sff f ^ string_of_sfm m2 ^ "_"
^ string_of_int g2
| G_SL2SQ2 (f,m1,m2,m3,m4,g1,g2) -> "gsl" ^ string_of_sfm m1 ^ "_"
^ string_of_int g1 ^ "_sl" ^ string_of_sfm m2 ^ "_" ^ string_of_int g1
^ "_" ^ string_of_sff f ^ string_of_sfm m3 ^ "_" ^ string_of_int g2
^ "_" ^ string_of_sff f ^ string_of_sfm m4 ^ "_" ^ string_of_int g2
| G_SUSDSNSL (vc,m1,m2,m3,g1,g2,g3) -> conj_symbol (vc, "gsl"
^ string_of_sfm m3 ^ "_" ^ string_of_int g3 ^ "_sn_" ^ string_of_int g3
^ "_su" ^ string_of_sfm m1 ^ "_" ^ string_of_int g1 ^ "_sd"
^ string_of_sfm m2 ^ "_" ^ string_of_int g2)
| G_SU4 (m1,m2,m3,m4,g) -> "gsu" ^ string_of_sfm m1 ^ "_"
^ "_su" ^ string_of_sfm m2 ^ "_" ^ "_su" ^ string_of_sfm m3 ^ "_" ^
"_su" ^ string_of_sfm m4 ^ "_" ^ string_of_int g
| G_SU4_2 (m1,m2,m3,m4,g1,g2) -> "gsu" ^ string_of_sfm m1 ^ "_"
^ "_su" ^ string_of_sfm m2 ^ "_" ^ "_su" ^ string_of_sfm m3 ^ "_" ^
"_su" ^ string_of_sfm m4 ^ "_" ^ string_of_int g1 ^ "_" ^
string_of_int g2
| G_SD4 (m1,m2,m3,m4,g) -> "gsd" ^ string_of_sfm m1 ^ "_"
^ "_sd" ^ string_of_sfm m2 ^ "_" ^ "_sd" ^ string_of_sfm m3 ^ "_"
^ "_sd" ^ string_of_sfm m4 ^ "_" ^ string_of_int g
| G_SD4_2 (m1,m2,m3,m4,g1,g2) -> "gsd" ^ string_of_sfm m1 ^ "_"
^ "_sd" ^ string_of_sfm m2 ^ "_" ^ "_sd" ^ string_of_sfm m3 ^ "_"
^ "_sd" ^ string_of_sfm m4 ^ "_" ^ string_of_int g1 ^ "_" ^
string_of_int g2
| G_SU2SD2 (m1,m2,m3,m4,g1,g2,g3,g4) -> "gsu" ^ string_of_sfm m1
^ "_" ^ string_of_int g1 ^ "_su" ^ string_of_sfm m2 ^ "_"
^ string_of_int g2 ^ "_sd" ^ string_of_sfm m3 ^ "_" ^ string_of_int g3
^ "_sd" ^ string_of_sfm m4 ^ "_" ^ string_of_int g4
| M f -> "mass" ^ flavor_symbol f
| W f -> "width" ^ flavor_symbol f
| G_Grav -> "ggrav" | G_Gr_Ch C1 -> "ggrch1" | G_Gr_Ch C2 -> "ggrch2"
| G_Gr_Ch C1c -> "ggrch1c" | G_Gr_Ch C2c -> "ggrch2c"
| G_Gr_Z_Neu n -> "ggrzneu" ^ string_of_neu n
| G_Gr_A_Neu n -> "ggraneu" ^ string_of_neu n
| G_Gr4_Neu n -> "ggr4neu" ^ string_of_neu n
| G_Gr4_A_Ch C1 -> "ggr4ach1" | G_Gr4_A_Ch C2 -> "ggr4ach2"
| G_Gr4_A_Ch C1c -> "ggr4ach1c" | G_Gr4_A_Ch C2c -> "ggr4ach2c"
| G_Gr4_Z_Ch C1 -> "ggr4zch1" | G_Gr4_Z_Ch C2 -> "ggr4zch2"
| G_Gr4_Z_Ch C1c -> "ggr4zch1c" | G_Gr4_Z_Ch C2c -> "ggr4zch2c"
| G_Grav_N -> "ggravn"
| G_GravGl -> "gs * ggrav"
| G_Grav_L (g,m) -> "ggravl" ^ string_of_int g ^ string_of_sfm m
| G_Grav_Lc (g,m) -> "ggravl" ^ string_of_int g ^ string_of_sfm m ^ "c"
| G_Grav_U (g,m) -> "ggravu" ^ string_of_int g ^ string_of_sfm m
| G_Grav_Uc (g,m) -> "ggravu" ^ string_of_int g ^ string_of_sfm m ^ "c"
| G_Grav_D (g,m) -> "ggravd" ^ string_of_int g ^ string_of_sfm m
| G_Grav_Dc (g,m) -> "ggravd" ^ string_of_int g ^ string_of_sfm m ^ "c"
| G_Gr_H_Ch C1 -> "ggrhch1" | G_Gr_H_Ch C2 -> "ggrhch2"
| G_Gr_H_Ch C1c -> "ggrhch1c" | G_Gr_H_Ch C2c -> "ggrhch2c"
| G_Gr_H1_Neu n -> "ggrh1neu" ^ string_of_neu n
| G_Gr_H2_Neu n -> "ggrh2neu" ^ string_of_neu n
| G_Gr_H3_Neu n -> "ggrh3neu" ^ string_of_neu n
| G_Gr4A_Sl (g,m) -> "ggr4asl" ^ string_of_int g ^ string_of_sfm m
| G_Gr4A_Slc (g,m) -> "ggr4asl" ^ string_of_int g ^ string_of_sfm m ^ "c"
| G_Gr4A_Su (g,m) -> "ggr4asu" ^ string_of_int g ^ string_of_sfm m
| G_Gr4A_Suc (g,m) -> "ggr4asu" ^ string_of_int g ^ string_of_sfm m ^ "c"
| G_Gr4A_Sd (g,m) -> "ggr4asd" ^ string_of_int g ^ string_of_sfm m
| G_Gr4A_Sdc (g,m) -> "ggr4asd" ^ string_of_int g ^ string_of_sfm m ^ "c"
| G_Gr4Z_Sn -> "ggr4zsn" | G_Gr4Z_Snc -> "ggr4zsnc"
| G_Gr4Z_Sl (g,m) -> "ggr4zsl" ^ string_of_int g ^ string_of_sfm m
| G_Gr4Z_Slc (g,m) -> "ggr4zsl" ^ string_of_int g ^ string_of_sfm m ^ "c"
| G_Gr4Z_Su (g,m) -> "ggr4zsu" ^ string_of_int g ^ string_of_sfm m
| G_Gr4Z_Suc (g,m) -> "ggr4zsu" ^ string_of_int g ^ string_of_sfm m ^ "c"
| G_Gr4Z_Sd (g,m) -> "ggr4zsd" ^ string_of_int g ^ string_of_sfm m
| G_Gr4Z_Sdc (g,m) -> "ggr4zsd" ^ string_of_int g ^ string_of_sfm m ^ "c"
| G_Gr4W_Sl (g,m) -> "ggr4wsl" ^ string_of_int g ^ string_of_sfm m
| G_Gr4W_Slc (g,m) -> "ggr4wsl" ^ string_of_int g ^ string_of_sfm m ^ "c"
| G_Gr4W_Su (g,m) -> "ggr4wsu" ^ string_of_int g ^ string_of_sfm m
| G_Gr4W_Suc (g,m) -> "ggr4wsu" ^ string_of_int g ^ string_of_sfm m ^ "c"
| G_Gr4W_Sd (g,m) -> "ggr4wsd" ^ string_of_int g ^ string_of_sfm m
| G_Gr4W_Sdc (g,m) -> "ggr4wsd" ^ string_of_int g ^ string_of_sfm m ^ "c"
| G_Gr4Gl_Su (g,m) -> "ggr4glsu" ^ string_of_int g ^ string_of_sfm m
| G_Gr4Gl_Suc (g,m) -> "ggr4glsu" ^ string_of_int g ^ string_of_sfm m ^ "c"
| G_Gr4Gl_Sd (g,m) -> "ggr4glsd" ^ string_of_int g ^ string_of_sfm m
| G_Gr4Gl_Sdc (g,m) -> "ggr4glsd" ^ string_of_int g ^ string_of_sfm m ^ "c"
| G_Gr4_Z_H1 n -> "ggr4zh1_" ^ string_of_neu n
| G_Gr4_Z_H2 n -> "ggr4zh2_" ^ string_of_neu n
| G_Gr4_Z_H3 n -> "ggr4zh3_" ^ string_of_neu n
| G_Gr4_W_H n -> "ggr4wh_" ^ string_of_neu n
| G_Gr4_W_Hc n -> "ggr4whc_" ^ string_of_neu n
| G_Gr4_H_A C1 -> "ggr4ha1" | G_Gr4_H_A C2 -> "ggr4ha2"
| G_Gr4_H_A C1c -> "ggr4ha1c" | G_Gr4_H_A C2c -> "ggr4ha2c"
| G_Gr4_H_Z C1 -> "ggr4hz1" | G_Gr4_H_Z C2 -> "ggr4hz2"
| G_Gr4_H_Z C1c -> "ggr4hz1c" | G_Gr4_H_Z C2c -> "ggr4hz2c"
| G_Gr4W_Sn -> "ggr4wsn"
| G_Gr4W_Snc -> "ggr4wsnc"
end
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/fusion_vintage.mli
===================================================================
--- trunk/omega/src/fusion_vintage.mli (revision 8899)
+++ trunk/omega/src/fusion_vintage.mli (revision 8900)
@@ -1,383 +1,423 @@
(* fusion.mli --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
+(* \thocwmodulesection{Signature of [Fusion.T]} *)
+
module type T =
sig
val options : Options.t
(* JRR's implementation of Majoranas needs a special case. *)
val vintage : bool
(* Wavefunctions are an abstract data type, containing a momentum~[p]
and additional quantum numbers, collected in~[flavor]. *)
type wf
+
+(* Return the wave function with the the same momentum and a
+ charge conjugated [flavor]. *)
val conjugate : wf -> wf
(* Obviously, [flavor] is not restricted to the physical notion of
- flavor, but can carry spin, color, etc. *)
+ flavor, but can carry spin, color, etc. See the implementation of
+ [Model.T] for the physics. *)
type flavor
val flavor : wf -> flavor
+
+(* If [flavor] contains powers of coupling orders, it is sometimes useful
+ for organizing the output and for diagnostics to be able to strip it
+ away. *)
+ type flavor_all_orders
+ val flavor_all_orders : wf -> flavor_all_orders
+
+(* If [flavor] contains $\textrm{SU}(3)$ color, it is sometimes useful
+ for organizing the output and for diagnostics to be able to strip it
+ away. *)
type flavor_sans_color
val flavor_sans_color : wf -> flavor_sans_color
(* Momenta are represented by an abstract datatype (defined
in~[Momentum]) that is optimized for performance. They can be
accessed either abstractly or as lists of indices of the external
momenta. These indices are assigned sequentially by [amplitude] below. *)
type p
val momentum : wf -> p
val momentum_list : wf -> int list
-(* At tree level, the wave functions are uniquely specified by [flavor]
- and momentum. If loops are included, we need to distinguish among
- orders. Also, if we build a result from an incomplete sum of diagrams,
- we need to add a distinguishing mark. At the moment, we assume that a
- [string] that can be attached to the symbol suffices. *)
- val wf_tag : wf -> string option
-
(* Coupling constants *)
type constant
(* and right hand sides of assignments. The latter are formed from a sign from
Fermi statistics, a coupling (constand and Lorentz structure) and wave
- functions. *)
+ functions of the children. *)
type coupling
type rhs
+
+(* \begin{dubious}
+ There is no deep reason for defining a polymorphic
+ [type 'a children], since we will only ever use [wf children].
+ \end{dubious} *)
type 'a children
- val sign : rhs -> int
- val coupling : rhs -> constant Coupling.t
- val coupling_tag : rhs -> string option
+(* Keep track of statistics. *)
+ val sign : rhs -> int
- type exclusions
- val no_exclusions : exclusions
+(* Extract the coupling (constant and structure) fusing the children. *)
+ val coupling : rhs -> constant Coupling.t
(* In renormalized perturbation theory, couplings come in different orders
of the loop expansion. Be prepared: [val order : rhs -> int] *)
(* \begin{dubious}
- This is here only for the benefit of [Target] and shall become
- [val children : rhs -> wf children] later \ldots
+ The concrete return type [wf list] is here only for the benefit
+ of [Target] and could become [wf children] in a more refined
+ interface \ldots
\end{dubious} *)
val children : rhs -> wf list
(* Fusions come in two types: fusions of wave functions to off-shell wave
functions:
\begin{equation*}
- \phi(p+q) = \phi(p)\phi(q)
+ \phi'(p+q) = \phi_1(p)\phi_2(q)
\end{equation*} *)
type fusion
val lhs : fusion -> wf
val rhs : fusion -> rhs list
(* and products at the keystones:
\begin{equation*}
- \phi(-p-q)\cdot\phi(p)\phi(q)
+ \braket{\phi'(-p-q)|\phi_1(p)\phi_2(q)}
\end{equation*} *)
type braket
val bra : braket -> wf
val ket : braket -> rhs list
(* [amplitude goldstones incoming outgoing] calculates the
amplitude for scattering of [incoming] to [outgoing]. If
[goldstones] is true, also non-propagating off-shell Goldstone
amplitudes are included to allow the checking of Slavnov-Taylor
- identities. *)
+ identities. [selectors] is an instance of [Cascade.T.selectors]
+ and used to select certain parts of an amplitude, see
+ section~\ref{sec:cascades}. *)
type amplitude
type amplitude_sans_color
type selectors
- val amplitudes : bool -> exclusions -> selectors ->
+ type slicings
+ val amplitudes : bool -> selectors -> slicings option ->
+ flavor_sans_color list -> flavor_sans_color list -> amplitude list
+ val amplitudes_all_orders : bool -> selectors ->
flavor_sans_color list -> flavor_sans_color list -> amplitude list
- val amplitude_sans_color : bool -> exclusions -> selectors ->
+ val amplitude_sans_color : bool -> selectors ->
flavor_sans_color list -> flavor_sans_color list -> amplitude_sans_color
+(* How a given wave function depends on other wave functions and
+ couplings. This is used for finding subexpressions common
+ among different color flow amplitudes. *)
val dependencies : amplitude -> wf -> (wf, coupling) Tree2.t
(* We should be precise regarding the semantics of the following functions, since
modules implementating [Target] must not make any mistakes interpreting the
return values. Instead of calculating the amplitude
\begin{subequations}
\begin{equation}
\label{eq:physical-amplitude}
\Braket{f_3,p_3,f_4,p_4,\ldots|T|f_1,p_1,f_2,p_2}
\end{equation}
directly, O'Mega calculates the---equivalent, but more symmetrical---crossed
amplitude
\begin{equation}
\Braket{\bar f_1,-p_1,\bar f_2,-p_2,f_3,p_3,f_4,p_4,\ldots|T|0}
\end{equation}
- Internally, all flavors are represented by their charge conjugates
+ For the benefit of the people implementing [Model]s, however,
+ all flavors are represented internally by the charge conjugates
\begin{equation}
\label{eq:internal-amplitude}
A(f_1,-p_1,f_2,-p_2,\bar f_3,p_3,\bar f_4,p_4,\ldots)
\end{equation}
\end{subequations}
- The correspondence of vertex and term in the lagrangian
+ Indeed, the vertex and corresponding term in the lagrangian
\begin{equation}
\parbox{26\unitlength}{%
\fmfframe(5,3)(5,3){%
\begin{fmfgraph*}(15,20)
\fmfleft{v}
\fmfright{p,A,e}
\fmflabel{$\mathrm{e}^-$}{e}
\fmflabel{$\mathrm{e}^+$}{p}
\fmflabel{$\mathrm{A}$}{A}
\fmf{fermion}{p,v,e}
\fmf{photon}{A,v}
\fmfdot{v}
\end{fmfgraph*}}}: \bar\psi\fmslash{A}\psi
\end{equation}
suggests to denote the \emph{outgoing} particle by the flavor of the
\emph{anti}particle and the \emph{outgoing} \emph{anti}particle by the
flavor of the particle, since this choice allows to represent the vertex
by a triple
\begin{equation}
\bar\psi\fmslash{A}\psi: (\mathrm{e}^+,A,\mathrm{e}^-)
\end{equation}
which is more intuitive than the alternative $(\mathrm{e}^-,A,\mathrm{e}^+)$.
Also, when thinking in terms of building wavefunctions from the outside in,
the outgoing \emph{antiparticle} is represented by a \emph{particle}
propagator and vice versa\footnote{Even if this choice will appear slightly
counter-intuitive on the [Target] side, one must keep in mind that much more
people are expected to prepare [Model]s.}.
- [incoming] and [outgoing] are the physical flavors as
- in~(\ref{eq:physical-amplitude}) *)
+ Note that [incoming] and [outgoing] are the physical flavors as
+ in~(\ref{eq:physical-amplitude}) or in the argument of [amplitudes],
+ but with the color flow quantum numbers added. *)
val incoming : amplitude -> flavor list
val outgoing : amplitude -> flavor list
-(* [externals] are flavors and momenta as in~(\ref{eq:internal-amplitude}) *)
+(* In contrast, [externals] are flavors and momenta as
+ in~(\ref{eq:internal-amplitude}) *)
val externals : amplitude -> wf list
+(* Return all off-shell wave functions so that [Target] can allocate
+ variables for them. *)
val variables : amplitude -> wf list
+
+(* Return all [fusion]s in an order so that all right hand sides
+ have been computed before they are used. *)
val fusions : amplitude -> fusion list
- val brakets : amplitude -> braket list
- val on_shell : amplitude -> (wf -> bool)
- val is_gauss : amplitude -> (wf -> bool)
+
+(* Return all [braket]s. *)
+ type 'a slices
+ val brakets : amplitude -> braket list slices
+
+(* Test if an off-shell wave function has been forced on-shell
+ or is smeared as as gaussian. *)
+ val on_shell : amplitude -> wf -> bool
+ val is_gauss : amplitude -> wf -> bool
+
+(* Describe the constraints in the [selectors] argument to [amplitudes]. *)
val constraints : amplitude -> string option
+
+(* Human readable description of the requested slicings of type [Orders.Conditions.] *)
+ val slicings : amplitude -> string list
+
+(* Compute the symmetry factor $\prod_i n_i!$ for identical outgoing
+ particles. *)
val symmetry : amplitude -> int
+(* Quickly test whether an amplitude vanishes. *)
val allowed : amplitude -> bool
(*i
(* \thocwmodulesubsection{Performance Hacks} *)
val initialize_cache : string -> unit
val set_cache_name : string -> unit
i*)
(* \thocwmodulesubsection{Diagnostics} *)
+(* Compute a list of all charge conservation violating vertices in the [Model]. *)
val check_charges : unit -> flavor_sans_color list list
+
+(* Count the fusions and propagators that are computed and compare
+ to the number of Feynman diagrams appearing in the amplitude. *)
val count_fusions : amplitude -> int
val count_propagators : amplitude -> int
val count_diagrams : amplitude -> int
+(* Expand the [DAG] beneath an off-shell wave function into the corresponding
+ forest. \textit{Use with caution for complicated processes!} *)
val forest : wf -> amplitude -> ((wf * coupling option, wf) Tree.t) list
+
+(* A list of all combinations of off-shell wave functions in the
+ Feynman diagrams described by the [DAG]. This could be used for
+ phase space mappings, but lies dormant at the moment.
+ \begin{dubious}
+ At the moment, the result contains empty lists and many
+ redundancies. This should be cleaned up!
+ \end{dubious} *)
val poles : amplitude -> wf list list
+
+(* A list of all $s$-channel poles in the [DAG]. Helpful
+ for phase space mappings and for fudging widths. *)
val s_channel : amplitude -> wf list
+(* Prepare \texttt{.dot} files as input fot \texttt{graphviz}
+ to draw graphical representations of the tower of of-shell
+ wavefunctions and the dag corresponding to the amplitude. *)
val tower_to_dot : out_channel -> amplitude -> unit
val amplitude_to_dot : out_channel -> amplitude -> unit
(* \thocwmodulesubsection{WHIZARD} *)
+(* Phase space descriptions for \texttt{WHIZARD}. Once as written
+ and once with the incoming particles exchanged. This way
+ we can write a tree starting from the first and one from
+ the second incoming particle. *)
val phase_space_channels : out_channel -> amplitude_sans_color -> unit
val phase_space_channels_flipped : out_channel -> amplitude_sans_color -> unit
end
-(* There is more than one way to make fusions. *)
+(* \thocwmodulesection{Various Functors generating [Fusion.T]} *)
+
+(* There is more than one way to make fusions, differing in the
+ unterlying topology of diagrams. *)
module type Maker =
functor (P : Momentum.T) -> functor (M : Model.T) ->
T with type p = P.t
- and type flavor = Colorize.It(M).flavor
+ and type flavor = Orders.Slice(Colorize.It(M)).flavor
+ and type flavor_all_orders = Colorize.It(M).flavor
and type flavor_sans_color = M.flavor
and type constant = M.constant
and type selectors = Cascade.Make(M)(P).selectors
+ and type slicings = Orders.Conditions(Colorize.It(M)).t
+ and type 'a slices = (Orders.Slice(Colorize.It(M)).orders * 'a) list
(*i If we want or need to expose [Make], here's how to do it:
module type Stat =
sig
type flavor
type stat
exception Impossible
val stat : flavor -> int -> stat
val stat_fuse : stat -> stat -> flavor -> stat
val stat_sign : stat -> int
end
module type Stat_Maker = functor (M : Model.T) ->
Stat with type flavor = M.flavor
module Make : functor (PT : Tuple.Poly) (Stat : Stat_Maker)
(T : Topology.T with type 'a children = 'a PT.t) -> Maker
i*)
(* Straightforward Dirac fermions vs. slightly more complicated
Majorana fermions: *)
module Binary : Maker
module Binary_Majorana : Maker
module Mixed23 : Maker
module Mixed23_Majorana : Maker
module Nary : functor (B : Tuple.Bound) -> Maker
module Nary_Majorana : functor (B : Tuple.Bound) -> Maker
(* We can also proceed \'a la~\cite{HELAC:2000}. Empirically,
this will use slightly~($O(10\%)$) fewer fusions than the
symmetric factorization. Our implementation uses
significantly~($O(50\%)$) fewer fusions than reported
by~\cite{HELAC:2000}. Our pruning of the DAG might
be responsible for this. *)
module Helac : functor (B : Tuple.Bound) -> Maker
module Helac_Majorana : functor (B : Tuple.Bound) -> Maker
(* \thocwmodulesection{Multiple Amplitudes} *)
module type Multi =
sig
exception Mismatch
val options : Options.t
type flavor
type process = flavor list * flavor list
type amplitude
type fusion
type wf
- type exclusions
- val no_exclusions : exclusions
type selectors
+ type slicings
type amplitudes
(* Construct all possible color flow amplitudes for a given process. *)
val amplitudes : bool -> int option ->
- exclusions -> selectors -> process list -> amplitudes
+ selectors -> slicings option -> process list -> amplitudes
val empty : amplitudes
(*i
(* Precompute the vertex table cache. *)
val initialize_cache : string -> unit
val set_cache_name : string -> unit
i*)
(* The list of all combinations of incoming and outgoing particles
with a nonvanishing scattering amplitude. *)
val flavors : amplitudes -> process list
(* The list of all combinations of incoming and outgoing particles that
don't lead to any color flow with non vanishing scattering amplitude. *)
val vanishing_flavors : amplitudes -> process list
(* The list of all color flows with a nonvanishing scattering amplitude. *)
val color_flows : amplitudes -> Color.Flow.t list
(* The list of all valid helicity combinations. *)
val helicities : amplitudes -> (int list * int list) list
(* The list of all amplitudes. *)
val processes : amplitudes -> amplitude list
(* [(process_table a).(f).(c)] returns the amplitude for the [f]th
allowed flavor combination and the [c]th allowed color flow as
an [amplitude option]. *)
val process_table : amplitudes -> amplitude option array array
(* The list of all non redundant fusions together with the amplitudes
they came from. *)
val fusions : amplitudes -> (fusion * amplitude) list
(* If there's more than external flavor state, the wavefunctions are
\emph{not} uniquely specified by [flavor] and [Momentum.t]. This
function can be used to determine how many variables must be allocated. *)
val multiplicity : amplitudes -> wf -> int
(* This function can be used to disambiguate wavefunctions with the same
combination of [flavor] and [Momentum.t]. *)
val dictionary : amplitudes -> amplitude -> wf -> int
(* [(color_factors a).(c1).(c2)] power of~$N_C$ for the given product
of color flows. *)
val color_factors : amplitudes -> Color.Flow.factor array array
(* A description of optional diagram selectors. *)
val constraints : amplitudes -> string option
+ (* Human readable description of the requested slicings of type [Orders.Conditions.] *)
+ val slicings : amplitudes -> string list
+
end
module type Multi_Maker = functor (Fusion_Maker : Maker) ->
functor (P : Momentum.T) ->
functor (M : Model.T) ->
Multi with type flavor = M.flavor
and type amplitude = Fusion_Maker(P)(M).amplitude
and type fusion = Fusion_Maker(P)(M).fusion
and type wf = Fusion_Maker(P)(M).wf
and type selectors = Fusion_Maker(P)(M).selectors
+ and type slicings = Orders.Conditions(Colorize.It(M)).t
module Multi : Multi_Maker
-(* \thocwmodulesection{Tags} *)
-
-(* It appears that there are useful applications for tagging couplings
- and wave functions, e.\,g.~skeleton expansion and diagram selections.
- We can abstract this in a [Tags] signature: *)
-
-module type Tags =
- sig
- type wf
- type coupling
- type 'a children
- val null_wf : wf
- val null_coupling : coupling
- val fuse : coupling -> wf children -> wf
- val wf_to_string : wf -> string option
- val coupling_to_string : coupling -> string option
- end
-
-module type Tagger =
- functor (PT : Tuple.Poly) -> Tags with type 'a children = 'a PT.t
-
-module type Tagged_Maker =
- functor (Tagger : Tagger) ->
- functor (P : Momentum.T) -> functor (M : Model.T) ->
- T with type p = P.t
- and type flavor = Colorize.It(M).flavor
- and type flavor_sans_color = M.flavor
- and type constant = M.constant
-
-module Tagged_Binary : Tagged_Maker
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/NEList.ml
===================================================================
--- trunk/omega/src/NEList.ml (revision 0)
+++ trunk/omega/src/NEList.ml (revision 8900)
@@ -0,0 +1,59 @@
+(* NEList.ml --
+
+ Copyright (C) 2022-2023 by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+ with contributions from
+ Christian Speckner <cnspeckn@googlemail.com>
+
+ 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. *)
+
+(* The implementation is now trivial, except for the few cases
+ where we need to avoid incomplete pattern match warnings: *)
+
+let impossible f = failwith ("NList." ^ f ^ ": impossible []")
+
+type 'a t = 'a list
+
+let make a alist = a :: alist
+let singleton a = make a []
+let cons = make
+
+let to_list l = l [@@inline]
+
+let hd = List.hd
+let tl = List.tl
+
+let tl_opt = function
+ | [] -> impossible "tl_opt"
+ | [_] -> None
+ | _ :: tail -> Some tail
+
+let snoc = function
+ | [] -> impossible "snoc"
+ | head :: tail -> (head, tail)
+
+let snoc_opt = function
+ | [] -> impossible "snoc_opt"
+ | [head] -> (head, None)
+ | head :: tail -> (head, Some tail)
+
+let map = List.map
+let fold_right = List.fold_right
+let sort = List.sort
+
+
Index: trunk/omega/src/targets_vintage.mli
===================================================================
--- trunk/omega/src/targets_vintage.mli (revision 0)
+++ trunk/omega/src/targets_vintage.mli (revision 8900)
@@ -0,0 +1,102 @@
+(* targets_vintage.mli --
+
+ Copyright (C) 1999-2023 by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+ with contributions from
+ Christian Speckner <cnspeckn@googlemail.com>
+
+ 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. *)
+
+(* This is the original implementation of [Target_Fortran().print_current] for
+ hard coded models with [Coupling.V3] and [Coupling.V4] vertices only.
+ It was adequate for the Standard Model and simple extensions upto the MSSM.
+ The extension to higher dimensional operators became more and more baroque ---
+ to the extent to be almost unmaintainable. In order to make [Target_Fortran]
+ maintainable, this code has been factored out. *)
+
+(* Output routines for fermion couplings. *)
+module type Fermions =
+ sig
+ open Coupling
+ val print_current : int * fermionbar * boson * fermion ->
+ string -> string -> string -> fuse2 -> unit
+ val print_current_mom : int * fermionbar * boson * fermion ->
+ string -> string -> string -> string -> string -> string -> fuse2 -> unit
+ val print_current_p : int * fermion * boson * fermion ->
+ string -> string -> string -> fuse2 -> unit
+ val print_current_b : int * fermionbar * boson * fermionbar ->
+ string -> string -> string -> fuse2 -> unit
+ val print_current_g : int * fermionbar * boson * fermion ->
+ string -> string -> string -> string -> string -> string -> fuse2 -> unit
+ val print_current_g4 : int * fermionbar * boson2 * fermion ->
+ string -> string -> string -> string -> fuse3 -> unit
+ val reverse_braket : bool -> lorentz -> lorentz list -> bool
+ end
+
+(* We need to use the names of Fortran types, wave function variables and
+ propagator functions consistently with \texttt{omegalib} and [Target_Fortran]. *)
+module type Fermion_Maker = functor (N : Target_Fortran_Names.T) -> Fermions
+
+module Fortran_Fermions : Fermion_Maker
+module Fortran_Majorana_Fermions : Fermion_Maker
+
+(* Output routines triple and quartic vertices. *)
+module type T =
+ sig
+
+ type amplitude
+ type constant
+ type wf
+ type rhs
+
+ (* [print_current_V3 format_wf format_p amplitude dictionary
+ amplitude dictionary rhs vertex fusion constant] writes code
+ combining the children [rhs] into a current, using the vertex factor
+ [vertex], coupling [constant] and the permutation [fusion] of its legs.
+ [amplitude] is used with [dictionary] to disambiguate wavefunctions
+ with the same flavor and momentum. The formatting functions
+ [format_wf] and [format_p] must be compatible with the remaining
+ implementation of [Target]. *)
+ (* \begin{dubious}
+ The type is probably unnecessarily higher order. It was natural
+ in the monolithic implementation and has been kept in the first
+ refactoring step.
+ \end{dubious} *)
+ val print_current_V3 :
+ (amplitude -> (amplitude -> wf -> int) -> wf -> string) -> (wf -> string) ->
+ amplitude -> (amplitude -> wf -> int) -> rhs ->
+ constant Coupling.vertex3 -> Coupling.fuse2 -> constant -> unit
+
+ val print_current_V4 :
+ (amplitude -> (amplitude -> wf -> int) -> wf -> string) -> (wf -> string) ->
+ amplitude -> (amplitude -> wf -> int) -> rhs ->
+ constant Coupling.vertex4 -> Coupling.fuse3 -> constant -> unit
+
+ end
+
+module type Maker =
+ functor (N : Target_Fortran_Names.T) -> functor (F : Fermion_Maker) ->
+ functor (FM : Fusion.Maker) -> functor (P : Momentum.T) -> functor (M : Model.T) -> T
+ with type amplitude = Fusion.Multi(FM)(P)(M).amplitude
+ and type constant = Orders.Slice(Colorize.It(M)).constant
+ and type wf = FM(P)(M).wf
+ and type rhs = FM(P)(M).rhs
+
+ module Make_Fortran : Maker
+
+
Index: trunk/omega/src/omega_AltH.ml
===================================================================
--- trunk/omega/src/omega_AltH.ml (revision 8899)
+++ trunk/omega/src/omega_AltH.ml (revision 8900)
@@ -1,36 +1,27 @@
(* omega_AltH.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@physik.uni-freiburg.de>
with contributions from
Marco Sekulla <marco.sekulla@kit.edu>
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.Fortran)
- (Modellib_NoH.AltH(Modellib_NoH.NoH_k_matrix))
+module O = Omega.Mixed23(Target_Fortran.Make)(Modellib_NoH.AltH(Modellib_NoH.NoH_k_matrix))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/omega_Littlest_Tpar.ml
===================================================================
--- trunk/omega/src/omega_Littlest_Tpar.ml (revision 8899)
+++ trunk/omega/src/omega_Littlest_Tpar.ml (revision 8900)
@@ -1,35 +1,26 @@
(* omega_Littlest_Tpar.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.Fortran)
- (Modellib_BSM.Littlest_Tpar(Modellib_BSM.BSM_bsm))
+module O = Omega.Mixed23(Target_Fortran.Make)(Modellib_BSM.Littlest_Tpar(Modellib_BSM.BSM_bsm))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/omega_SM_Majorana_legacy.ml
===================================================================
--- trunk/omega/src/omega_SM_Majorana_legacy.ml (revision 8899)
+++ trunk/omega/src/omega_SM_Majorana_legacy.ml (revision 8900)
@@ -1,26 +1,26 @@
(* omega_SM_Maj.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23_Majorana_vintage(Targets.Fortran_Majorana)(Modellib_SM.SM(Modellib_SM.SM_no_anomalous))
+module O = Omega.Mixed23_Majorana_vintage(Target_Fortran.Make_Majorana)(Modellib_SM.SM(Modellib_SM.SM_no_anomalous))
let _ = O.main ()
Index: trunk/omega/src/UFOx_parser.mly
===================================================================
--- trunk/omega/src/UFOx_parser.mly (revision 8899)
+++ trunk/omega/src/UFOx_parser.mly (revision 8900)
@@ -1,84 +1,111 @@
/* vertex_parser.mly --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
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. */
/* Right recursion is more convenient for constructing
the value. Since the lists will always be short,
there is no performace or stack size reason for
prefering left recursion. */
%{
module X = UFOx_syntax
let parse_error msg =
raise (UFOx_syntax.Syntax_Error
(msg, symbol_start_pos (), symbol_end_pos ()))
let invalid_parameter_attr () =
parse_error "invalid parameter attribute"
%}
%token < int > INT
%token < float > FLOAT
%token < string > ID QUOTED
%token PLUS MINUS TIMES POWER DIV
-%token LPAREN RPAREN COMMA
+%token LPAREN RPAREN LBRACKET RBRACKET COMMA
%token END
%left PLUS MINUS
%left TIMES DIV
%nonassoc UNARY
%right POWER
%start input
%type < UFOx_syntax.expr > input
%%
input:
| expr END { $1 }
;
expr:
| INT { X.integer $1 }
| FLOAT { X.float $1 }
| ID { X.variable $1 }
| QUOTED { X.quoted $1 }
+ | young_tableau { X.young_tableau $1 }
| expr PLUS expr { X.add $1 $3 }
| expr MINUS expr { X.subtract $1 $3 }
| expr TIMES expr { X.multiply $1 $3 }
| expr DIV expr { X.divide $1 $3 }
| PLUS expr %prec UNARY { $2 }
| MINUS expr %prec UNARY { X.multiply (X.integer (-1)) $2 }
| expr POWER expr { X.power $1 $3 }
| LPAREN expr RPAREN { $2 }
| ID LPAREN RPAREN { X.apply $1 [] }
| ID LPAREN args RPAREN { X.apply $1 $3 }
;
args:
| expr { [$1] }
| expr COMMA args { $1 :: $3 }
;
+
+young_tableau:
+ | LBRACKET RBRACKET { [] }
+ | LBRACKET integer_lists RBRACKET { $2 }
+;
+
+integer_lists:
+ | integer_list { [$1] }
+ | integer_list COMMA integer_lists { $1 :: $3 }
+;
+
+integer_list:
+ | LBRACKET RBRACKET { [] }
+ | LBRACKET integers RBRACKET { $2 }
+
+;
+
+integers:
+ | integer { [$1] }
+ | integer COMMA integers { $1 :: $3 }
+;
+
+integer:
+ | INT { $1 }
+ | MINUS INT { ~- $2 }
+;
Index: trunk/omega/src/omega_SM.ml
===================================================================
--- trunk/omega/src/omega_SM.ml (revision 8899)
+++ trunk/omega/src/omega_SM.ml (revision 8900)
@@ -1,26 +1,26 @@
(* omega_SM.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.Fortran)(Modellib_SM.SM(Modellib_SM.SM_no_anomalous))
+module O = Omega.Mixed23(Target_Fortran.Make)(Modellib_SM.SM(Modellib_SM.SM_no_anomalous))
let _ = O.main ()
Index: trunk/omega/src/omega_SM_ul.ml
===================================================================
--- trunk/omega/src/omega_SM_ul.ml (revision 8899)
+++ trunk/omega/src/omega_SM_ul.ml (revision 8900)
@@ -1,36 +1,27 @@
(* omega_SM_ul.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Marco Sekulla <marco.sekulla@kit.edu>
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.Fortran)
- (Modellib_SM.SM(Modellib_SM.SM_k_matrix))
+module O = Omega.Mixed23(Target_Fortran.Make)(Modellib_SM.SM(Modellib_SM.SM_k_matrix))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/omega_cli.mli
===================================================================
--- trunk/omega/src/omega_cli.mli (revision 0)
+++ trunk/omega/src/omega_cli.mli (revision 8900)
@@ -0,0 +1,52 @@
+(* omega_cli.mli --
+
+ Copyright (C) 1999-2023 by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+
+ 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. *)
+
+(* \begin{dubious}
+ Next generation command line interface.
+
+ Ideally, I would have liked to use \texttt{cmdliner}
+ (\url{https://erratique.ch/software/cmdliner}),
+ but more recent versions of this require ocaml 4.08.
+ Also, building it without \texttt{dune} might be a challenge.
+
+ Neverthess, I will take inspiration from \texttt{cmdliner}.
+ \end{dubious} *)
+
+module Models : sig
+ type t
+ val of_list : (string * string * (module Model.T)) list -> t
+ val by_name_opt : t -> string -> (module Model.T) option
+ val names : t -> (string * string) list
+end
+
+(* Since there are only very few implementations of [Target.Maker]
+ that are actively maintained and only [Targets.Fortran_Majorana]
+ can currently deal with Majorana fermions, we don't implement
+ a lookup table but select them explicitey according to the command line
+ options. *)
+
+module type T =
+ sig
+ val main : ?current:int ref -> ?argv:string array -> unit -> unit
+ end
+
+module Make (F : Fusion.Maker) (P : Fusion.Maker) (T : Target.Maker) (M : Model.Mutable) : T
Index: trunk/omega/src/color_Fusion.ml
===================================================================
--- trunk/omega/src/color_Fusion.ml (revision 0)
+++ trunk/omega/src/color_Fusion.ml (revision 8900)
@@ -0,0 +1,901 @@
+(* color_Fusion.ml --
+
+ Copyright (C) 2022-2023 by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+ with contributions from
+ Christian Speckner <cnspeckn@googlemail.com>
+
+ 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. *)
+
+(* \label{sec:colorflow-fusions} *)
+
+(* Here we will use the color flow described by a [Arrow.free list]
+ to determine the possible outgoing color flows for the incoming
+ color flows in a fusion. This translates from vertices described
+ by connections among integers describing factors in the tensor product
+ to color flows with integers describing individual color flow lines.
+ For the treatment of $\epsilon$ and $\bar\epsilon$, see the discussion
+ on page~\pageref{sec:epsilon-evaluation-strategy}. *)
+
+(* \begin{dubious}
+ At the moment both the factors in the tensor product and
+ the color flow lines are [int]s. This could be made clearer
+ by abstract types.
+ \end{dubious} *)
+
+(* \begin{dubious}
+ This still needs to be extended to $\epsilon$ and $\bar\epsilon$,
+ i.\,e.~[Arrow.free_eps] and [Arrow.free_eps_bar].
+ \end{dubious} *)
+
+module A = Arrow
+open A.Infix
+module CP = Color_Propagator
+module L = Algebra.Laurent
+module QC = Algebra.QC
+
+(* Take a [Color_Propagator.t list], ignore the uncolored ([Color_Propagator.W])
+ ones and construct a map into the colored ones indexed by
+ the offset into the original list.
+ Actually, one could use a [Color_Propagator.t option array] instead,
+ but the elements of ['a array] are updated in place, making
+ it harder to keep track. *)
+let line_map lines =
+ let _, map =
+ List.fold_left
+ (fun (i, acc) line ->
+ (succ i,
+ if CP.is_white line then
+ acc
+ else
+ PArray.add i line acc))
+ (1, PArray.empty)
+ lines in
+ map
+
+(* [clear i lines] removes the [Color_Propagator.t] at position [i]
+ from the map [lines]. *)
+let clear = PArray.remove
+
+(* Return $+1$ if the list [l1] is an even permutation of
+ the list [l2], $-1$ if [l1] is an odd permutation of [l2]
+ and $0$ otherwise. *)
+let relative_permutation l1 l2 =
+ let eps1, l1 = Combinatorics.sort_signed l1
+ and eps2, l2 = Combinatorics.sort_signed l2 in
+ if l1 = l2 then
+ eps1 * eps2
+ else
+ 0
+
+(* Return the integers in the list [elements] that are not in
+ the list [universe]. *)
+let not_in elements universe =
+ let universe = Sets.Int.of_list universe in
+ let rec collect missing = function
+ | [] -> missing
+ | x :: tail ->
+ if Sets.Int.mem x universe then
+ collect missing tail
+ else
+ collect (x :: missing) tail in
+ collect [] elements
+
+(* [open_epsilon] is an $\epsilon_{ii_2\cdots i_n}$
+ (or~$\bar\epsilon^{ii_2\cdots i_n}$)
+ with one index~$i$ open and [epsilon_bar] a matching
+ $\bar\epsilon^{j_1j_2\cdots j_n}$
+ (or $\epsilon_{j_1j_2\cdots j_n}$). Replace~$i$
+ by the single $j\in\{j_m\}_{m=1,\ldots,n}$ with
+ $j\not\in\{i_m\}_{m=2,\ldots,n}$ and compute
+ \begin{equation}
+ \epsilon_{ii_2\cdots i_n}
+ \bar\epsilon^{j_1j_2\cdots j_n}
+ = \delta_{ii_2\cdots i_n}^{j_1j_2\cdots j_n}
+ = \sum_{\sigma\in S_n} (-1)^{\varepsilon(\sigma)}
+ \delta_{i}^{\sigma(j_1)}
+ \delta_{i_2}^{\sigma(j_2)}
+ \cdots
+ \delta_{i_n}^{\sigma(j_n)}\,.
+ \end{equation}
+ Return [None] if the two index sets are not permutations
+ of one another and [Some (sign, i)] if they are. *)
+
+let open_contract open_epsilon epsilon_bar =
+ match not_in epsilon_bar open_epsilon with
+ | [] -> None
+ | [i] ->
+ let sign = relative_permutation (i :: open_epsilon) epsilon_bar in
+ if sign = 0 then
+ None
+ else
+ Some (sign, i)
+ | _ -> None
+
+(* [connect n (sign, flow_n, lines) arrow] tries to form a new connection in the
+ map [lines] using a single [arrow]. The outgoing line in the fusion
+ is represented by [flow_n] and corresponds to [n] in the [arrow]. *)
+
+(* If the arrow is a ghost and is connected to the outgoing line,
+ just add it. If it is connected to an incoming line, remove
+ this propagator, as it is saturated. *)
+
+let connect_ghost_opt n g (sign, flow_n, lines) =
+ let g' = A.position_ghost g in
+ if g' = n then
+ Some (sign, CP.Ghost, lines)
+ else
+ match PArray.get_opt g' lines with
+ | Some CP.Ghost -> Some (sign, flow_n, clear g' lines)
+ | Some CP.Ghost_with_Epsilons _ ->
+ failwith "connect_ghost_opt: incomplete"
+ | Some CP.Ghost_with_Epsilon_Bars _ ->
+ failwith "connect_ghost_opt: incomplete"
+ | _ -> None
+
+(* Add the normalized propagator [p] to the map [lines] at position
+ [i], unless it contains no color flows. Remove it in this case. *)
+
+let add_or_remove_if_white i p lines =
+ let p = CP.normalize p in
+ if CP.is_white p then
+ PArray.remove i lines
+ else
+ PArray.add i p lines
+
+(* If the arrow is a connection and is connected on one side
+ to the outgoing line, find the matching incoming line.
+ If it is connected to two incoming lines, merge them,
+ which amounts to throwing them away. *)
+
+(* \begin{dubious}
+ Here's where the $\epsilon$-$\bar\epsilon$ pairs will be consumed.
+ We should move this to a preprocessing step, so that the
+ repeated application of arrows does not have to take care of it.
+ Or do it in a postprocessing step, which has the advantage that
+ the contractions have been processed and a possible new $\epsilon$
+ or $\bar\epsilon$ is available.
+ \end{dubious} *)
+
+(* Try to extract
+ an $\epsilon$ (or $\bar\epsilon$) from the color flow
+ given as the argument. *)
+
+let take_epsilon cfi =
+ let project_opt _ = function
+ | CP.CF_in cf -> Some cf
+ | CP.Epsilon _ -> None in
+ PArray.take_one project_opt cfi
+
+let take_epsilon_bar cfo =
+ let project_opt _ = function
+ | CP.CF_out cf -> Some cf
+ | CP.Epsilon_Bar _ -> None in
+ PArray.take_one project_opt cfo
+
+(* This is a part of [connect_in_opt] below that requires recursion and
+ therefore needs to be its own function. *)
+
+(* Keeping track of the overall [sign], connect the
+ incoming [CP.Flow_with_Epsilons] at index [i'] at position
+ [i] in [lines] with
+ the outgoing [CP.Flow_with_Epsilon_Bars] at index [n'].
+ Return the updated propagator and [lines] if the color flows
+ match. *)
+
+let rec connect_in_contract_epsilons_opt sign :
+ int -> CP.flow_eps_bar -> CP.eps_bar list ->
+ int -> CP.flow_eps -> CP.eps list ->
+ int -> CP.t PArray.t -> (int * CP.t * CP.t PArray.t) option =
+ fun n' (cfi_n, cfo_n as cf_n) epsilon_bars_n
+ i' (cfi_i, cfo_i as cf_i) epsilons_i i lines ->
+ let open PArray in
+ match epsilon_bars_n, epsilons_i with
+ | epsilon_bar :: epsilon_bars_n, epsilon :: epsilons_i ->
+ let relative_sign = relative_permutation epsilon epsilon_bar in
+ if relative_sign = 0 then
+ None
+ else
+ connect_in_contract_epsilons_opt (relative_sign * sign)
+ n' cf_n epsilon_bars_n i' cf_i epsilons_i i lines
+ | epsilon_bar :: _, [] ->
+ begin match take_epsilon cfi_i with
+ | Nothing cfi ->
+ let flow_n = CP.Flow_with_Epsilon_Bars (cf_n, epsilon_bars_n)
+ and pi = CP.Flow (cfi, cfo_i) in
+ Some (sign, flow_n, add_or_remove_if_white i pi lines)
+ | Single (_, _, cfi_i) ->
+ failwith "Color_Fusion.connect_in_contract_epsilons_opt: incomplete"
+ | Multiple (_, _, cfi_i) ->
+ failwith "Color_Fusion.connect_in_contract_epsilons_opt: incomplete"
+ end
+ | [], epsilon :: _ ->
+ begin match take_epsilon_bar cfo_n with
+ | Nothing cfo ->
+ let flow_n = CP.Flow (cfi_n, cfo)
+ and pi = CP.Flow_with_Epsilons (cf_i, epsilons_i) in
+ Some (sign, flow_n, add_or_remove_if_white i pi lines)
+ | Single (_, _, cfo_n) ->
+ failwith "Color_Fusion.connect_in_contract_epsilons_opt: incomplete"
+ | Multiple (_, _, cfo_n) ->
+ failwith "Color_Fusion.connect_in_contract_epsilons_opt: incomplete"
+ end
+ | [], [] ->
+ begin match take_epsilon_bar cfo_n, take_epsilon cfi_i with
+ | Nothing cfo, Nothing cfi ->
+ let flow_n = CP.Flow (cfi_n, cfo)
+ and pi = CP.Flow (cfi, cfo_i) in
+ Some (sign, flow_n, add_or_remove_if_white i pi lines)
+ | _ ->
+ failwith "Color_Fusion.connect_in_contract_epsilons_opt: incomplete"
+ end
+
+let connect_in_opt n' (i, i') (sign, flow_n, lines) =
+ let open PArray in
+ match get_opt i lines with
+ | None -> None
+ | Some flow_i ->
+ begin match flow_i with
+ | CP.Ghost | CP.Ghost_with_Epsilons _ | CP.Ghost_with_Epsilon_Bars _ -> None
+ | CP.Flow (cfi_i, cfo_i) ->
+ begin match get_opt i' cfi_i with
+ | None -> None
+ | Some cfi ->
+ begin match flow_n with
+ | CP.Ghost -> None
+ | CP.Ghost_with_Epsilons _ ->
+ failwith "connect_in_opt: incomplete"
+ | CP.Ghost_with_Epsilon_Bars _ ->
+ failwith "connect_in_opt: incomplete"
+ | CP.Flow (cfi_n, cfo_n) ->
+ let flow_n = CP.Flow (add n' cfi cfi_n, cfo_n)
+ and pi = CP.Flow (remove i' cfi_i, cfo_i) in
+ Some (sign, flow_n, add_or_remove_if_white i pi lines)
+ | CP.Flow_with_Epsilons ((cfi_n, cfo_n), epsilons_n) ->
+ let cfi = CP.CF_in cfi in
+ let flow_n = CP.Flow_with_Epsilons ((add n' cfi cfi_n, cfo_n), epsilons_n)
+ and pi = CP.Flow (remove i' cfi_i, cfo_i) in
+ Some (sign, flow_n, add_or_remove_if_white i pi lines)
+ | CP.Flow_with_Epsilon_Bars ((cfi_n, cfo_n), epsilon_bars_n) ->
+ let flow_n = CP.Flow_with_Epsilon_Bars ((add n' cfi cfi_n, cfo_n), epsilon_bars_n)
+ and pi = CP.Flow (remove i' cfi_i, cfo_i) in
+ Some (sign, flow_n, add_or_remove_if_white i pi lines)
+ end
+ end
+ | CP.Flow_with_Epsilons ((cfi_i, cfo_i), epsilons_i) ->
+ begin match get_opt i' cfi_i with
+ | None -> None
+ | Some cfi ->
+ begin match flow_n with
+ | CP.Ghost -> None
+ | CP.Ghost_with_Epsilons _ ->
+ failwith "connect_in_opt: incomplete"
+ | CP.Ghost_with_Epsilon_Bars _ ->
+ failwith "connect_in_opt: incomplete"
+ | CP.Flow (cfi_n, cfo_n) ->
+ let cfi_n = map (fun cf -> CP.CF_in cf) cfi_n in
+ let flow_n = CP.Flow_with_Epsilons ((add n' cfi cfi_n, cfo_n), epsilons_i)
+ and pi = CP.Flow_with_Epsilons ((remove i' cfi_i, cfo_i), []) in
+ Some (sign, flow_n, add_or_remove_if_white i pi lines)
+ | CP.Flow_with_Epsilons ((cfi_n, cfo_n), epsilons_n) ->
+ let flow_n = CP.Flow_with_Epsilons ((add n' cfi cfi_n, cfo_n), epsilons_i @ epsilons_n)
+ and pi = CP.Flow_with_Epsilons ((remove i' cfi_i, cfo_i), []) in
+ Some (sign, flow_n, add_or_remove_if_white i pi lines)
+ | CP.Flow_with_Epsilon_Bars ((cfi_n, cfo_n), epsilon_bars_n) ->
+ connect_in_contract_epsilons_opt sign
+ n' (cfi_n, cfo_n) epsilon_bars_n
+ i' (cfi_i, cfo_i) epsilons_i
+ i lines
+ end
+ end
+ | CP.Flow_with_Epsilon_Bars ((cfi_i, cfo_i), epsilon_bars_i) ->
+ begin match get_opt i' cfi_i with
+ | None -> None
+ | Some cfi ->
+ begin match flow_n with
+ | CP.Ghost -> None
+ | CP.Ghost_with_Epsilons _ ->
+ failwith "connect_in_opt: incomplete"
+ | CP.Ghost_with_Epsilon_Bars _ ->
+ failwith "connect_in_opt: incomplete"
+ | CP.Flow (cfi_n, cfo_n) ->
+ let cfo_n = map (fun cf -> CP.CF_out cf) cfo_n in
+ let flow_n = CP.Flow_with_Epsilon_Bars ((add n' cfi cfi_n, cfo_n), epsilon_bars_i)
+ and pi = CP.Flow_with_Epsilon_Bars ((remove i' cfi_i, cfo_i), []) in
+ Some (sign, flow_n, add_or_remove_if_white i pi lines)
+ | CP.Flow_with_Epsilon_Bars ((cfi_n, cfo_n), epsilon_bars_n) ->
+ let flow_n = CP.Flow_with_Epsilon_Bars ((add n' cfi cfi_n, cfo_n), epsilon_bars_i @ epsilon_bars_n)
+ and pi = CP.Flow_with_Epsilon_Bars ((remove i' cfi_i, cfo_i), []) in
+ Some (sign, flow_n, add_or_remove_if_white i pi lines)
+
+ | CP.Flow_with_Epsilons ((cfi_n, cfo_n), epsilons_n) ->
+ failwith "Color_Fusion.connect_in_opt: no epsilon contractions yet"
+ end
+ end
+ end
+
+let connect_out_opt n' (o, o') (sign, flow_n, lines) =
+ let open PArray in
+ match get_opt o lines with
+ | None -> None
+ | Some flow ->
+ begin match flow with
+ | CP.Ghost | CP.Ghost_with_Epsilons _ | CP.Ghost_with_Epsilon_Bars _ -> None
+ | CP.Flow (cfi_o, cfo_o) ->
+ begin match get_opt o' cfo_o with
+ | None -> None
+ | Some cfo ->
+ begin match flow_n with
+ | CP.Ghost -> None
+ | CP.Ghost_with_Epsilons _ ->
+ failwith "connect_out_opt: incomplete"
+ | CP.Ghost_with_Epsilon_Bars _ ->
+ failwith "connect_out_opt: incomplete"
+ | CP.Flow (cfi_n, cfo_n) ->
+ let flow_n = CP.Flow (cfi_n, add n' cfo cfo_n)
+ and po = CP.Flow (cfi_o, remove o' cfo_o) in
+ Some (sign, flow_n, add_or_remove_if_white o po lines)
+ | CP.Flow_with_Epsilons ((cfi_n, cfo_n), epsilons_n) ->
+ let flow_n = CP.Flow_with_Epsilons ((cfi_n, add n' cfo cfo_n), epsilons_n)
+ and po = CP.Flow (cfi_o, remove o' cfo_o) in
+ Some (sign, flow_n, add_or_remove_if_white o po lines)
+ | CP.Flow_with_Epsilon_Bars ((cfi_n, cfo_n), epsilon_bars_n) ->
+ let cfo = CP.CF_out cfo in
+ let flow_n = CP.Flow_with_Epsilon_Bars ((cfi_n, add n' cfo cfo_n), epsilon_bars_n)
+ and po = CP.Flow (cfi_o, remove o' cfo_o) in
+ Some (sign, flow_n, add_or_remove_if_white o po lines)
+ end
+ end
+ | CP.Flow_with_Epsilons ((cfi_o, cfo_o), epsilons_o) ->
+ begin match get_opt o' cfo_o with
+ | None -> None
+ | Some cfo ->
+ begin match flow_n with
+ | CP.Ghost -> None
+ | CP.Ghost_with_Epsilons _ ->
+ failwith "connect_out_opt: incomplete"
+ | CP.Ghost_with_Epsilon_Bars _ ->
+ failwith "connect_out_opt: incomplete"
+ | CP.Flow (cfi_n, cfo_n) ->
+ let cfi_n = map (fun cf -> CP.CF_in cf) cfi_n in
+ let flow_n = CP.Flow_with_Epsilons ((cfi_n, add n' cfo cfo_n), epsilons_o)
+ and po = CP.Flow_with_Epsilons ((cfi_o, remove o' cfo_o), []) in
+ Some (sign, flow_n, add_or_remove_if_white o po lines)
+ | CP.Flow_with_Epsilons ((cfi_n, cfo_n), epsilons_n) ->
+ let flow_n = CP.Flow_with_Epsilons ((cfi_n, add n' cfo cfo_n), epsilons_o @ epsilons_n)
+ and po = CP.Flow_with_Epsilons ((cfi_o, remove o' cfo_o), []) in
+ Some (sign, flow_n, add_or_remove_if_white o po lines)
+ | CP.Flow_with_Epsilon_Bars ((cfi_n, cfo_n), epsilon_bars_n) ->
+ failwith "Color_Fusion.connect_out_opt: no epsilon contractions yet"
+ end
+ end
+ | CP.Flow_with_Epsilon_Bars ((cfi_o, cfo_o), epsilon_bars_o) ->
+ begin match get_opt o' cfo_o with
+ | None -> None
+ | Some cfo ->
+ begin match flow_n with
+ | CP.Ghost -> None
+ | CP.Ghost_with_Epsilons _ ->
+ failwith "connect_out_opt: incomplete"
+ | CP.Ghost_with_Epsilon_Bars _ ->
+ failwith "connect_out_opt: incomplete"
+ | CP.Flow (cfi_n, cfo_n) ->
+ let cfo_n = map (fun cf -> CP.CF_out cf) cfo_n in
+ let flow_n = CP.Flow_with_Epsilon_Bars ((cfi_n, add n' cfo cfo_n), epsilon_bars_o)
+ and po = CP.Flow_with_Epsilon_Bars ((cfi_o, remove o' cfo_o), []) in
+ Some (sign, flow_n, add_or_remove_if_white o po lines)
+ | CP.Flow_with_Epsilon_Bars ((cfi_n, cfo_n), epsilon_bars_n) ->
+ let flow_n = CP.Flow_with_Epsilon_Bars ((cfi_n, add n' cfo cfo_n), epsilon_bars_o @ epsilon_bars_n)
+ and po = CP.Flow_with_Epsilon_Bars ((cfi_o, remove o' cfo_o), []) in
+ Some (sign, flow_n, add_or_remove_if_white o po lines)
+
+ | CP.Flow_with_Epsilons ((cfi_n, cfo_n), epsilons_n) ->
+ failwith "Color_Fusion.connect_out_opt: no epsilon contractions yet"
+ end
+ end
+ end
+
+let connect_in_out_opt (i, i') (o, o') (sign, flow_n, lines) =
+ let open PArray in
+ match get_opt i lines, get_opt o lines with
+ | None, _ | _, None -> None
+ | Some flow_i, Some flow_o ->
+ begin match flow_i, flow_o with
+ | (CP.Ghost | CP.Ghost_with_Epsilons _ | CP.Ghost_with_Epsilon_Bars _), _
+ | _, (CP.Ghost | CP.Ghost_with_Epsilons _ | CP.Ghost_with_Epsilon_Bars _) -> None
+ | CP.Flow (cfi_i, cfo_i), CP.Flow (cfi_o, cfo_o) ->
+ begin match get_opt i' cfi_i, get_opt o' cfo_o with
+ | Some cfi, Some cfo when cfi = cfo ->
+ let pi = CP.Flow (remove i' cfi_i, cfo_i)
+ and po = CP.Flow (cfi_o, remove o' cfo_o) in
+ Some (sign, flow_n, add_or_remove_if_white i pi (add_or_remove_if_white o po lines))
+ | _, _ -> None
+ end
+ | CP.Flow (cfi_i, cfo_i), CP.Flow_with_Epsilons ((cfi_o, cfo_o), epsilons_o) ->
+ begin match get_opt i' cfi_i, get_opt o' cfo_o with
+ | Some cfi, Some cfo when cfi = cfo ->
+ let pi = CP.Flow (remove i' cfi_i, cfo_i)
+ and po = CP.Flow_with_Epsilons ((cfi_o, remove o' cfo_o), epsilons_o) in
+ Some (sign, flow_n, add_or_remove_if_white i pi (add_or_remove_if_white o po lines))
+ | _, _ -> None
+ end
+ | CP.Flow_with_Epsilons ((_, _), _), CP.Flow_with_Epsilons ((_, _), _) ->
+ failwith "Color_Fusion.connect_in_out_opt: incomplete"
+ | CP.Flow_with_Epsilon_Bars ((cfi_i, cfo_i), epsilon_bars_i), CP.Flow (cfi_o, cfo_o) ->
+ begin match get_opt i' cfi_i, get_opt o' cfo_o with
+ | Some cfi, Some cfo when cfi = cfo ->
+ let pi = CP.Flow_with_Epsilon_Bars ((remove i' cfi_i, cfo_i), epsilon_bars_i)
+ and po = CP.Flow ((cfi_o, remove o' cfo_o)) in
+ Some (sign, flow_n, add_or_remove_if_white i pi (add_or_remove_if_white o po lines))
+ | _, _ -> None
+ end
+ | CP.Flow_with_Epsilon_Bars ((_, _), _), CP.Flow_with_Epsilon_Bars ((_, _), _) ->
+ failwith "Color_Fusion.connect_in_out_opt: incomplete"
+ | CP.Flow_with_Epsilons ((cfi_i, cfo_i), epsilons_i), CP.Flow (cfi_o, cfo_o) ->
+ begin match get_opt i' cfi_i, get_opt o' cfo_o with
+ | Some (CP.CF_in cfi), Some cfo when cfi = cfo ->
+ let pi = CP.Flow_with_Epsilons ((remove i' cfi_i, cfo_i), epsilons_i)
+ and po = CP.Flow (cfi_o, remove o' cfo_o) in
+ Some (sign, flow_n, add_or_remove_if_white i pi (add_or_remove_if_white o po lines))
+ | Some (CP.Epsilon epsilon_i), Some cfo ->
+ let epsilon_n = cfo :: epsilon_i in
+ let flow_n =
+ match flow_n with
+ | CP.Ghost -> CP.Ghost
+ | CP.Ghost_with_Epsilons _ ->
+ failwith "connect_in_out_opt: incomplete"
+ | CP.Ghost_with_Epsilon_Bars _ ->
+ failwith "connect_in_out_opt: incomplete"
+ | CP.Flow (cfo, cfi) ->
+ let cfi = map (fun cf -> CP.CF_in cf) cfi in
+ CP.Flow_with_Epsilons ((cfi, cfo), [epsilon_n])
+ | CP.Flow_with_Epsilons (flow, epsilons_n) ->
+ CP.Flow_with_Epsilons (flow, epsilon_n :: epsilons_n)
+ | CP.Flow_with_Epsilon_Bars (flow, epsilon_bars_n) ->
+ failwith "Color_Fusion.connect_in_out_opt: no epsilon contractions yet" in
+ let pi = CP.Flow_with_Epsilons ((remove i' cfi_i, cfo_i), epsilons_i)
+ and po = CP.Flow (cfi_o, remove o' cfo_o) in
+ Some (sign, flow_n, add_or_remove_if_white i pi (add_or_remove_if_white o po lines))
+ | _, _ -> None
+ end
+ | CP.Flow (cfi_i, cfo_i), CP.Flow_with_Epsilon_Bars ((cfi_o, cfo_o), epsilon_bars_o) ->
+ begin match get_opt i' cfi_i, get_opt o' cfo_o with
+ | Some cfi, Some (CP.CF_out cfo) when cfi = cfo ->
+ let pi = CP.Flow (remove i' cfi_i, cfo_i)
+ and po = CP.Flow_with_Epsilon_Bars ((cfi_o, remove o' cfo_o), epsilon_bars_o) in
+ Some (sign, flow_n, add_or_remove_if_white i pi (add_or_remove_if_white o po lines))
+ | Some cfi, Some (CP.Epsilon_Bar epsilon_bar_o) ->
+ let epsilon_bar_n = cfi :: epsilon_bar_o in
+ let flow_n =
+ match flow_n with
+ | CP.Ghost -> CP.Ghost
+ | CP.Ghost_with_Epsilons _ ->
+ failwith "connect_in_out_opt: incomplete"
+ | CP.Ghost_with_Epsilon_Bars _ ->
+ failwith "connect_in_out_opt: incomplete"
+ | CP.Flow (cfo, cfi) ->
+ let cfo = map (fun cf -> CP.CF_out cf) cfo in
+ CP.Flow_with_Epsilon_Bars ((cfi, cfo), [epsilon_bar_n])
+ | CP.Flow_with_Epsilon_Bars (flow, epsilon_bars_n) ->
+ CP.Flow_with_Epsilon_Bars (flow, epsilon_bar_n :: epsilon_bars_n)
+ | CP.Flow_with_Epsilons (flow, epsilons_n) ->
+ failwith "Color_Fusion.connect_in_out_opt: no epsilon contractions yet" in
+ let pi = CP.Flow (remove i' cfi_i, cfo_i)
+ and po = CP.Flow_with_Epsilon_Bars ((cfi_o, remove o' cfo_o), epsilon_bars_o) in
+ Some (sign, flow_n, add_or_remove_if_white i pi (add_or_remove_if_white o po lines))
+ | _, _ -> None
+ end
+ | CP.Flow_with_Epsilons ((_, _), _), CP.Flow_with_Epsilon_Bars ((_, _), _) ->
+ failwith "Color_Fusion.connect_in_out_opt: no epsilon contractions yet"
+ | CP.Flow_with_Epsilon_Bars ((_, _), _), CP.Flow_with_Epsilons ((_, _), _) ->
+ failwith "Color_Fusion.connect_in_out_opt: no epsilon contractions yet"
+ end
+
+(* \thocwmodulesection{Putting Everything Together} *)
+let decode_endpoint = function
+ | A.I n -> (n, 0)
+ | A.M (n, m) -> (n, m)
+
+let decode_tail t = decode_endpoint (t : A.tail :> A.endpoint)
+let decode_tip t = decode_endpoint (t : A.tip :> A.endpoint)
+let decode_ghost g = decode_endpoint (g : A.ghost :> A.endpoint)
+
+let endpoint_to_string = function
+ | A.I n -> string_of_int n
+ | A.M (n, m) -> string_of_int n ^ "." ^ string_of_int m
+
+let tail_to_string t = endpoint_to_string (t : A.tail :> A.endpoint)
+let tip_to_string t = endpoint_to_string (t : A.tip :> A.endpoint)
+let ghost_to_string g = endpoint_to_string (g : A.ghost :> A.endpoint)
+
+let connect_arrow_opt n i o lines =
+ let i, i' as ii' = decode_tail i
+ and o, o' as oo' = decode_tip o in
+ if o = n then
+ connect_in_opt o' ii' lines
+ else if i = n then
+ connect_out_opt i' oo' lines
+ else
+ connect_in_out_opt ii' oo' lines
+
+let lines_to_string (sign, flow_n, lines) =
+ Printf.sprintf
+ "%d*%s<%s"
+ sign (CP.to_string flow_n)
+ (ThoList.to_string
+ (fun (i, p) -> Printf.sprintf "%s@%d" (CP.to_string p) i)
+ (PArray.to_pairs lines))
+
+let connect_arrow_opt_logging n i o lines =
+ let result = connect_arrow_opt n i o lines in
+ Printf.eprintf
+ " (%s,%s) %s >>> %s\n"
+ (tail_to_string i) (tip_to_string o)
+ (lines_to_string lines)
+ (match result with
+ | None -> "None"
+ | Some lines -> lines_to_string lines);
+ result
+
+(*i
+let connect_arrow_opt = connect_arrow_opt_logging
+i*)
+
+(* Performan a single connection of the [lines] as described by
+ [arrow_or_ghost]. Use [n] as the index of the outgoing line.
+ Return the updated outgoing and incoming lines. *)
+
+let connect_arrow_or_ghost_opt :
+ int -> A.free -> int * CP.t * CP.t PArray.t -> (int * CP.t * CP.t PArray.t) option =
+ fun n arrow_or_ghost lines ->
+ match arrow_or_ghost with
+ | A.Ghost g -> connect_ghost_opt n g lines
+ | A.Arrow (i, o) -> connect_arrow_opt n i o lines
+
+(* Return the signed color [flow] iff all color flows in [lines]
+ have been consumed. *)
+let all_lines_consumed_opt (sign, flow, lines) =
+ if PArray.is_empty lines then
+ Some (sign, flow)
+ else
+ None
+
+(* Try to use the ghosts and arrows in [connections] to combine the
+ color flows in [lines]. *)
+let connect_arrows_opt : A.free list -> CP.t list -> (int * CP.t) option =
+ fun connections lines ->
+ let n = List.length lines + 1 in
+ let rec connect' acc = function
+ | arrow :: arrows ->
+ begin match connect_arrow_or_ghost_opt n arrow acc with
+ | None -> None
+ | Some acc -> connect' acc arrows
+ end
+ | [] -> Some acc in
+ match connect' (1, CP.white, line_map lines) connections with
+ | Some acc -> all_lines_consumed_opt acc
+ | None -> None
+
+let extract_lines_opt endpoints lines =
+ let rec extract_lines' acc lines = function
+ | [] -> Some (List.rev acc, lines)
+ | A.I i :: rest ->
+ begin match PArray.get_opt i lines with
+ | None -> None
+ | Some (CP.Flow (_, cfo)) ->
+ begin match PArray.to_option_list cfo with
+ | [Some cf] ->
+ extract_lines' (cf :: acc) (PArray.remove i lines) rest
+ | _ -> failwith "extract_lines_opt: incomplete"
+ end
+ | Some (CP.Flow_with_Epsilons ((_, _), _)) ->
+ failwith "extract_lines_opt: incomplete"
+ | Some (CP.Flow_with_Epsilon_Bars ((_, _), _)) ->
+ failwith "extract_lines_opt: incomplete"
+ | Some CP.Ghost ->
+ failwith "extract_lines_opt: incomplete"
+ | Some (CP.Ghost_with_Epsilons _)->
+ failwith "extract_lines_opt: incomplete"
+ | Some (CP.Ghost_with_Epsilon_Bars _) ->
+ failwith "extract_lines_opt: incomplete"
+ end
+ | A.M (_, _) :: _ -> failwith "extract_lines_opt: incomplete" in
+ extract_lines' [] endpoints lines
+
+(*i
+ let connect_epsilon_saturated_opt n epsilon (flow_n, lines) =
+ match extract_lines_opt epsilon lines with
+ | None -> None
+ | Some (flow_n, lines) -> Some (CP.Epsilon flow_n, lines)
+
+ let connect_epsilon_opt n epsilon (flow_n, lines) =
+ match extract_lines_opt epsilon lines with
+ | None -> None
+ | Some (flow_n, lines) -> Some (CP.Epsilon flow_n, lines)
+i*)
+
+let fuse1 n_c lines arrow =
+ let open Birdtracks in
+ match arrow with
+ | Arrows { coeff; arrows } ->
+ begin match connect_arrows_opt arrows lines with
+ | None -> []
+ | Some (sign, flow) ->
+ [(QC.mul (QC.int sign) (L.eval (QC.int n_c) coeff), flow)]
+ end
+ | Epsilons _ -> failwith "Birdtracks.fuse1: Epsilons"
+ | Epsilon_Bars _ -> failwith "Birdtracks.fuse1: Epsilon_Bars"
+
+let fuse n_c vertex lines =
+ match vertex with
+ | [] ->
+ if List.for_all CP.is_white lines then
+ [(QC.unit, CP.white)]
+ else
+ []
+ | vertex ->
+ ThoList.flatmap (fuse1 n_c lines) vertex
+
+let flow_to_string flow =
+ ThoList.to_string
+ (fun (c, p) ->
+ let p = CP.to_string p in
+ if QC.is_unit c then
+ p
+ else
+ Printf.sprintf "%s*%s" (QC.to_string c) p)
+ flow
+
+let fuse_logging n_c vertex lines =
+ let flow_n = fuse n_c vertex lines in
+ Printf.eprintf
+ "%s >>> %s\n"
+ (ThoList.to_string CP.to_string lines)
+ (flow_to_string flow_n);
+ flow_n
+
+(*i
+let fuse = fuse_logging
+i*)
+
+(* \thocwmodulesection{Unit Tests} *)
+
+module Test =
+ struct
+ open OUnit
+
+ let vertices_equal v1 v2 =
+ (Birdtracks.canonicalize v1) = (Birdtracks.canonicalize v2)
+
+ let eq v1 v2 =
+ assert_equal ~printer:Birdtracks.to_string_raw ~cmp:vertices_equal v1 v2
+
+ let suite_open_contract =
+ "open_contract" >:::
+
+ [ "[2;3] [1;2;4]" >::
+ (fun () -> assert_equal None (open_contract [2;3] [1;2;4]));
+
+ "[2;3] [1;2;3;4]" >::
+ (fun () -> assert_equal None (open_contract [2;3] [1;2;3;4]));
+
+ "[2;3] [1;2;3]" >::
+ (fun () -> assert_equal (Some ( 1,1)) (open_contract [2;3] [1;2;3]));
+
+ "[1;3] [1;2;3]" >::
+ (fun () -> assert_equal (Some (-1, 2)) (open_contract [1;3] [1;2;3])) ]
+
+ let signed_flow_option_to_string = function
+ | Some (sign, flow) ->
+ let flow = CP.to_string flow in
+ if sign = 1 then
+ flow
+ else
+ Printf.sprintf "%d*%s" sign flow
+ | None -> "None"
+
+ let test_connect_arrows_msg vertex formatter (expected, result) =
+ Format.fprintf
+ formatter
+ "[%s]: expected %s, got %s"
+ (ThoList.to_string A.free_to_string vertex)
+ (signed_flow_option_to_string expected)
+ (signed_flow_option_to_string result)
+
+ let test_connect_arrows expected lines vertex =
+ assert_equal ~printer:signed_flow_option_to_string
+ expected (connect_arrows_opt vertex lines)
+
+ let test_connect_arrows_permutations expected lines vertex =
+ List.iter
+ (fun v ->
+ assert_equal ~pp_diff:(test_connect_arrows_msg v)
+ expected (connect_arrows_opt v lines))
+ (Combinatorics.permute vertex)
+
+ let suite_connect_arrows =
+ "connect_arrows" >:::
+
+ [ "delta" >::
+ (fun () ->
+ test_connect_arrows_permutations
+ (Some (1, CP.of_lists [1] []))
+ [ CP.of_lists [1] []; CP.white]
+ ( 1 ==> 3 ));
+
+ "f: 1->3->2->1" >::
+ (fun () ->
+ test_connect_arrows_permutations
+ (Some (1, CP.of_lists [1] [3]))
+ [CP.of_lists [1] [2]; CP.of_lists [2] [3]]
+ (A.cycle [1; 3; 2]));
+
+ "f: 1->2->3->1" >::
+ (fun () ->
+ test_connect_arrows_permutations
+ (Some (1, CP.of_lists [1] [2]))
+ [CP.of_lists [3] [2]; CP.of_lists [1] [3]]
+ (A.cycle [1; 2; 3])) ]
+
+ let test_fuse_msg vertex lines formatter (expected, result) =
+ Format.fprintf
+ formatter
+ "%s // %s => %s failed, got %s instead"
+ (Birdtracks.to_string vertex)
+ (ThoList.to_string CP.to_string lines)
+ (flow_to_string expected)
+ (flow_to_string result)
+
+ let compare_fusion (c1, p1) (c2, p2) =
+ let c = Algebra.QC.compare c1 c2 in
+ if c <> 0 then
+ c
+ else
+ CP.compare p1 p2
+
+ let equal_fusion f1 f2 =
+ compare_fusion f1 f2 = 0
+
+ let cmp_fusions f1 f2 =
+ let f1 = List.sort compare_fusion f1
+ and f2 = List.sort compare_fusion f2 in
+ try
+ List.for_all2 equal_fusion f1 f2
+ with
+ | Invalid_argument _ -> false
+
+ let test_fuse expected vertex lines =
+ let nc = 3 in
+ assert_equal
+ ~cmp:cmp_fusions
+ ~pp_diff:(test_fuse_msg vertex lines)
+ expected (fuse nc vertex lines)
+
+ (* This way, we can write [vertex // lines => expected] in the
+ tests. *)
+ let (//) vertex lines = (vertex, lines)
+ let (=>) (vertex, lines) expected = test_fuse expected vertex lines
+
+ (* Abbreviations *)
+ let tf = test_fuse
+ let e = QC.unit
+ let half = QC.fraction 2
+ let w = CP.white
+
+ (* Quarks and anti quarks: *)
+ let q i = CP.of_lists [i] []
+ let aq i = CP.of_lists [] [i]
+
+ (* Diquarks and anti diquarks: *)
+ let dq i j = CP.of_lists [i; j] []
+ let adq i j = CP.of_lists [] [i; j]
+
+ (* Gluons without ghosts *)
+ let g i j = CP.of_lists [i] [j]
+
+ (* Couplings *)
+ let d = SU3.delta3
+ let d6 = SU3.delta6
+ let t = SU3.t
+ let t6 = SU3.t6
+ let k6 = SU3.k6
+ let k6b = SU3.k6bar
+
+ let suite_binary_qed3 =
+ "triplet" >:::
+ [ "1 2 " >:: (fun () -> d 2 1 // [q 1; aq 1] => [(e, w)]);
+ "1 2'" >:: (fun () -> d 2 1 // [aq 1; q 1 ] => []);
+ "2 1 " >:: (fun () -> d 1 2 // [aq 1; q 1 ] => [(e, w)]);
+ "2 1'" >:: (fun () -> d 1 2 // [q 1; aq 1] => []);
+ "1 3 " >:: (fun () -> d 3 1 // [q 1; w ] => [(e, q 1)]);
+ "2 3 " >:: (fun () -> d 3 2 // [w; q 1 ] => [(e, q 1)]);
+ "3 1 " >:: (fun () -> d 1 3 // [aq 1; w ] => [(e, aq 1)]);
+ "3 2 " >:: (fun () -> d 2 3 // [w; aq 1] => [(e, aq 1)]) ]
+
+ let suite_binary_qed6 =
+ "sextet" >:::
+ [ "1 2 " >:: (fun () -> d6 2 1 // [dq 1 2; adq 1 2] => [(half, w)]);
+ "1 2' " >:: (fun () -> d6 2 1 // [dq 1 2; adq 2 1] => [(half, w)]);
+ "1 2''" >:: (fun () -> d6 2 1 // [dq 1 2; adq 1 3] => []) ]
+
+ let suite_binary_qcd3 =
+ "triplet" >:::
+ [ "1 2 " >:: (fun () -> t 3 2 1 // [q 1; aq 2] => [(e, g 1 2)]);
+ "1 2'" >:: (fun () -> t 3 2 1 // [aq 1; q 2] => []) ]
+
+ let suite_binary_qcd6 =
+ "sextet" >:::
+ [ "1 2" >:: (fun () -> t6 3 2 1 // [dq 1 2; adq 2 3] => [(half, g 1 3)]) ]
+
+ let suite_binary_k6 =
+ "k6(bar)" >:::
+ [ "321 " >:: (fun () -> k6b 3 2 1 // [q 1; q 2 ] => [(e, dq 2 1); (e, dq 1 2)]);
+ "321* " >:: (fun () -> k6 3 2 1 // [aq 1; aq 2] => [(e, adq 2 1); (e, adq 1 2)]);
+ "123 " >:: (fun () -> k6b 1 2 3 // [adq 1 2; q 1] => [(e, aq 2)]);
+ "132 " >:: (fun () -> k6b 1 3 2 // [adq 1 2; q 1] => [(e, aq 2)]);
+ "123' " >:: (fun () -> k6b 1 2 3 // [adq 1 2; q 2] => [(e, aq 1)]);
+ "132' " >:: (fun () -> k6b 1 3 2 // [adq 1 2; q 2] => [(e, aq 1)]);
+ "213 " >:: (fun () -> k6b 2 1 3 // [q 1; adq 1 2] => [(e, aq 2)]);
+ "231 " >:: (fun () -> k6b 2 3 1 // [q 1; adq 1 2] => [(e, aq 2)]);
+ "213' " >:: (fun () -> k6b 2 1 3 // [q 2; adq 1 2] => [(e, aq 1)]);
+ "231' " >:: (fun () -> k6b 2 3 1 // [q 2; adq 1 2] => [(e, aq 1)]);
+ "123 *" >:: (fun () -> k6 1 2 3 // [dq 1 2; aq 1] => [(e, q 2)]);
+ "132 *" >:: (fun () -> k6 1 3 2 // [dq 1 2; aq 1] => [(e, q 2)]);
+ "123'*" >:: (fun () -> k6 1 2 3 // [dq 1 2; aq 2] => [(e, q 1)]);
+ "132'*" >:: (fun () -> k6 1 3 2 // [dq 1 2; aq 2] => [(e, q 1)]);
+ "213 *" >:: (fun () -> k6 2 1 3 // [aq 1; dq 1 2] => [(e, q 2)]);
+ "231 *" >:: (fun () -> k6 2 3 1 // [aq 1; dq 1 2] => [(e, q 2)]);
+ "213'*" >:: (fun () -> k6 2 1 3 // [aq 2; dq 1 2] => [(e, q 1)]);
+ "231'*" >:: (fun () -> k6 2 3 1 // [aq 2; dq 1 2] => [(e, q 1)]) ]
+
+ let suite_binary =
+ "binary" >:::
+ [ "colorless" >:: (fun () -> [] // [w; w] => [(e, w)]);
+ "qed" >::: [ suite_binary_qed3; suite_binary_qed6; suite_binary_k6 ];
+ "qcd" >::: [ suite_binary_qcd3; suite_binary_qcd6 ] ]
+
+ let suite_tertiary =
+ "tertiary" >:::
+ [ "colorless" >:: (fun () -> [] // [w; w; w] => [(e, w)]);
+ "qed 1 2" >:: (fun () -> d 2 1 // [q 1; aq 1; w] => [(e, w)]);
+ "qed 1 3" >:: (fun () -> d 3 1 // [q 1; w; aq 1] => [(e, w)]);
+ "qed 2 3" >:: (fun () -> d 3 2 // [w; q 1; aq 1] => [(e, w)]) ]
+
+
+ let suite_nary =
+ "n-ary" >:::
+ [ "colorless" >:: (fun () -> [] // [w; w; w; w; w] => [(e, w)]) ]
+
+
+ let suite_fuse =
+ "fuse" >:::
+ [ suite_binary;
+ suite_tertiary;
+ suite_nary ]
+
+ let suite =
+ "Color_Fusion" >:::
+ [suite_open_contract;
+ suite_connect_arrows;
+ suite_fuse]
+
+ let suite_long =
+ "Color_Fusion long" >:::
+ []
+ end
+
Index: trunk/omega/src/omega.mli
===================================================================
--- trunk/omega/src/omega.mli (revision 8899)
+++ trunk/omega/src/omega.mli (revision 8900)
@@ -1,56 +1,57 @@
(* omega.mli --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
module type T =
sig
- val main : unit -> unit
+
+ val main : ?current:int ref -> ?argv:string array -> unit -> unit
(* \begin{dubious}
This used to be only intended for debugging O'Giga,
but might live longer \ldots
\end{dubious} *)
type flavor
val diagrams : flavor -> flavor -> flavor list ->
((flavor * Momentum.Default.t) *
(flavor * Momentum.Default.t,
flavor * Momentum.Default.t) Tree.t) list
end
(* Wrap the two instances of [Fusion.Maker] for
amplitudes and phase space into a single functor to
make sure that the Dirac and Majorana versions match.
Don't export the slightly unsafe
[module Make (FM : Fusion.Maker) (PM : Fusion.Maker)
(TM : Target.Maker) (M : Model.T) : T with type flavor = M.flavor]. *)
module Binary (TM : Target.Maker) (M : Model.T) : T with type flavor = M.flavor
module Binary_Majorana (TM : Target.Maker) (M : Model.T) : T with type flavor = M.flavor
module Mixed23 (TM : Target.Maker) (M : Model.T) : T with type flavor = M.flavor
module Mixed23_Majorana (TM : Target.Maker) (M : Model.T) : T with type flavor = M.flavor
module Mixed23_Majorana_vintage (TM : Target.Maker) (M : Model.T) : T with type flavor = M.flavor
module Nary (TM : Target.Maker) (M : Model.T) : T with type flavor = M.flavor
module Nary_Majorana (TM : Target.Maker) (M : Model.T) : T with type flavor = M.flavor
Index: trunk/omega/src/NList.mli
===================================================================
--- trunk/omega/src/NList.mli (revision 0)
+++ trunk/omega/src/NList.mli (revision 8900)
@@ -0,0 +1,72 @@
+(* NList.mli --
+
+ Copyright (C) 2022-2023 by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+ with contributions from
+ Christian Speckner <cnspeckn@googlemail.com>
+
+ 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. *)
+
+(* \textit{This is inspired by an example posted on github by Izaak Meckler
+ that in turn appears to be based on ideas well known in the Haskell community.} *)
+
+(* These types are just Peano numerals ['n] used as indices
+ for [('n, 'a) t]. [z] encodes 0 and ['a s] the successor. *)
+type z
+type 'a s
+
+(* A [('n, 'a) t] is a list of ['a] of length ['n] with ['n]
+ encoded as a church numeral and must not be too large! *)
+type ('n, 'a) t
+
+(* Constructors. *)
+val empty : (z, 'a) t
+val cons : 'a -> ('n, 'a) t -> ('n s, 'a) t
+
+(* Deconstructors. Note that they cannot be applied to the empty list. *)
+val hd : ('n s, 'a) t -> 'a
+val tl : ('n s, 'a) t -> ('n, 'a) t
+
+(* Turn the a list with typed length into an ordinary list.
+ Note also, that we can not implement the inverse function
+ [of_list : 'a list -> ('n, 'a t)], because in that case the
+ type ['n] depends on the list and is \emph{not} known at
+ compile time. *)
+val to_list : ('n, 'a) t -> 'a list
+
+(* The usual suspects. *)
+val map : ('a -> 'b) -> ('n, 'a) t -> ('n, 'b) t
+val fold_right : ('a -> 'b -> 'b) -> ('n, 'a) t -> 'b -> 'b
+
+(* A version of [append] is complicated, since we need to compute
+ the sum of the lengths in the type system. It can be done by
+ introducing additional wrappers, but the result is difficult to
+ deconstruct and we don't need it for our applications.
+ The usual implementation of [rev] will also not work, because we
+ need again to maintain the sum of the lengths as an invariant.
+ Simple successor relationships are not enough. *)
+
+(* On the other hand, [map2], [fold_right2] etc.{} can be
+ implemented easily. Here, the type shines, because it can
+ avoid the [Invalid_argument] exception. *)
+val map2 : ('a -> 'b -> 'c) -> ('n, 'a) t -> ('n, 'b) t -> ('n, 'c) t
+
+(* The algorithm is not suitable for long lists, but we expect the
+ lists to be very short anyway. *)
+val sort : ('a -> 'a -> int) -> ('n, 'a) t -> ('n, 'a) t
+
Index: trunk/omega/src/omega_Littlest_Eta.ml
===================================================================
--- trunk/omega/src/omega_Littlest_Eta.ml (revision 8899)
+++ trunk/omega/src/omega_Littlest_Eta.ml (revision 8900)
@@ -1,35 +1,26 @@
(* omega_Littlest_Eta.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.Fortran_Majorana)
- (Modellib_BSM.Littlest(Modellib_BSM.BSM_ungauged))
+module O = Omega.Mixed23(Target_Fortran.Make_Majorana)(Modellib_BSM.Littlest(Modellib_BSM.BSM_ungauged))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/omega3.ml
===================================================================
--- trunk/omega/src/omega3.ml (revision 0)
+++ trunk/omega/src/omega3.ml (revision 8900)
@@ -0,0 +1,420 @@
+(* omega3.ml --
+
+ Copyright (C) 1999-2023 by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+
+ 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. *)
+
+(* \begin{dubious}
+ Next generation single executable.
+ \begin{center}
+ $\Omega^3$: only healthy fatty acids included!
+ \end{center}
+ Playground for first class modules.
+ \end{dubious} *)
+
+(* \begin{dubious}
+ The following static models are still missing
+ \begin{itemize}
+ \item model defined in the compilation unit of the executable:
+ \verb+CQED+, \verb+Littlest_Zprime+, \verb+SM_top+, \verb+SYM+.
+ \end{itemize}
+ \end{dubious} *)
+
+let static_models_SM : (string * string * (module Model.T)) list =
+ let open Modellib_SM in
+ let pfx = "from Modellib_SM: " in
+ [ ("QED", "Quantum Electro Dynamics", (module QED));
+ ("QCD", "Quantum Chromo Dynamics", (module QCD));
+ ("SM", "Standard Model (minimal, no CKM)", (module SM(SM_no_anomalous)));
+ ("SM_CKM", pfx^"SM(SM_no_anomalous_ckm)", (module SM(SM_no_anomalous_ckm)));
+ ("SM_Higgs", pfx^"SM(SM_Higgs)", (module SM(SM_Higgs)));
+ ("SM_Higgs_CKM", pfx^"SM(SM_Higgs_CKM)", (module SM(SM_Higgs_CKM)));
+ ("SM_ac", pfx^"SM(SM_anomalous)", (module SM(SM_anomalous)));
+ ("SM_ac_CKM", pfx^"SM(SM_anomalous_ckm)", (module SM(SM_anomalous_ckm)));
+ ("SM_top_anom", pfx^"SM(SM_anomalous_top)", (module SM(SM_anomalous_top)));
+ ("SM_dim6", pfx^"SM(SM_dim6)", (module SM(SM_dim6)));
+ ("SM_tt_threshold", pfx^"SM(SM_tt_threshold)", (module SM(SM_tt_threshold)));
+ ("SM_ul", pfx^"SM(SM_k_matrix)", (module SM(SM_k_matrix)));
+ ("SM_rx", pfx^"SM(SM_k_matrix) = SM_ul with fewer parameters in Whizard", (module SM(SM_k_matrix)));
+ ("SM_Rxi", pfx^"SM_Rxi", (module SM_Rxi));
+ ("SM_clones", pfx^"SM_clones", (module SM_clones));
+ ("Phi3", "phi^3 toy model", (module Phi3));
+ ("Phi4", "phi^3 + phi^4 toy model", (module Phi4)) ]
+
+let static_models_BSM : (string * string * (module Model.T)) list =
+ let open Modellib_BSM in
+ let pfx = "from Modellib_BSM: " in
+ [ ("THDM", pfx^"TwoHiggsDoublet(THDM)", (module TwoHiggsDoublet(THDM)));
+ ("THDM_CKM", pfx^"TwoHiggsDoublet(THDM_CKM)", (module TwoHiggsDoublet(THDM_CKM)));
+ ("GravTest", pfx^"GravTest(BSM_bsm)", (module GravTest(BSM_bsm)));
+ ("HSExt", pfx^"HSExt(BSM_bsm)", (module HSExt(BSM_bsm)));
+ ("Littlest", pfx^"Littlest(BSM_bsm)", (module Littlest(BSM_bsm)));
+ ("Littlest_Eta", pfx^"Littlest(BSM_ungauged)", (module Littlest(BSM_ungauged)));
+ ("Littlest_Tpar", pfx^"(Littlest_Tpar(BSM_bsm))", (module (Littlest_Tpar(BSM_bsm))));
+ ("Simplest", pfx^"Simplest(BSM_bsm)", (module Simplest(BSM_bsm)));
+ ("Simplest_univ", pfx^"Simplest(BSM_anom)", (module Simplest(BSM_anom)));
+ ("SSC", pfx^"SSC(SSC_kmatrix)", (module SSC(SSC_kmatrix)));
+ ("SSC_2", pfx^"SSC(SSC_kmatrix_2)", (module SSC(SSC_kmatrix_2)));
+ ("SSC_AltT", pfx^"SSC_AltT(SSC_kmatrix_2)", (module SSC_AltT(SSC_kmatrix_2)));
+ ("Template", pfx^"Template(BSM_bsm)", (module Template(BSM_bsm)));
+ ("Threeshl", pfx^"Threeshl(Threeshl_no_ckm)", (module Threeshl(Threeshl_no_ckm)));
+ ("Threeshl_nohf", pfx^"Threeshl(Threeshl_no_ckm_no_hf)", (module Threeshl(Threeshl_no_ckm_no_hf)));
+ ("UED", pfx^"UED(BSM_bsm)", (module UED(BSM_bsm)));
+ ("Xdim", pfx^"Xdim(BSM_bsm)", (module Xdim(BSM_bsm))) ]
+
+let static_models_MSSM : (string * string * (module Model.T)) list =
+ let open Modellib_MSSM in
+ let pfx = "from Modellib_MSSM: " in
+ [ ("MSSM", pfx^"MSSM(MSSM_no_4)", (module MSSM(MSSM_no_4)));
+ ("MSSM_CKM", pfx^"MSSM(MSSM_no_4_ckm)", (module MSSM(MSSM_no_4_ckm)));
+ ("MSSM_Hgg", pfx^"MSSM(MSSM_Hgg)", (module MSSM(MSSM_Hgg)));
+ ("MSSM_Grav", pfx^"MSSM(MSSM_Grav)", (module MSSM(MSSM_Grav))) ]
+
+let static_models_NMSSM : (string * string * (module Model.T)) list =
+ let open Modellib_NMSSM in
+ let pfx = "from Modellib_NMSSM: " in
+ [ ("NMSSM", pfx^"NMSSM_func(NMSSM)", (module NMSSM_func(NMSSM)));
+ ("NMSSM_CKM", pfx^"NMSSM_func(NMSSM_CKM)", (module NMSSM_func(NMSSM_CKM)));
+ ("NMSSM_Hgg", pfx^"NMSSM_func(NMSSM_Hgg)", (module NMSSM_func(NMSSM_Hgg))) ]
+
+let static_models_NoH : (string * string * (module Model.T)) list =
+ let open Modellib_NoH in
+ let pfx = "from Modellib_NoH: " in
+ [ ("AltH", pfx^"AltH(NoH_k_matrix)", (module AltH(NoH_k_matrix)));
+ ("NoH_rx", pfx^"NoH(NoH_k_matrix)", (module NoH(NoH_k_matrix))) ]
+
+let static_models_other : (string * string * (module Model.T)) list =
+ let module Zprime = Modellib_Zprime in
+ let module PSSSM = Modellib_PSSSM in
+ let module WZW = Modellib_WZW in
+ let pfx s = "from Modellib_" ^ s ^ ": " in
+ [ ("Zprime", pfx "Zprime"^"Zprime.Zprime(Zprime.SM_no_anomalous)", (module Zprime.Zprime(Zprime.SM_no_anomalous)));
+ ("PSSSM", pfx "PSSSM"^"PSSSM.ExtMSSM(PSSSM.PSSSM)", (module PSSSM.ExtMSSM(PSSSM.PSSSM)));
+ ("WZW", pfx "WZW"^"WZW.WZW(WZW.SM_no_anomalous)", (module WZW.WZW(WZW.SM_no_anomalous))) ]
+
+let static_models =
+ Omega_cli.Models.of_list
+ (List.concat [ static_models_SM;
+ static_models_BSM;
+ static_models_MSSM;
+ static_models_NMSSM;
+ static_models_NoH;
+ static_models_other ])
+
+let list_models () =
+ List.iter
+ (fun (name, description) -> Printf.printf "%s : %s\n" name description)
+ (Omega_cli.Models.names static_models)
+
+type model =
+ | Static_Model of string
+ | UFO_Model of string
+
+let load_model ?(flags=[]) = function
+ | Static_Model name ->
+ begin match Omega_cli.Models.by_name_opt static_models name with
+ | Some (module S) -> (module Modeltools.Static(S) : Model.Mutable)
+ | None -> invalid_arg (Printf.sprintf "omega: static model '%s' not found!" name)
+ end
+ | UFO_Model directory ->
+ let (module U) = (module UFO.Model : Model.Mutable with type init = string * string list) in
+ U.init (directory, flags);
+ (module U : Model.Mutable)
+
+(* Check if the model [M] contains Majorana fermions.
+ In the case of UFO, this can only be used \emph{after} the UFO model has
+ been loaded with [M.init dir], of course! *)
+let needs_majorana (module M : Model.T) =
+ List.exists (fun f -> M.fermion f = 2) (M.flavors ())
+
+(* Interface to the old CLI module [Omega] for testing the first class modules
+ code before implementing the new [Omega_cli]. *)
+
+module Legacy =
+ struct
+
+ (* Match a model without Majorana fermions and a target to a topology. *)
+ let dirac (module T : Target.Maker) (module M : Model.Mutable) =
+ let n = M.max_degree () in
+ if n > 4 then
+ (module (Omega.Nary(T)(M)) : Omega_cli.T)
+ else if n = 4 then
+ (module (Omega.Mixed23(T)(M)) : Omega_cli.T)
+ else if n = 3 then
+ (module (Omega.Binary(T)(M)) : Omega_cli.T)
+ else
+ invalid_arg "Omega3.Legacy.dirac: max_degree < 3"
+
+ (* Match a model containing Majorana fermions and a target to a topology. *)
+ let majorana (module T : Target.Maker) (module M : Model.Mutable) =
+ let n = M.max_degree () in
+ if n > 4 then
+ (module (Omega.Nary_Majorana(T)(M)) : Omega_cli.T)
+ else if n = 4 then
+ (module (Omega.Mixed23_Majorana(T)(M)) : Omega_cli.T)
+ else if n = 3 then
+ (module (Omega.Binary_Majorana(T)(M)) : Omega_cli.T)
+ else
+ invalid_arg "Omega3.Legacy.majorana: max_degree < 3"
+
+ (* Match a model containing Majorana fermions and a target to a topology
+ using the old implementation. *)
+ let vintage_majorana (module T : Target.Maker) (module M : Model.Mutable) =
+ let n = M.max_degree () in
+ if n = 3 || n = 4 then
+ (module (Omega.Mixed23_Majorana_vintage(T)(M)) : Omega_cli.T)
+ else if n > 4 then
+ invalid_arg "Omega3.Legacy.vintage_majorana: max_degree > 4"
+ else
+ invalid_arg "Omega3.Legacy.vintage_majorana: max_degree < 3"
+
+ let fortran ?(force_vintage_majorana=false) ?(force_majorana=false) (module M : Model.Mutable) =
+ if force_vintage_majorana then
+ vintage_majorana (module Target_Fortran.Make_Majorana) (module M)
+ else if force_majorana || needs_majorana (module M) then
+ majorana (module Target_Fortran.Make_Majorana) (module M)
+ else
+ dirac (module Target_Fortran.Make) (module M)
+
+ let vm ?(force_vintage_majorana=false) ?(force_majorana=false) (module M : Model.Mutable) =
+ if force_vintage_majorana || force_majorana || needs_majorana (module M) then
+ invalid_arg "Omega3.Legacy.vm: Majorana fermions not yet supported by the virtual machine"
+ else
+ dirac (module Target_VM.Make) (module M)
+
+ let adjoin_target ?force_majorana ?force_vintage_majorana (module M : Model.Mutable) name =
+ match String.lowercase_ascii name with
+ | "fortran" -> fortran ?force_majorana ?force_vintage_majorana (module M)
+ | "vm" -> vm ?force_majorana ?force_vintage_majorana (module M)
+ | _ -> invalid_arg (Printf.sprintf "omega: target '%s' not found!" name)
+
+ let load_omega ?flags ?force_majorana ?force_vintage_majorana target model =
+ adjoin_target ?force_majorana ?force_vintage_majorana (load_model ?flags model) target
+
+ end
+
+module Bound (M : Model.T) : Tuple.Bound =
+ struct
+ let max_arity () = pred (M.max_degree ())
+ end
+
+module V3 =
+ struct
+
+ module CLI = Omega_cli.Make
+
+ (* Match a model without Majorana fermions and a target to a topology. *)
+ let dirac (module T : Target.Maker) (module M : Model.Mutable) =
+ let open Fusion in
+ let n = M.max_degree () in
+ if n > 4 then
+ (module (CLI(Nary(Bound(M)))(Helac(Bound(M)))(T)(M)) : Omega_cli.T)
+ else if n = 4 then
+ (module (CLI(Mixed23)(Helac_Mixed23)(T)(M)) : Omega_cli.T)
+ else if n = 3 then
+ (module (CLI(Binary)(Helac_Binary)(T)(M)) : Omega_cli.T)
+ else
+ invalid_arg "Omega3.V3.dirac: max_degree < 3"
+
+ let dirac_helac (module T : Target.Maker) (module M : Model.Mutable) =
+ let open Fusion in
+ let n = M.max_degree () in
+ if n > 4 then
+ (module (CLI(Helac(Bound(M)))(Helac(Bound(M)))(T)(M)) : Omega_cli.T)
+ else if n = 4 then
+ (module (CLI(Helac_Mixed23)(Helac_Mixed23)(T)(M)) : Omega_cli.T)
+ else if n = 3 then
+ (module (CLI(Helac_Binary)(Helac_Binary)(T)(M)) : Omega_cli.T)
+ else
+ invalid_arg "Omega3.V3.dirac_helac: max_degree < 3"
+
+ (* Match a model containing Majorana fermions and a target to a topology. *)
+ let majorana (module T : Target.Maker) (module M : Model.Mutable) =
+ let open Fusion in
+ let n = M.max_degree () in
+ if n > 4 then
+ (module (CLI(Nary_Majorana(Bound(M)))(Helac_Majorana(Bound(M)))(T)(M)) : Omega_cli.T)
+ else if n = 4 then
+ (module (CLI(Mixed23_Majorana)(Helac_Mixed23_Majorana)(T)(M)) : Omega_cli.T)
+ else if n = 3 then
+ (module (CLI(Binary_Majorana)(Helac_Binary_Majorana)(T)(M)) : Omega_cli.T)
+ else
+ invalid_arg "Omega3.V3.majorana: max_degree < 3"
+
+ let majorana_helac (module T : Target.Maker) (module M : Model.Mutable) =
+ let open Fusion in
+ let n = M.max_degree () in
+ if n > 4 then
+ (module (CLI(Helac_Majorana(Bound(M)))(Helac_Majorana(Bound(M)))(T)(M)) : Omega_cli.T)
+ else if n = 4 then
+ (module (CLI(Helac_Mixed23_Majorana)(Helac_Mixed23_Majorana)(T)(M)) : Omega_cli.T)
+ else if n = 3 then
+ (module (CLI(Helac_Binary_Majorana)(Helac_Binary_Majorana)(T)(M)) : Omega_cli.T)
+ else
+ invalid_arg "Omega3.V3.majorana_helac: max_degree < 3"
+
+ (* Match a model containing Majorana fermions and a target to a topology
+ using the old implementation. *)
+ let vintage_majorana (module T : Target.Maker) (module M : Model.Mutable) =
+ let open Fusion_vintage in
+ let n = M.max_degree () in
+ if n > 4 then
+ (module (CLI(Nary_Majorana(Bound(M)))(Helac_Majorana(Bound(M)))(T)(M)) : Omega_cli.T)
+ else if n = 4 then
+ (module (CLI(Mixed23_Majorana)(Helac_Majorana(Bound(M)))(T)(M)) : Omega_cli.T)
+ else if n = 3 then
+ (module (CLI(Binary_Majorana)(Helac_Majorana(Bound(M)))(T)(M)) : Omega_cli.T)
+ else
+ invalid_arg "Omega3.V3.vintage_majorana: max_degree < 3"
+
+ let vintage_majorana_helac (module T : Target.Maker) (module M : Model.Mutable) =
+ let open Fusion_vintage in
+ let n = M.max_degree () in
+ if n > 2 then
+ (module (CLI(Nary_Majorana(Bound(M)))(Helac_Majorana(Bound(M)))(T)(M)) : Omega_cli.T)
+ else
+ invalid_arg "Omega3.V3.vintage_majorana_helac: max_degree < 3"
+
+ let fortran ?(force_vintage_majorana=false) ?(force_majorana=false) (module M : Model.Mutable) =
+ if force_vintage_majorana then
+ vintage_majorana (module Target_Fortran.Make_Majorana) (module M)
+ else if force_majorana || needs_majorana (module M) then
+ majorana (module Target_Fortran.Make_Majorana) (module M)
+ else
+ dirac (module Target_Fortran.Make) (module M)
+
+ let fortran_helac ?(force_vintage_majorana=false) ?(force_majorana=false) (module M : Model.Mutable) =
+ if force_vintage_majorana then
+ vintage_majorana_helac (module Target_Fortran.Make_Majorana) (module M)
+ else if force_majorana || needs_majorana (module M) then
+ majorana_helac (module Target_Fortran.Make_Majorana) (module M)
+ else
+ dirac_helac (module Target_Fortran.Make) (module M)
+
+ let vm ?(force_vintage_majorana=false) ?(force_majorana=false) (module M : Model.Mutable) =
+ if force_vintage_majorana || force_majorana || needs_majorana (module M) then
+ invalid_arg "Omega3.V3.vm: Majorana fermions not yet supported by the virtual machine"
+ else
+ dirac (module Target_VM.Make) (module M)
+
+ let vm_helac ?(force_vintage_majorana=false) ?(force_majorana=false) (module M : Model.Mutable) =
+ if force_vintage_majorana || force_majorana || needs_majorana (module M) then
+ invalid_arg "Omega3.V3.vm_helac: Majorana fermions not yet supported by the virtual machine"
+ else
+ dirac_helac (module Target_VM.Make) (module M)
+
+ let adjoin_target ?(helac=false) ?force_majorana ?force_vintage_majorana (module M : Model.Mutable) name =
+ match String.lowercase_ascii name with
+ | "fortran" ->
+ if helac then
+ fortran_helac ?force_majorana ?force_vintage_majorana (module M)
+ else
+ fortran ?force_majorana ?force_vintage_majorana (module M)
+ | "vm" ->
+ if helac then
+ vm_helac ?force_majorana ?force_vintage_majorana (module M)
+ else
+ vm ?force_majorana ?force_vintage_majorana (module M)
+ | _ -> invalid_arg (Printf.sprintf "omega: target '%s' not found!" name)
+
+ let load_omega ?helac ?flags ?force_majorana ?force_vintage_majorana target model =
+ adjoin_target ?helac ?force_majorana ?force_vintage_majorana (load_model ?flags model) target
+
+ end
+
+(* This is the first part of the command line processing.
+ Interpret the options up to ["--"] to load a model (static or UFO)
+ and a target. Then dispatch the rest of the command line to the old ([Omega.Make().main],
+ selected by ["--legacy"]) main program or the new one ([Omega_cli.Make().main],
+ selected by ["--v3"] or by default).
+
+ For static models, the old command line interface should work in exactly the same way
+ as the single executables. For UFO models, some options in the old interface
+ will not work, due to the new loading sequence. *)
+
+let list_targets () =
+ List.iter print_endline ["fortran"; "ovm"]
+
+type mode =
+ | V3
+ | Legacy
+
+let default_static_model_name = "SM"
+let default_target_name = "fortran"
+
+let _ =
+ let argv0 = Sys.argv.(0) in
+ let usage = "usage: " ^ argv0 ^ " [-help] [options]"
+ and mode = ref V3
+ and arg_head_rev = ref []
+ and arg_tail_rev = ref []
+ and ufo_debug = ref []
+ and model = ref (Static_Model default_static_model_name)
+ and target_name = ref default_target_name
+ and force_majorana = ref None
+ and force_vintage_majorana = ref None
+ and helac = ref None in
+ Arg.parse
+ (Arg.align
+ [ ( "-M", Arg.String (fun s -> model := Static_Model s),
+ "model select static model (default='" ^ default_static_model_name ^ "')");
+ ( "--model", Arg.String (fun s -> model := Static_Model s),
+ "model select static model (default='" ^ default_static_model_name ^ "')");
+ ( "--model_list", Arg.Unit list_models, " list all available static models");
+ ( "-U", Arg.String (fun s -> model := UFO_Model s),
+ "dir select UFO and read from directory");
+ ( "--ufo_directory", Arg.String (fun s -> model := UFO_Model s),
+ "dir select UFO and read from directory");
+ ( "--ufo_debug", Arg.String (fun s -> ufo_debug := s :: !ufo_debug),
+ "flag add UFO debug flags (undocumented)");
+ ( "-T", Arg.String ((:=) target_name), "target select target (default='" ^ !target_name ^ "')");
+ ( "--target", Arg.String ((:=) target_name), "target select target (default='" ^ !target_name ^ "')");
+ ( "--target_list", Arg.Unit list_targets, " list all available targets");
+ ( "--majorana", Arg.Unit (fun () -> force_majorana := Some true),
+ " use Majorana spinors even if not needed");
+ ( "--vintage_majorana", Arg.Unit (fun () -> force_vintage_majorana := Some true),
+ " use the original implementation of Majorana spinors");
+ ( "--helac", Arg.Unit (fun () -> helac := Some true),
+ " use asymmetrical topologies like HELAC");
+ ( "--v3", Arg.Unit (fun () -> mode := V3), " use the new omega CLI, version 3 (default)");
+ ( "--legacy", Arg.Unit (fun () -> mode := Legacy), " use the historically grown omega CLI");
+ ( "--", Arg.Rest (fun s -> arg_tail_rev := s :: !arg_tail_rev),
+ " pass remaining options to the selected omega CLI") ])
+ (fun s -> arg_head_rev := s :: !arg_head_rev)
+ usage;
+ let arg_head = List.rev !arg_head_rev
+ and arg_tail = List.rev !arg_tail_rev in
+ begin match arg_head with
+ | [] -> ()
+ | args -> Printf.eprintf "omega3: ignoring options before --: %s\n" (String.concat " " args)
+ end;
+ let force_majorana = !force_majorana
+ and force_vintage_majorana = !force_vintage_majorana
+ and helac = !helac
+ and flags =
+ match !ufo_debug with
+ | [] -> None
+ | flags -> Some flags in
+ let (module O) =
+ match !mode with
+ | Legacy -> Legacy.load_omega ?flags ?force_majorana ?force_vintage_majorana !target_name !model
+ | V3 -> V3.load_omega ?flags ?helac ?force_majorana ?force_vintage_majorana !target_name !model in
+ let current = ref 0
+ and argv = Array.of_list (argv0 :: arg_tail) in
+ O.main ~current ~argv ()
Index: trunk/omega/src/omega_Template.ml
===================================================================
--- trunk/omega/src/omega_Template.ml (revision 8899)
+++ trunk/omega/src/omega_Template.ml (revision 8900)
@@ -1,35 +1,26 @@
(* omega_Template.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.Fortran_Majorana)
- (Modellib_BSM.Template(Modellib_BSM.BSM_bsm))
+module O = Omega.Mixed23(Target_Fortran.Make_Majorana)(Modellib_BSM.Template(Modellib_BSM.BSM_bsm))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/partial.ml
===================================================================
--- trunk/omega/src/partial.ml (revision 8899)
+++ trunk/omega/src/partial.ml (revision 8900)
@@ -1,160 +1,167 @@
(* partial.ml --
Copyright (C) 1999-2015 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
module type T =
sig
type domain
type 'a t
val of_list : (domain * 'a) list -> 'a t
val of_lists : domain list -> 'a list -> 'a t
exception Undefined of domain
val apply : 'a t -> domain -> 'a
+ val apply_opt : 'a t -> domain -> 'a option
val apply_with_fallback : (domain -> 'a) -> 'a t -> domain -> 'a
val auto : domain t -> domain -> domain
end
module Make (D : Map.OrderedType) : T with type domain = D.t =
struct
module M = Map.Make (D)
type domain = D.t
type 'a t = 'a M.t
let of_list l =
List.fold_left (fun m (d, v) -> M.add d v m) M.empty l
let of_lists domain values =
of_list
(try
List.map2 (fun d v -> (d, v)) domain values
with
| Invalid_argument _ (* ["List.map2"] *) ->
invalid_arg "Partial.of_lists: length mismatch")
let auto partial d =
try
M.find d partial
with
| Not_found -> d
exception Undefined of domain
let apply partial d =
try
M.find d partial
with
| Not_found -> raise (Undefined d)
+ let apply_opt partial d =
+ try
+ Some (M.find d partial)
+ with
+ | Not_found -> None
+
let apply_with_fallback fallback partial d =
try
M.find d partial
with
| Not_found -> fallback d
end
(* \thocwmodulesection{Unit Tests} *)
module Test : sig val suite : OUnit.test end =
struct
open OUnit
module P = Make (struct type t = int let compare = compare end)
let apply_ok =
"apply/ok" >::
(fun () ->
let p = P.of_list [ (0,"a"); (1,"b"); (2,"c") ]
and l = [ 0; 1; 2 ] in
assert_equal [ "a"; "b"; "c" ] (List.map (P.apply p) l))
let apply_ok2 =
"apply/ok2" >::
(fun () ->
let p = P.of_lists [0; 1; 2] ["a"; "b"; "c"]
and l = [ 0; 1; 2 ] in
assert_equal [ "a"; "b"; "c" ] (List.map (P.apply p) l))
let apply_shadowed =
"apply/shadowed" >::
(fun () ->
let p = P.of_list [ (0,"a"); (1,"b"); (2,"c"); (1,"d") ]
and l = [ 0; 1; 2 ] in
assert_equal [ "a"; "d"; "c" ] (List.map (P.apply p) l))
let apply_shadowed2 =
"apply/shadowed2" >::
(fun () ->
let p = P.of_lists [0; 1; 2; 1] ["a"; "b"; "c"; "d"]
and l = [ 0; 1; 2 ] in
assert_equal [ "a"; "d"; "c" ] (List.map (P.apply p) l))
let apply_mismatch =
"apply/mismatch" >::
(fun () ->
assert_raises
(Invalid_argument "Partial.of_lists: length mismatch")
(fun () -> P.of_lists [0; 1; 2] ["a"; "b"; "c"; "d"]))
let suite_apply =
"apply" >:::
[apply_ok;
apply_ok2;
apply_shadowed;
apply_shadowed2;
apply_mismatch]
let auto_ok =
"auto/ok" >::
(fun () ->
let p = P.of_list [ (0,10); (1,11)]
and l = [ 0; 1; 2 ] in
assert_equal [ 10; 11; 2 ] (List.map (P.auto p) l))
let suite_auto =
"auto" >:::
[auto_ok]
let apply_with_fallback_ok =
"apply_with_fallback/ok" >::
(fun () ->
let p = P.of_list [ (0,10); (1,11)]
and l = [ 0; 1; 2 ] in
assert_equal
[ 10; 11; -2 ] (List.map (P.apply_with_fallback (fun n -> - n) p) l))
let suite_apply_with_fallback =
"apply_with_fallback" >:::
[apply_with_fallback_ok]
let suite =
"Partial" >:::
[suite_apply;
suite_auto;
suite_apply_with_fallback]
let time () =
()
end
Index: trunk/omega/src/UFO_parser.mly
===================================================================
--- trunk/omega/src/UFO_parser.mly (revision 8899)
+++ trunk/omega/src/UFO_parser.mly (revision 8900)
@@ -1,182 +1,193 @@
/* vertex_parser.mly --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
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. */
/* Right recursion is more convenient for constructing
the value. Since the lists will always be short,
there is no performace or stack size reason for
prefering left recursion. */
%{
module U = UFO_syntax
let parse_error msg =
raise (UFO_syntax.Syntax_Error
(msg, symbol_start_pos (), symbol_end_pos ()))
let invalid_parameter_attr () =
parse_error "invalid parameter attribute"
%}
%token < int > INT
%token < float > FLOAT
%token < string > STRING ID
%token DOT COMMA COLON
%token EQUAL PLUS MINUS DIV
%token LPAREN RPAREN
%token LBRACE RBRACE
%token LBRACKET RBRACKET
%token END
%start file
%type < UFO_syntax.t > file
%%
file:
| declarations END { $1 }
;
declarations:
| { [] }
| declaration declarations { $1 :: $2 }
;
declaration:
| ID EQUAL name LPAREN RPAREN { { U.name = $1;
U.kind = $3;
U.attribs = [] } }
| ID EQUAL name LPAREN attributes RPAREN { { U.name = $1;
U.kind = $3;
U.attribs = $5 } }
| ID EQUAL STRING { U.macro $1 (U.String $3) }
| ID EQUAL string_expr { U.macro $1 (U.String_Expr $3) }
;
name:
| ID { [$1] }
| name DOT ID { $3 :: $1 }
;
attributes:
| attribute { [$1] }
| attribute COMMA attributes { $1 :: $3 }
;
attribute:
| ID EQUAL value { { U.a_name = $1; U.a_value = $3 } }
| ID EQUAL list { { U.a_name = $1; U.a_value = $3 } }
| ID EQUAL dictionary { { U.a_name = $1; U.a_value = $3 } }
;
value:
| INT { U.Integer $1 }
| INT DIV INT { U.Fraction ($1, $3) }
| FLOAT { U.Float $1 }
| string { U.String $1 }
| string_expr { U.String_Expr $1 }
| name { U.Name $1 }
;
list:
- | LBRACKET RBRACKET { U.Empty_List }
- | LBRACKET names RBRACKET { U.Name_List $2 }
- | LBRACKET strings RBRACKET { U.String_List $2 }
- | LBRACKET integers RBRACKET { U.Integer_List $2 }
+ | LBRACKET RBRACKET { U.Empty_List }
+ | LBRACKET names RBRACKET { U.Name_List $2 }
+ | LBRACKET strings RBRACKET { U.String_List $2 }
+ | LBRACKET integers RBRACKET { U.Integer_List $2 }
+ | LBRACKET integer_lists RBRACKET { U.Young_Tableau $2 }
;
+integer_list:
+ | LBRACKET RBRACKET { [] }
+ | LBRACKET integers RBRACKET { $2 }
+
+;
dictionary:
| LBRACE orders RBRACE { U.Order_Dictionary $2 }
| LBRACE couplings RBRACE { U.Coupling_Dictionary $2 }
| LBRACE decays RBRACE { U.Decay_Dictionary $2 }
;
names:
| name { [$1] }
| name COMMA names { $1 :: $3 }
;
integers:
| INT { [$1] }
| INT COMMA integers { $1 :: $3 }
;
+integer_lists:
+ | integer_list { [$1] }
+ | integer_list COMMA integer_lists { $1 :: $3 }
+;
+
/* We demand that a [U.String_Expr] contains no adjacent literal strings.
Instead, they are concatenated already in the parser.
Note that a [U.String_Expr] must have at least two elements:
singletons are parsed as [U.Name] or [U.String] instead. */
string_expr:
| literal_string_expr { $1 }
| macro_string_expr { $1 }
;
literal_string_expr:
| string PLUS name { [U.Literal $1; U.Macro $3] }
| string PLUS macro_string_expr { U.Literal $1 :: $3 }
;
macro_string_expr:
| name PLUS string { [U.Macro $1; U.Literal $3] }
| name PLUS string_expr { U.Macro $1 :: $3 }
;
strings:
| string { [$1] }
| string COMMA strings { $1 :: $3 }
;
string:
| STRING { $1 }
| string PLUS STRING { $1 ^ $3 }
;
orders:
| order { [$1] }
| order COMMA orders { $1 :: $3 }
;
order:
| STRING COLON INT { ($1, $3) }
;
couplings:
| coupling { [$1] }
| coupling COMMA couplings { $1 :: $3 }
;
coupling:
| LPAREN INT COMMA INT RPAREN COLON name { ($2, $4, $7) }
;
decays:
| decay { [$1] }
| decay COMMA decays { $1 :: $3 }
;
decay:
| LPAREN names RPAREN COLON STRING { ($2, $5) }
;
Index: trunk/omega/src/omega_WZW.ml
===================================================================
--- trunk/omega/src/omega_WZW.ml (revision 8899)
+++ trunk/omega/src/omega_WZW.ml (revision 8900)
@@ -1,35 +1,26 @@
(* omega_WZW.ml --
Copyright (C) 1999-2015 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.Fortran)
- (Modellib_WZW.WZW(Modellib_WZW.SM_no_anomalous))
+module O = Omega.Mixed23(Target_Fortran.Make)(Modellib_WZW.WZW(Modellib_WZW.SM_no_anomalous))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/omega_HSExt_VM.ml
===================================================================
--- trunk/omega/src/omega_HSExt_VM.ml (revision 8899)
+++ trunk/omega/src/omega_HSExt_VM.ml (revision 8900)
@@ -1,35 +1,26 @@
(* omega_HSExt_VM.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
cf. main AUTHORS file
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.VM)
- (Modellib_BSM.HSExt(Modellib_BSM.BSM_bsm))
+module O = Omega.Mixed23(Target_VM.Make)(Modellib_BSM.HSExt(Modellib_BSM.BSM_bsm))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/partial.mli
===================================================================
--- trunk/omega/src/partial.mli (revision 8899)
+++ trunk/omega/src/partial.mli (revision 8900)
@@ -1,58 +1,59 @@
(* partial.mli --
Copyright (C) 1999-2015 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
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. *)
(* Partial maps that are constructed from assoc lists. *)
module type T =
sig
(* The domain of the map.
It needs to be compatible with [Map.OrderedType.t] *)
type domain
(* The codomain ['a] can be anything we want. *)
type 'a t
(* A list of argument-value pairs is mapped to a partial map.
If an argument appears twice, the later value takes
precedence. *)
val of_list : (domain * 'a) list -> 'a t
(* Two lists of arguments and values (both must have the
same length) are mapped to a partial map. Again the
later value takes precedence. *)
val of_lists : domain list -> 'a list -> 'a t
(* If domain and codomain disagree, we must raise an exception
or provide a fallback. *)
exception Undefined of domain
val apply : 'a t -> domain -> 'a
+ val apply_opt : 'a t -> domain -> 'a option
val apply_with_fallback : (domain -> 'a) -> 'a t -> domain -> 'a
(* Iff domain and codomain of the map agree, we can
fall back to the identity map. *)
val auto : domain t -> domain -> domain
end
module Make : functor (D : Map.OrderedType) -> T with type domain = D.t
module Test : sig val suite : OUnit.test end
Index: trunk/omega/src/NEList.mli
===================================================================
--- trunk/omega/src/NEList.mli (revision 0)
+++ trunk/omega/src/NEList.mli (revision 8900)
@@ -0,0 +1,61 @@
+(* NEList.mli --
+
+ Copyright (C) 2022-2023 by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+ with contributions from
+ Christian Speckner <cnspeckn@googlemail.com>
+
+ 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. *)
+
+(* Since O'Caml 3.11, we can use private type abbreviation
+ to enforce invariants without sacrificing any performance. *)
+
+(* Once we have decided on an interface that avoids any partial
+ functions, most of the implementation will be just an indirection
+ to the standard library module. *)
+
+(* A nonempty list ['a t] is represented as a ``normal''
+ ['a list] \ldots *)
+type 'a t = private 'a list
+
+(* \ldots, but there is no way to construct an empty list,
+ since the constructors require at least one element: *)
+val make : 'a -> 'a list -> 'a t
+val singleton : 'a -> 'a t
+val cons : 'a -> 'a t -> 'a t
+
+(* [to_list l] is the same as [l :> elt list], without having to
+ specify the element type [elt]. The compiler should inline this. *)
+val to_list : 'a t -> 'a list
+
+(* [hd] never fails. We can also have a [tl] that never fails,
+ if we allow it to return an ``normal'' list. *)
+val hd : 'a t -> 'a
+val tl : 'a t -> 'a list
+val tl_opt : 'a t -> 'a t option
+
+(* The inverse of [cons] (uncurried): [snoc l = (hd l, tl l)] and
+ [snoc_opt l = (hd l, tl_opt l)], but a little bit more efficient,
+ since the list is deconstructed only once. *)
+val snoc : 'a t -> 'a * 'a list
+val snoc_opt : 'a t -> 'a * 'a t option
+
+val map : ('a -> 'b) -> 'a t -> 'b t
+val fold_right : ('a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+val sort : ('a -> 'a -> int) -> 'a t -> 'a t
+
Index: trunk/omega/src/whizard.ml
===================================================================
--- trunk/omega/src/whizard.ml (revision 8899)
+++ trunk/omega/src/whizard.ml (revision 8900)
@@ -1,418 +1,409 @@
(* whizard.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
open Printf
module type T =
sig
type t
type amplitude
val trees : amplitude -> t
val merge : t -> t
val write : out_channel -> string -> t -> unit
end
module Make (FM : Fusion.Maker) (P : Momentum.T)
(PW : Momentum.Whizard with type t = P.t) (M : Model.T) =
struct
module F = FM(P)(M)
type tree = (P.t * F.flavor list) list
module Poles = Map.Make
(struct
type t = int * int
let compare (s1, t1) (s2, t2) =
let c = compare s2 s1 in
if c <> 0 then
c
else
compare t1 t2
end)
let add_tree maps tree trees =
Poles.add maps
(try tree :: (Poles.find maps trees) with Not_found -> [tree]) trees
type t =
{ in1 : F.flavor;
in2 : F.flavor;
out : F.flavor list;
trees : tree list Poles.t }
type amplitude = F.amplitude
(* \thocwmodulesection{Building Trees} *)
(* A singularity is to be mapped if it is timelike and not the
overall $s$-channel. *)
let timelike_map c = P.Scattering.timelike c && not (P.Scattering.s_channel c)
let count_maps n clist =
List.fold_left (fun (s, t as cnt) (c, _) ->
if timelike_map c then
(succ s, t)
else if P.Scattering.spacelike c then
(s, succ t)
else
cnt) (0, 0) clist
let poles_to_whizard n trees poles =
let tree = List.map (fun wf ->
(P.Scattering.flip_s_channel_in (F.momentum wf), [F.flavor wf])) poles in
add_tree (count_maps n tree) tree trees
(* \begin{dubious}
I must reinstate the [conjugate] eventually!
\end{dubious} *)
let trees a =
match F.externals a with
| in1 :: in2 :: out ->
let n = List.length out + 2 in
{ in1 = F.flavor in1;
in2 = F.flavor in2;
out = List.map (fun f -> (* [M.conjugate] *) (F.flavor f)) out;
trees = List.fold_left
(poles_to_whizard n) Poles.empty (F.poles a) }
| _ -> invalid_arg "Whizard().trees"
(* \thocwmodulesection{Merging Homomorphic Trees} *)
module Pole_Map =
Map.Make (struct type t = P.t list let compare = compare end)
module Flavor_Set =
Set.Make (struct type t = F.flavor let compare = compare end)
let add_flavors flist fset =
List.fold_right Flavor_Set.add flist fset
let set_of_flavors flist =
List.fold_right Flavor_Set.add flist Flavor_Set.empty
let pack_tree map t =
let c, f =
List.split (List.sort (fun (c1, _) (c2, _) ->
compare (PW.of_momentum c2) (PW.of_momentum c1)) t) in
let f' =
try
List.map2 add_flavors f (Pole_Map.find c map)
with
| Not_found -> List.map set_of_flavors f in
Pole_Map.add c f' map
let pack_map trees = List.fold_left pack_tree Pole_Map.empty trees
let merge_sets clist flist =
List.map2 (fun c f -> (c, Flavor_Set.elements f)) clist flist
let unpack_map map =
Pole_Map.fold (fun c f l -> (merge_sets c f) :: l) map []
(* If a singularity is to be mapped (i.\,e.~if it is timelike and not the
overall $s$-channel), expand merged particles again: *)
let unfold1 (c, f) =
if timelike_map c then
List.map (fun f' -> (c, [f'])) f
else
[(c,f)]
let unfold_tree tree = Product.list (fun x -> x) (List.map unfold1 tree)
let unfold trees = ThoList.flatmap unfold_tree trees
let merge t =
{ t with trees = Poles.map
(fun t' -> unfold (unpack_map (pack_map t'))) t.trees }
(* \thocwmodulesection{Printing Trees} *)
let flavors_to_string f =
String.concat "/" (List.map M.flavor_to_string f)
let whizard_tree t =
"tree " ^
(String.concat " " (List.rev_map (fun (c, _) ->
(string_of_int (PW.of_momentum c))) t)) ^
" ! " ^
(String.concat ", " (List.rev_map (fun (_, f) -> flavors_to_string f) t))
let whizard_tree_debug t =
"tree " ^
(String.concat " " (List.rev_map (fun (c, _) ->
("[" ^ (String.concat "+" (List.map string_of_int (P.to_ints c))) ^ "]"))
(List.sort (fun (t1,_) (t2,_) ->
let c =
compare
(List.length (P.to_ints t2))
(List.length (P.to_ints t1)) in
if c <> 0 then
c
else
compare t1 t2) t))) ^
" ! " ^
(String.concat ", " (List.rev_map (fun (_, f) -> flavors_to_string f) t))
let format_maps = function
| (0, 0) -> "neither mapped timelike nor spacelike poles"
| (0, 1) -> "no mapped timelike poles, one spacelike pole"
| (0, n) -> "no mapped timelike poles, " ^
string_of_int n ^ " spacelike poles"
| (1, 0) -> "one mapped timelike pole, no spacelike pole"
| (1, 1) -> "one mapped timelike and spacelike pole each"
| (1, n) -> "one mapped timelike and " ^
string_of_int n ^ " spacelike poles"
| (n, 0) -> string_of_int n ^
" mapped timelike poles and no spacelike pole"
| (n, 1) -> string_of_int n ^
" mapped timelike poles and one spacelike pole"
| (n, n') -> string_of_int n ^ " mapped timelike and " ^
string_of_int n' ^ " spacelike poles"
let format_flavor f =
match flavors_to_string f with
| "d" -> "d" | "dbar" -> "D"
| "u" -> "u" | "ubar" -> "U"
| "s" -> "s" | "sbar" -> "S"
| "c" -> "c" | "cbar" -> "C"
| "b" -> "b" | "bbar" -> "B"
| "t" -> "t" | "tbar" -> "T"
| "e-" -> "e1" | "e+" -> "E1"
| "nue" -> "n1" | "nuebar" -> "N1"
| "mu-" -> "e2" | "mu+" -> "E2"
| "numu" -> "n2" | "numubar" -> "N2"
| "tau-" -> "e3" | "tau+" -> "E3"
| "nutau" -> "n3" | "nutaubar" -> "N3"
| "g" -> "G" | "A" -> "A" | "Z" -> "Z"
| "W+" -> "W+" | "W-" -> "W-"
| "H" -> "H"
| s -> s ^ " (not translated)"
- module Mappable =
- Set.Make (struct type t = string let compare = compare end)
+ module Mappable = Sets.String
let mappable =
List.fold_right Mappable.add
[ "T"; "Z"; "W+"; "W-"; "H" ] Mappable.empty
let analyze_tree ch t =
List.iter (fun (c, f) ->
let f' = format_flavor f
and c' = PW.of_momentum c in
if P.Scattering.timelike c then begin
if P.Scattering.s_channel c then
fprintf ch " ! overall s-channel %d %s not mapped\n" c' f'
else if Mappable.mem f' mappable then
fprintf ch " map %d s-channel %s\n" c' f'
else
fprintf ch
" ! %d s-channel %s can't be mapped by whizard\n"
c' f'
end else
fprintf ch " ! t-channel %d %s not mapped\n" c' f') t
let write ch pid t =
failwith "Whizard.Make().write: incomplete"
(*i
fprintf ch "! whizard trees by O'Mega\n\n";
fprintf ch "! %s %s -> %s\n"
(M.flavor_to_string t.in1) (M.flavor_to_string t.in2)
(String.concat " " (List.map M.flavor_to_string t.out));
(*i
fprintf ch "! %d %d -> %s\n\n"
(whizard_code1 t.n 1) (whizard_code1 t.n 2)
(String.concat " " (List.map (fun o ->
string_of_int (whizard_code1 t.n o)) (ThoList.range 3 t.n)));
i*)
fprintf ch "process %s\n" pid;
Poles.iter (fun maps ds ->
fprintf ch "\n ! %d times %s:\n"
(List.length ds) (format_maps maps);
List.iter (fun d ->
fprintf ch "\n grove\n";
fprintf ch " %s\n" (whizard_tree d);
analyze_tree ch d) ds) t.trees;
fprintf ch "\n"
i*)
end
(* \thocwmodulesection{Process Dispatcher} *)
let arguments = function
| [] -> ("", "")
| args ->
let arg_list = String.concat ", " (List.map snd args) in
(arg_list, ", " ^ arg_list)
let import_prefixed ch pid name =
fprintf ch " use %s, only: %s_%s => %s !NODEP!\n"
pid pid name name
let declare_argument ch (arg_type, arg) =
fprintf ch " %s, intent(in) :: %s\n" arg_type arg
let call_function ch pid result name args =
fprintf ch " case (pr_%s)\n" pid;
fprintf ch " %s = %s_%s (%s)\n" result pid name args
let default_function ch result default =
fprintf ch " case default\n";
fprintf ch " call invalid_process (pid)\n";
fprintf ch " %s = %s\n" result default
let call_subroutine ch pid name args =
fprintf ch " case (pr_%s)\n" pid;
fprintf ch " call %s_%s (%s)\n" pid name args
let default_subroutine ch =
fprintf ch " case default\n";
fprintf ch " call invalid_process (pid)\n"
let write_interface_subroutine ch wrapper name args processes =
let arg_list, arg_list' = arguments args in
fprintf ch " subroutine %s (pid%s)\n" wrapper arg_list';
List.iter (fun p -> import_prefixed ch p name) processes;
List.iter (declare_argument ch) (("character(len=*)", "pid") :: args);
fprintf ch " select case (pid)\n";
List.iter (fun p -> call_subroutine ch p name arg_list) processes;
default_subroutine ch;
fprintf ch " end select\n";
fprintf ch " end subroutine %s\n" wrapper
let write_interface_function ch wrapper name
(result_type, result, default) args processes =
let arg_list, arg_list' = arguments args in
fprintf ch " function %s (pid%s) result (%s)\n" wrapper arg_list' result;
List.iter (fun p -> import_prefixed ch p name) processes;
List.iter (declare_argument ch) (("character(len=*)", "pid") :: args);
fprintf ch " %s :: %s\n" result_type result;
fprintf ch " select case (pid)\n";
List.iter (fun p -> call_function ch p result name arg_list) processes;
default_function ch result default;
fprintf ch " end select\n";
fprintf ch " end function %s\n" wrapper
let write_other_interface_functions ch =
fprintf ch " subroutine invalid_process (pid)\n";
fprintf ch " character(len=*), intent(in) :: pid\n";
fprintf ch " print *, \"PANIC:";
fprintf ch " process `\"//trim(pid)//\"' not available!\"\n";
fprintf ch " end subroutine invalid_process\n";
fprintf ch " function n_tot (pid) result (n)\n";
fprintf ch " character(len=*), intent(in) :: pid\n";
fprintf ch " integer :: n\n";
fprintf ch " n = n_in(pid) + n_out(pid)\n";
fprintf ch " end function n_tot\n"
let write_other_declarations ch =
fprintf ch " public :: n_in, n_out, n_tot, pdg_code\n";
fprintf ch " public :: allow_helicities\n";
fprintf ch " public :: create, destroy\n";
fprintf ch " public :: set_const, sqme\n";
fprintf ch " interface create\n";
fprintf ch " module procedure process_create\n";
fprintf ch " end interface\n";
fprintf ch " interface destroy\n";
fprintf ch " module procedure process_destroy\n";
fprintf ch " end interface\n";
fprintf ch " interface set_const\n";
fprintf ch " module procedure process_set_const\n";
fprintf ch " end interface\n";
fprintf ch " interface sqme\n";
fprintf ch " module procedure process_sqme\n";
fprintf ch " end interface\n"
let write_interface ch names =
fprintf ch "module process_interface\n";
fprintf ch " use kinds, only: default !NODEP!\n";
fprintf ch " use parameters, only: parameter_set\n";
fprintf ch " implicit none\n";
fprintf ch " private\n";
List.iter (fun p ->
fprintf ch
" character(len=*), parameter, public :: pr_%s = \"%s\"\n" p p)
names;
write_other_declarations ch;
fprintf ch "contains\n";
write_interface_function ch "n_in" "n_in" ("integer", "n", "0") [] names;
write_interface_function ch "n_out" "n_out" ("integer", "n", "0") [] names;
write_interface_function ch "pdg_code" "pdg_code"
("integer", "n", "0") [ "integer", "i" ] names;
write_interface_function ch "allow_helicities" "allow_helicities"
("logical", "yorn", ".false.") [] names;
write_interface_subroutine ch "process_create" "create" [] names;
write_interface_subroutine ch "process_destroy" "destroy" [] names;
write_interface_subroutine ch "process_set_const" "set_const"
[ "type(parameter_set)", "par"] names;
write_interface_function ch "process_sqme" "sqme"
("real(kind=default)", "sqme", "0")
[ "real(kind=default), dimension(0:,:)", "p";
"integer, dimension(:), optional", "h" ] names;
write_other_interface_functions ch;
fprintf ch "end module process_interface\n"
(* \thocwmodulesection{Makefile} *)
let write_makefile ch names =
fprintf ch "KINDS = ../@KINDS@\n";
fprintf ch "HELAS = ../@HELAS@\n";
fprintf ch "F90 = @F90@\n";
fprintf ch "F90FLAGS = @F90FLAGS@\n";
fprintf ch "F90INCL = -I$(KINDS) -I$(HELAS)\n";
fprintf ch "F90COMMON = omega_bundle_whizard.f90";
fprintf ch " file_utils.f90 process_interface.f90\n";
fprintf ch "include Makefile.processes\n";
fprintf ch "F90SRC = $(F90COMMON) $(F90PROCESSES)\n";
fprintf ch "OBJ = $(F90SRC:.f90=.o)\n";
fprintf ch "MOD = $(F90SRC:.f90=.mod)\n";
fprintf ch "archive: processes.a\n";
fprintf ch "processes.a: $(OBJ)\n";
fprintf ch "\t$(AR) r $@ $(OBJ)\n";
fprintf ch "\t@RANLIB@ $@\n";
fprintf ch "clean:\n";
fprintf ch "\trm -f $(OBJ)\n";
fprintf ch "realclean:\n";
fprintf ch "\trm -f processes.a\n";
fprintf ch "parameters.o: file_utils.o\n";
fprintf ch "omega_bundle_whizard.o: parameters.o\n";
fprintf ch "process_interface.o: parameters.o\n";
fprintf ch "%%.o: %%.f90 $(KINDS)/kinds.f90\n";
fprintf ch "\t$(F90) $(F90FLAGS) $(F90INCL) -c $<\n"
let write_makefile_processes ch names =
fprintf ch "F90PROCESSES =";
List.iter (fun f -> fprintf ch " \\\n %s.f90" f) names;
fprintf ch "\n";
List.iter (fun f ->
fprintf ch "%s.o: omega_bundle_whizard.o parameters.o\n" f;
fprintf ch "process_interface.o: %s.o\n" f) names
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/tree.mli
===================================================================
--- trunk/omega/src/tree.mli (revision 8899)
+++ trunk/omega/src/tree.mli (revision 8900)
@@ -1,168 +1,164 @@
(* tree.mli --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
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. *)
(* This module provides utilities for generic decorated trees, such as
FeynMF output. *)
(* \thocwmodulesection{Abstract Data Type} *)
type ('n, 'l) t
(* [leaf n l] returns a tree consisting of a single leaf node
of type [n] with a label [l]. *)
val leaf : 'n -> 'l -> ('n, 'l) t
(* [cons n ch] returns a tree node. *)
val cons : 'n -> ('n, 'l) t list -> ('n, 'l) t
(* Note that [cons node []] constructs a terminal node, but
\emph{not} a leaf, since the latter \emph{must} have a label!
\begin{dubious}
\label{Tree.Leaf}
This approach was probably tailored to Feynman diagrams,
where we have external propagators as nodes with additional
labels (cf.~the function [to_feynmf] on page~\pageref{Tree.to_feynmf}
below). I'm not so sure anymore that this was a good choice.
\end{dubious} *)
(* [node t] returns the top node of the tree [t]. *)
val node : ('n, 'l) t -> 'n
(* [leafs t] returns a list of all leaf labels \textit{in order}. *)
val leafs : ('n, 'l) t -> 'l list
(* [nodes t] returns a list of all nodes that are not leafs
in post-order. This guarantees
that the root node can be stripped from the result by [List.tl]. *)
val nodes : ('n, 'l) t -> 'n list
(* [fuse conjg root contains_root trees] joins the [trees], using
the leaf [root] in one of the trees as root of the new tree.
[contains_root] guides the search for the subtree containing [root]
as a leaf. [fun t -> List.mem root (leafs t)] is acceptable, but more
efficient solutions could be available in special circumstances. *)
val fuse : ('n -> 'n) -> 'l -> (('n, 'l) t -> bool) -> ('n, 'l) t list -> ('n, 'l) t
(* [sort lesseq t] return a sorted copy of the tree~[t]: node
labels are ignored and nodes are according to the supremum of the
leaf labels in the corresponding subtree. *)
val sort : ('l -> 'l -> bool) -> ('n, 'l) t -> ('n, 'l) t
val canonicalize : ('n, 'l) t -> ('n, 'l) t
(* \thocwmodulesection{Homomorphisms} *)
val map : ('n1 -> 'n2) -> ('l1 -> 'l2) -> ('n1, 'l1) t -> ('n2, 'l2) t
val fold : ('n -> 'l -> 'a) -> ('n -> 'a list -> 'a) -> ('n, 'l) t -> 'a
val fan : ('n -> 'l -> 'a list) -> ('n -> 'a list -> 'a list) ->
('n, 'l) t -> 'a list
(* \thocwmodulesection{Output} *)
val to_string : (string, string) t -> string
(* \thocwmodulesubsection{Feynmf} *)
(* \begin{dubious}
[style : (string * string) option] should be replaced by
[style : string option; tex_label : string option]
\end{dubious} *)
type feynmf =
{ style : (string * string) option;
rev : bool;
label : string option;
tension : float option }
val vanilla : feynmf
val sty : (string * string) * bool * string -> feynmf
(* [to_feynmf file to_string incoming t] write the trees in the
list~[t] to the file named~[file]. The leaves~[incoming] are
used as incoming particles and~[to_string] is use to convert
leaf labels to \LaTeX-strings. *)
(* \label{Tree.to_feynmf} *)
type 'l feynmf_set =
{ header : string;
incoming : 'l list;
diagrams : (feynmf, 'l) t list }
type ('l, 'm) feynmf_sets =
{ outer : 'l feynmf_set;
inner : 'm feynmf_set list }
val feynmf_sets_plain : bool -> int -> string ->
('l -> string) -> ('l -> string) ->
('m -> string) -> ('m -> string) -> ('l, 'm) feynmf_sets list -> unit
val feynmf_sets_wrapped : bool -> string ->
('l -> string) -> ('l -> string) ->
('m -> string) -> ('m -> string) -> ('l, 'm) feynmf_sets list -> unit
+val feynmf_sets_wrapped_to_channel : bool -> out_channel ->
+ ('l -> string) -> ('l -> string) ->
+ ('m -> string) -> ('m -> string) -> ('l, 'm) feynmf_sets list -> unit
+
(* If the diagrams at all levels are of the same type,
we can recurse to arbitrary depth. *)
type 'l feynmf_levels =
{ this : 'l feynmf_set;
lower : 'l feynmf_levels list }
(* [to_feynmf_levels_plain sections level file wf_to_TeX p_to_TeX levels]
\ldots *)
val feynmf_levels_plain : bool -> int -> string ->
('l -> string) -> ('l -> string) -> 'l feynmf_levels list -> unit
(* [to_feynmf_levels_wrapped file wf_to_TeX p_to_TeX levels]
\ldots *)
val feynmf_levels_wrapped : string ->
('l -> string) -> ('l -> string) -> 'l feynmf_levels list -> unit
(* \thocwmodulesubsection{Least Squares Layout} *)
(* A general graph with edges of type~['e], internal nodes of type~['n],
and external nodes of type ['ext]. *)
type ('e, 'n, 'ext) graph
val graph_of_tree : ('n -> 'n -> 'e) -> ('n -> 'n) ->
'n -> ('n, 'n) t -> ('e, 'n, 'n) graph
(* A general graph with the layout of the external nodes fixed. *)
type ('e, 'n, 'ext) ext_layout
val left_to_right : int -> ('e, 'n, 'ext) graph -> ('e, 'n, 'ext) ext_layout
(* A general graph with the layout of all nodes fixed. *)
type ('e, 'n, 'ext) layout
val layout : ('e, 'n, 'ext) ext_layout -> ('e, 'n, 'ext) layout
val dump : ('e, 'n, 'ext) layout -> unit
val iter_edges : ('e -> float * float -> float * float -> unit) ->
('e, 'n, 'ext) layout -> unit
val iter_internal : (float * float -> unit) ->
('e, 'n, 'ext) layout -> unit
val iter_incoming : ('ext * float * float -> unit) ->
('e, 'n, 'ext) layout -> unit
val iter_outgoing : ('ext * float * float -> unit) ->
('e, 'n, 'ext) layout -> unit
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/fusion.mli
===================================================================
--- trunk/omega/src/fusion.mli (revision 8899)
+++ trunk/omega/src/fusion.mli (revision 8900)
@@ -1,389 +1,427 @@
(* fusion.mli --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
+(* \thocwmodulesection{Signature of [Fusion.T]} *)
+
module type T =
sig
val options : Options.t
(* JRR's implementation of Majoranas needs a special case. *)
val vintage : bool
(* Wavefunctions are an abstract data type, containing a momentum~[p]
and additional quantum numbers, collected in~[flavor]. *)
type wf
+
+(* Return the wave function with the the same momentum and a
+ charge conjugated [flavor]. *)
val conjugate : wf -> wf
(* Obviously, [flavor] is not restricted to the physical notion of
- flavor, but can carry spin, color, etc. *)
+ flavor, but can carry spin, color, etc. See the implementation of
+ [Model.T] for the physics. *)
type flavor
val flavor : wf -> flavor
+
+(* If [flavor] contains powers of coupling orders, it is sometimes useful
+ for organizing the output and for diagnostics to be able to strip it
+ away. *)
+ type flavor_all_orders
+ val flavor_all_orders : wf -> flavor_all_orders
+
+(* If [flavor] contains $\textrm{SU}(3)$ color, it is sometimes useful
+ for organizing the output and for diagnostics to be able to strip it
+ away. *)
type flavor_sans_color
val flavor_sans_color : wf -> flavor_sans_color
(* Momenta are represented by an abstract datatype (defined
in~[Momentum]) that is optimized for performance. They can be
accessed either abstractly or as lists of indices of the external
momenta. These indices are assigned sequentially by [amplitude] below. *)
type p
val momentum : wf -> p
val momentum_list : wf -> int list
-(* At tree level, the wave functions are uniquely specified by [flavor]
- and momentum. If loops are included, we need to distinguish among
- orders. Also, if we build a result from an incomplete sum of diagrams,
- we need to add a distinguishing mark. At the moment, we assume that a
- [string] that can be attached to the symbol suffices. *)
- val wf_tag : wf -> string option
-
(* Coupling constants *)
type constant
(* and right hand sides of assignments. The latter are formed from a sign from
Fermi statistics, a coupling (constand and Lorentz structure) and wave
- functions. *)
+ functions of the children. *)
type coupling
type rhs
+
+(* \begin{dubious}
+ There is no deep reason for defining a polymorphic
+ [type 'a children], since we will only ever use [wf children].
+ \end{dubious} *)
type 'a children
- val sign : rhs -> int
- val coupling : rhs -> constant Coupling.t
- val coupling_tag : rhs -> string option
+(* Keep track of statistics. *)
+ val sign : rhs -> int
- type exclusions
- val no_exclusions : exclusions
+(* Extract the coupling (constant and structure) fusing the children. *)
+ val coupling : rhs -> constant Coupling.t
(* In renormalized perturbation theory, couplings come in different orders
of the loop expansion. Be prepared: [val order : rhs -> int] *)
(* \begin{dubious}
- This is here only for the benefit of [Target] and shall become
- [val children : rhs -> wf children] later \ldots
+ The concrete return type [wf list] is here only for the benefit
+ of [Target] and could become [wf children] in a more refined
+ interface \ldots
\end{dubious} *)
val children : rhs -> wf list
(* Fusions come in two types: fusions of wave functions to off-shell wave
functions:
\begin{equation*}
- \phi(p+q) = \phi(p)\phi(q)
+ \phi'(p+q) = \phi_1(p)\phi_2(q)
\end{equation*} *)
type fusion
val lhs : fusion -> wf
val rhs : fusion -> rhs list
(* and products at the keystones:
\begin{equation*}
- \phi(-p-q)\cdot\phi(p)\phi(q)
+ \braket{\phi'(-p-q)|\phi_1(p)\phi_2(q)}
\end{equation*} *)
type braket
val bra : braket -> wf
val ket : braket -> rhs list
(* [amplitude goldstones incoming outgoing] calculates the
amplitude for scattering of [incoming] to [outgoing]. If
[goldstones] is true, also non-propagating off-shell Goldstone
amplitudes are included to allow the checking of Slavnov-Taylor
- identities. *)
+ identities. [selectors] is an instance of [Cascade.T.selectors]
+ and used to select certain parts of an amplitude, see
+ section~\ref{sec:cascades}. *)
type amplitude
type amplitude_sans_color
type selectors
- val amplitudes : bool -> exclusions -> selectors ->
+ type slicings
+ val amplitudes : bool -> selectors -> slicings option ->
flavor_sans_color list -> flavor_sans_color list -> amplitude list
- val amplitude_sans_color : bool -> exclusions -> selectors ->
+ val amplitudes_all_orders : bool -> selectors ->
+ flavor_sans_color list -> flavor_sans_color list -> amplitude list
+ val amplitude_sans_color : bool -> selectors ->
flavor_sans_color list -> flavor_sans_color list -> amplitude_sans_color
+(* How a given wave function depends on other wave functions and
+ couplings. This is used for finding subexpressions common
+ among different color flow amplitudes. *)
val dependencies : amplitude -> wf -> (wf, coupling) Tree2.t
(* We should be precise regarding the semantics of the following functions, since
modules implementating [Target] must not make any mistakes interpreting the
return values. Instead of calculating the amplitude
\begin{subequations}
\begin{equation}
\label{eq:physical-amplitude}
\Braket{f_3,p_3,f_4,p_4,\ldots|T|f_1,p_1,f_2,p_2}
\end{equation}
directly, O'Mega calculates the---equivalent, but more symmetrical---crossed
amplitude
\begin{equation}
\Braket{\bar f_1,-p_1,\bar f_2,-p_2,f_3,p_3,f_4,p_4,\ldots|T|0}
\end{equation}
- Internally, all flavors are represented by their charge conjugates
+ For the benefit of the people implementing [Model]s, however,
+ all flavors are represented internally by the charge conjugates
\begin{equation}
\label{eq:internal-amplitude}
A(f_1,-p_1,f_2,-p_2,\bar f_3,p_3,\bar f_4,p_4,\ldots)
\end{equation}
\end{subequations}
- The correspondence of vertex and term in the lagrangian
+ Indeed, the vertex and corresponding term in the lagrangian
\begin{equation}
\parbox{26\unitlength}{%
\fmfframe(5,3)(5,3){%
\begin{fmfgraph*}(15,20)
\fmfleft{v}
\fmfright{p,A,e}
\fmflabel{$\mathrm{e}^-$}{e}
\fmflabel{$\mathrm{e}^+$}{p}
\fmflabel{$\mathrm{A}$}{A}
\fmf{fermion}{p,v,e}
\fmf{photon}{A,v}
\fmfdot{v}
\end{fmfgraph*}}}: \bar\psi\fmslash{A}\psi
\end{equation}
suggests to denote the \emph{outgoing} particle by the flavor of the
\emph{anti}particle and the \emph{outgoing} \emph{anti}particle by the
flavor of the particle, since this choice allows to represent the vertex
by a triple
\begin{equation}
\bar\psi\fmslash{A}\psi: (\mathrm{e}^+,A,\mathrm{e}^-)
\end{equation}
which is more intuitive than the alternative $(\mathrm{e}^-,A,\mathrm{e}^+)$.
Also, when thinking in terms of building wavefunctions from the outside in,
the outgoing \emph{antiparticle} is represented by a \emph{particle}
propagator and vice versa\footnote{Even if this choice will appear slightly
counter-intuitive on the [Target] side, one must keep in mind that much more
people are expected to prepare [Model]s.}.
- [incoming] and [outgoing] are the physical flavors as
- in~(\ref{eq:physical-amplitude}) *)
+ Note that [incoming] and [outgoing] are the physical flavors as
+ in~(\ref{eq:physical-amplitude}) or in the argument of [amplitudes],
+ but with the color flow quantum numbers added. *)
val incoming : amplitude -> flavor list
val outgoing : amplitude -> flavor list
-(* [externals] are flavors and momenta as in~(\ref{eq:internal-amplitude}) *)
+(* In contrast, [externals] are flavors and momenta as
+ in~(\ref{eq:internal-amplitude}) *)
val externals : amplitude -> wf list
+(* Return all off-shell wave functions so that [Target] can allocate
+ variables for them. *)
val variables : amplitude -> wf list
+
+(* Return all [fusion]s in an order so that all right hand sides
+ have been computed before they are used. *)
val fusions : amplitude -> fusion list
- val brakets : amplitude -> braket list
- val on_shell : amplitude -> (wf -> bool)
- val is_gauss : amplitude -> (wf -> bool)
+
+(* Return all [braket]s. *)
+ type 'a slices
+ val brakets : amplitude -> braket list slices
+
+(* Test if an off-shell wave function has been forced on-shell
+ or is smeared as as gaussian. *)
+ val on_shell : amplitude -> wf -> bool
+ val is_gauss : amplitude -> wf -> bool
+
+(* Describe the constraints in the [selectors] argument to [amplitudes]. *)
val constraints : amplitude -> string option
- val symmetry : amplitude -> int
- val allowed : amplitude -> bool
+(* Human readable description of the requested slicings of type [Orders.Conditions.t] *)
+ val slicings : amplitude -> string list
-(*i
-(* \thocwmodulesubsection{Performance Hacks} *)
+(* Compute the symmetry factor $\prod_i n_i!$ for identical outgoing
+ particles. *)
+ val symmetry : amplitude -> int
- val initialize_cache : string -> unit
- val set_cache_name : string -> unit
-i*)
+(* Quickly test whether an amplitude vanishes. *)
+ val allowed : amplitude -> bool
(* \thocwmodulesubsection{Diagnostics} *)
+(* Compute a list of all charge conservation violating vertices in the [Model]. *)
val check_charges : unit -> flavor_sans_color list list
+
+(* Count the fusions and propagators that are computed and compare
+ to the number of Feynman diagrams appearing in the amplitude. *)
val count_fusions : amplitude -> int
val count_propagators : amplitude -> int
val count_diagrams : amplitude -> int
+(* Expand the [DAG] beneath an off-shell wave function into the corresponding
+ forest. \textit{Use with caution for complicated processes!} *)
val forest : wf -> amplitude -> ((wf * coupling option, wf) Tree.t) list
+
+(* A list of all combinations of off-shell wave functions in the
+ Feynman diagrams described by the [DAG]. This could be used for
+ phase space mappings, but lies dormant at the moment.
+ \begin{dubious}
+ At the moment, the result contains empty lists and many
+ redundancies. This should be cleaned up!
+ \end{dubious} *)
val poles : amplitude -> wf list list
+
+(* A list of all $s$-channel poles in the [DAG]. Helpful
+ for phase space mappings and for fudging widths. *)
val s_channel : amplitude -> wf list
+(* Prepare \texttt{.dot} files as input fot \texttt{graphviz}
+ to draw graphical representations of the tower of of-shell
+ wavefunctions and the dag corresponding to the amplitude. *)
val tower_to_dot : out_channel -> amplitude -> unit
val amplitude_to_dot : out_channel -> amplitude -> unit
(* \thocwmodulesubsection{WHIZARD} *)
+(* Phase space descriptions for \texttt{WHIZARD}. Once as written
+ and once with the incoming particles exchanged. This way
+ we can write a tree starting from the first and one from
+ the second incoming particle. *)
val phase_space_channels : out_channel -> amplitude_sans_color -> unit
val phase_space_channels_flipped : out_channel -> amplitude_sans_color -> unit
end
-(* There is more than one way to make fusions. *)
+(* \thocwmodulesection{Various Functors generating [Fusion.T]} *)
+
+(* There is more than one way to make fusions, differing in the
+ unterlying topology of diagrams. *)
module type Maker =
functor (P : Momentum.T) -> functor (M : Model.T) ->
T with type p = P.t
- and type flavor = Colorize.It(M).flavor
+ and type flavor = Orders.Slice(Colorize.It(M)).flavor
+ and type flavor_all_orders = Colorize.It(M).flavor
and type flavor_sans_color = M.flavor
and type constant = M.constant
and type selectors = Cascade.Make(M)(P).selectors
+ and type slicings = Orders.Conditions(Colorize.It(M)).t
+ and type 'a slices = (Orders.Slice(Colorize.It(M)).orders * 'a) list
(*i If we want or need to expose [Make], here's how to do it:
module type Stat =
sig
type flavor
type stat
exception Impossible
val stat : flavor -> int -> stat
val stat_fuse : stat -> stat -> flavor -> stat
val stat_sign : stat -> int
end
module type Stat_Maker = functor (M : Model.T) ->
Stat with type flavor = M.flavor
module Make : functor (PT : Tuple.Poly) (Stat : Stat_Maker)
(T : Topology.T with type 'a children = 'a PT.t) -> Maker
i*)
(* Straightforward Dirac fermions vs. slightly more complicated
Majorana fermions: *)
exception Majorana
module Binary : Maker
module Binary_Majorana : Maker
module Mixed23 : Maker
module Mixed23_Majorana : Maker
module Nary : functor (B : Tuple.Bound) -> Maker
module Nary_Majorana : functor (B : Tuple.Bound) -> Maker
(* We can also proceed \'a la~\cite{HELAC:2000}. Empirically,
this will use slightly~($O(10\%)$) fewer fusions than the
symmetric factorization. Our implementation uses
significantly~($O(50\%)$) fewer fusions than reported
by~\cite{HELAC:2000}. Our pruning of the DAG might
be responsible for this. *)
module Helac_Binary : Maker
module Helac_Binary_Majorana : Maker
module Helac_Mixed23 : Maker
module Helac_Mixed23_Majorana : Maker
module Helac : functor (B : Tuple.Bound) -> Maker
module Helac_Majorana : functor (B : Tuple.Bound) -> Maker
(* \thocwmodulesection{Multiple Amplitudes} *)
module type Multi =
sig
exception Mismatch
val options : Options.t
type flavor
type process = flavor list * flavor list
type amplitude
type fusion
type wf
- type exclusions
- val no_exclusions : exclusions
type selectors
+ type slicings
+ type coupling_order
type amplitudes
(* Construct all possible color flow amplitudes for a given process. *)
val amplitudes : bool -> int option ->
- exclusions -> selectors -> process list -> amplitudes
+ selectors -> slicings option -> process list -> amplitudes
val empty : amplitudes
-(*i
- (* Precompute the vertex table cache. *)
- val initialize_cache : string -> unit
- val set_cache_name : string -> unit
-i*)
-
(* The list of all combinations of incoming and outgoing particles
with a nonvanishing scattering amplitude. *)
val flavors : amplitudes -> process list
(* The list of all combinations of incoming and outgoing particles that
don't lead to any color flow with non vanishing scattering amplitude. *)
val vanishing_flavors : amplitudes -> process list
(* The list of all color flows with a nonvanishing scattering amplitude. *)
val color_flows : amplitudes -> Color.Flow.t list
+ (* The coupling orders that are not summed over and their powers. *)
+ val coupling_orders : amplitudes -> (coupling_order list * int list list) option
+
(* The list of all valid helicity combinations. *)
val helicities : amplitudes -> (int list * int list) list
(* The list of all amplitudes. *)
val processes : amplitudes -> amplitude list
(* [(process_table a).(f).(c)] returns the amplitude for the [f]th
allowed flavor combination and the [c]th allowed color flow as
an [amplitude option]. *)
val process_table : amplitudes -> amplitude option array array
+ (* [(process_table a).(co).(f).(c)] returns the amplitude for
+ the [o]th set of coupling orders, the [f]th
+ allowed flavor combination and the [c]th allowed color flow
+ as an [amplitude option]. *)
+ val process_table_new : amplitudes -> amplitude option array array array
+
(* The list of all non redundant fusions together with the amplitudes
they came from. *)
val fusions : amplitudes -> (fusion * amplitude) list
(* If there's more than external flavor state, the wavefunctions are
\emph{not} uniquely specified by [flavor] and [Momentum.t]. This
function can be used to determine how many variables must be allocated. *)
val multiplicity : amplitudes -> wf -> int
(* This function can be used to disambiguate wavefunctions with the same
combination of [flavor] and [Momentum.t]. *)
val dictionary : amplitudes -> amplitude -> wf -> int
(* [(color_factors a).(c1).(c2)] power of~$N_C$ for the given product
of color flows. *)
val color_factors : amplitudes -> Color.Flow.factor array array
(* A description of optional diagram selectors. *)
val constraints : amplitudes -> string option
+ (* Human readable description of the requested slicings of type [Orders.Conditions.t]. *)
+ val slicings : amplitudes -> string list
+
end
module type Multi_Maker = functor (Fusion_Maker : Maker) ->
functor (P : Momentum.T) ->
functor (M : Model.T) ->
Multi with type flavor = M.flavor
and type amplitude = Fusion_Maker(P)(M).amplitude
and type fusion = Fusion_Maker(P)(M).fusion
and type wf = Fusion_Maker(P)(M).wf
and type selectors = Fusion_Maker(P)(M).selectors
+ and type slicings = Orders.Conditions(Colorize.It(M)).t
+ and type coupling_order = Orders.Slice(Colorize.It(M)).coupling_order
module Multi : Multi_Maker
-(* \thocwmodulesection{Tags} *)
-
-(* It appears that there are useful applications for tagging couplings
- and wave functions, e.\,g.~skeleton expansion and diagram selections.
- We can abstract this in a [Tags] signature: *)
-
-module type Tags =
- sig
- type wf
- type coupling
- type 'a children
- val null_wf : wf
- val null_coupling : coupling
- val fuse : coupling -> wf children -> wf
- val wf_to_string : wf -> string option
- val coupling_to_string : coupling -> string option
- end
-
-module type Tagger =
- functor (PT : Tuple.Poly) -> Tags with type 'a children = 'a PT.t
-
-module type Tagged_Maker =
- functor (Tagger : Tagger) ->
- functor (P : Momentum.T) -> functor (M : Model.T) ->
- T with type p = P.t
- and type flavor = Colorize.It(M).flavor
- and type flavor_sans_color = M.flavor
- and type constant = M.constant
-
-module Tagged_Binary : Tagged_Maker
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/vertex.ml
===================================================================
--- trunk/omega/src/vertex.ml (revision 8899)
+++ trunk/omega/src/vertex.ml (revision 8900)
@@ -1,1699 +1,1695 @@
(* vertex.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-(* Avoid refering to [Pervasives.compare], because [Pervasives] will
- become [Stdlib.Pervasives] in O'Caml 4.07 and [Stdlib] in O'Caml 4.08. *)
-let pcompare = compare
-
module type Test =
sig
val example : unit -> unit
val suite : OUnit.test
end
(* \thocwmodulesection{New Implementation: Next Version} *)
let error_in_string text start_pos end_pos =
let i = start_pos.Lexing.pos_cnum
and j = end_pos.Lexing.pos_cnum in
String.sub text i (j - i)
let error_in_file name start_pos end_pos =
Printf.sprintf
"%s:%d.%d-%d.%d"
name
start_pos.Lexing.pos_lnum
(start_pos.Lexing.pos_cnum - start_pos.Lexing.pos_bol)
end_pos.Lexing.pos_lnum
(end_pos.Lexing.pos_cnum - end_pos.Lexing.pos_bol)
let parse_string text =
Vertex_syntax.File.expand_includes
(fun file -> invalid_arg ("parse_string: found include `" ^ file ^ "'"))
(try
Vertex_parser.file
Vertex_lexer.token
(Vertex_lexer.init_position "" (Lexing.from_string text))
with
| Vertex_syntax.Syntax_Error (msg, start_pos, end_pos) ->
invalid_arg (Printf.sprintf "syntax error (%s) at: `%s'"
msg (error_in_string text start_pos end_pos))
| Parsing.Parse_error ->
invalid_arg ("parse error: " ^ text))
let parse_file name =
let parse_file_tree name =
let ic = open_in name in
let file_tree =
begin try
Vertex_parser.file
Vertex_lexer.token
(Vertex_lexer.init_position name (Lexing.from_channel ic))
with
| Vertex_syntax.Syntax_Error (msg, start_pos, end_pos) ->
begin
close_in ic;
invalid_arg (Printf.sprintf
"%s: syntax error (%s)"
(error_in_file name start_pos end_pos) msg)
end
| Parsing.Parse_error ->
begin
close_in ic;
invalid_arg ("parse error: " ^ name)
end
end in
close_in ic;
file_tree in
Vertex_syntax.File.expand_includes parse_file_tree (parse_file_tree name)
let dump_file pfx f =
List.iter
(fun s -> print_endline (pfx ^ ": " ^ s))
(Vertex_syntax.File.to_strings f)
module Parser_Test : Test =
struct
let example () =
()
open OUnit
let compare s_out s_in () =
assert_equal ~printer:(String.concat " ")
[s_out] (Vertex_syntax.File.to_strings (parse_string s_in))
let parse_error error s () =
assert_raises (Invalid_argument error) (fun () -> parse_string s)
let syntax_error (msg, error) s () =
parse_error ("syntax error (" ^ msg ^ ") at: `" ^ error ^ "'") s ()
let (=>) s_in s_out =
" " ^ s_in >:: compare s_out s_in
let (?>) s =
s => s
let (=>!!!) s error =
" " ^ s >:: parse_error error s
let (=>!) s error =
" " ^ s >:: syntax_error error s
let empty =
"empty" >::
(fun () -> assert_equal [] (parse_string ""))
let expr =
"expr" >:::
[ "\\vertex[2 * (17 + 4)]{}" => "\\vertex[42]{{}}";
"\\vertex[2 * 17 + 4]{}" => "\\vertex[38]{{}}";
"\\vertex[2" =>! ("missing `]'", "[2");
"\\vertex]{}" =>! ("expected `[' or `{'", "\\vertex]");
"\\vertex2]{}" =>! ("expected `[' or `{'", "\\vertex2");
"\\vertex}{}" =>! ("expected `[' or `{'", "\\vertex}");
"\\vertex2}{}" =>! ("expected `[' or `{'", "\\vertex2");
"\\vertex[(2}{}" =>! ("expected `)', found `}'", "(2}");
"\\vertex[(2]{}" =>! ("expected `)', found `]'", "(2]");
"\\vertex{2]{}" =>! ("syntax error", "2");
"\\vertex[2}{}" =>! ("expected `]', found `}'", "[2}");
"\\vertex[2{}" =>! ("syntax error", "2");
"\\vertex[2*]{}" =>! ("syntax error", "2") ]
let index =
"index" >:::
[ "\\vertex{{a}_{1}^{2}}" => "\\vertex{a^2_1}";
"\\vertex{a_{11}^2}" => "\\vertex{a^2_{11}}";
"\\vertex{a_{1_1}^2}" => "\\vertex{a^2_{1_1}}" ]
let electron1 =
"electron1" >:::
[ ?> "\\charged{e^-}{e^+}";
"\\charged{{e^-}}{{e^+}}" => "\\charged{e^-}{e^+}" ]
let electron2 =
"electron2" >:::
[ "\\charged{e^-}{e^+}\\fortran{ele}" =>
"\\charged{e^-}{e^+}\\fortran{{ele}}";
"\\charged{e^-}{e^+}\\fortran{electron}\\fortran{ele}" =>
"\\charged{e^-}{e^+}\\fortran{{ele}}\\fortran{{electron}}";
"\\charged{e^-}{e^+}\\alias{e2}\\alias{e1}" =>
"\\charged{e^-}{e^+}\\alias{{e1}}\\alias{{e2}}";
"\\charged{e^-}{e^+}\\fortran{ele}\\anti\\fortran{pos}" =>
"\\charged{e^-}{e^+}\\fortran{{ele}}\\anti\\fortran{{pos}}" ]
let particles =
"particles" >:::
[electron1;
electron2]
let parameters =
"parameters" >:::
[ ?> "\\parameter{\\alpha}{1/137}";
?> "\\derived{\\alpha_s}{1/\\ln{\\frac{\\mu}{\\Lambda}}}";
"\\parameter{\\alpha}{1/137}\\anti\\fortran{alpha}" =>!
("invalid parameter attribute", "\\anti") ]
let indices =
"indices" >:::
[ ?> "\\index{a}\\color{8}";
"\\index{a}\\color[SU(2)]{3}" => "\\index{a}\\color[{SU(2)}]{3}" ]
let tensors =
"tensors" >:::
[ "\\tensor{T}\\color{3}" => "\\tensor{T}\\color{3}"]
let vertices =
"vertex" >:::
[ "\\vertex{\\bar\\psi\\gamma_\\mu\\psi A_\\mu}" =>
"\\vertex{{{\\bar\\psi\\gamma_\\mu\\psi A_\\mu}}}" ]
module T = Vertex_syntax.Token
let parse_token s =
match parse_string ("\\vertex{" ^ s ^ "}") with
| [Vertex_syntax.File.Vertex (_, v)] -> v
| _ -> invalid_arg "only_vertex"
let print_token pfx t =
print_endline (pfx ^ ": " ^ T.to_string t)
let test_stem s_out s_in () =
assert_equal ~printer:T.to_string
(parse_token s_out)
(T.stem (parse_token s_in))
let (=>>) s_in s_out =
"stem " ^ s_in >:: test_stem s_out s_in
let tokens =
"tokens" >:::
[ "\\vertex{a'}" => "\\vertex{a^\\prime}";
"\\vertex{a''}" => "\\vertex{a^{\\prime\\prime}}";
"\\bar\\psi''_{i,\\alpha}" =>> "\\psi";
"\\phi^\\dagger_{i'}" =>> "\\phi";
"\\bar{\\phi\\psi}''_{i,\\alpha}" =>> "\\psi";
"\\vertex{\\phi}" => "\\vertex{\\phi}";
"\\vertex{\\phi_1}" => "\\vertex{\\phi_1}";
"\\vertex{{{\\phi}'}}" => "\\vertex{\\phi^\\prime}";
"\\vertex{\\hat{\\bar\\psi}_1}" => "\\vertex{\\hat\\bar\\psi_1}";
"\\vertex{{a_b}_{cd}}" => "\\vertex{a_{bcd}}";
"\\vertex{{\\phi_1}_2}" => "\\vertex{\\phi_{12}}";
"\\vertex{{\\phi_{12}}_{34}}" => "\\vertex{\\phi_{1234}}";
"\\vertex{{\\phi_{12}}^{34}}" => "\\vertex{\\phi^{34}_{12}}";
"\\vertex{\\bar{\\psi_{\\mathrm{e}}}_\\alpha\\gamma_{\\alpha\\beta}^\\mu{\\psi_{\\mathrm{e}}}_\\beta}" =>
"\\vertex{{{\\bar\\psi_{\\mathrm e\\alpha}\\gamma^\\mu_{\\alpha\\beta}\\psi_{\\mathrm e\\beta}}}}"]
let suite =
"Vertex_Parser" >:::
[empty;
index;
expr;
particles;
parameters;
indices;
tensors;
vertices;
tokens ]
end
(* \thocwmodulesubsection{Symbol Tables} *)
module type Symbol =
sig
type file = Vertex_syntax.File.t
type t = Vertex_syntax.Token.t
(* Tensors and their indices are representations of
color, flavor or Lorentz groups. In the end it might
turn out to be unnecessary to distinguish [Color] from
[Flavor]. *)
type space =
| Color of Vertex_syntax.Lie.t
| Flavor of t list * t list
| Lorentz of t list
(* A symbol (i.\,e.~a [Symbol.t = Vertex_syntax.Token.t])
can refer either to particles, to parameters (derived and input)
or to tensors and indices. *)
type kind =
| Neutral
| Charged
| Anti
| Parameter
| Derived
| Index of space
| Tensor of space
type table
val load : file -> table
val dump : out_channel -> table -> unit
(* Look up the [kind] of a symbol. *)
val kind_of_symbol : table -> t -> kind option
(* Look up the [kind] of a symbol's stem. *)
val kind_of_stem : table -> t -> kind option
(* Look up the [kind] of a symbol and fall back to the
[kind] of the symbol's stem, if necessary. *)
val kind_of_symbol_or_stem : table -> t -> kind option
(* A table to look up all symbols with the same [stem]. *)
val common_stem : table -> t -> t list
exception Missing_Space of t
exception Conflicting_Space of t
end
module Symbol : Symbol =
struct
module T = Vertex_syntax.Token
module F = Vertex_syntax.File
module P = Vertex_syntax.Particle
module I = Vertex_syntax.Index
module L = Vertex_syntax.Lie
module Q = Vertex_syntax.Parameter
module X = Vertex_syntax.Tensor
type file = F.t
type t = T.t
type space =
| Color of L.t
| Flavor of t list * t list
| Lorentz of t list
let space_to_string = function
| Color (g, r) ->
"color:" ^ L.group_to_string g ^ ":" ^ L.rep_to_string r
| Flavor (_, _) -> "flavor"
| Lorentz _ -> "Lorentz"
type kind =
| Neutral
| Charged
| Anti
| Parameter
| Derived
| Index of space
| Tensor of space
let kind_to_string = function
| Neutral -> "neutral particle"
| Charged -> "charged particle"
| Anti -> "charged anti particle"
| Parameter -> "input parameter"
| Derived -> "derived parameter"
| Index space -> space_to_string space ^ " index"
| Tensor space -> space_to_string space ^ " tensor"
module ST = Map.Make (T)
module SS = Set.Make (T)
type table =
{ symbol_kinds : kind ST.t;
stem_kinds : kind ST.t;
common_stems : SS.t ST.t }
let empty =
{ symbol_kinds = ST.empty;
stem_kinds = ST.empty;
common_stems = ST.empty }
let kind_of_symbol table token =
try Some (ST.find token table.symbol_kinds) with Not_found -> None
let kind_of_stem table token =
try
Some (ST.find (T.stem token) table.stem_kinds)
with
| Not_found -> None
let kind_of_symbol_or_stem symbol_table token =
match kind_of_symbol symbol_table token with
| Some _ as kind -> kind
| None -> kind_of_stem symbol_table token
let common_stem table token =
try
SS.elements (ST.find (T.stem token) table.common_stems)
with
| Not_found -> []
let add_symbol_kind table token kind =
try
let old_kind = ST.find token table in
if kind = old_kind then
table
else
invalid_arg ("conflicting symbol kind: " ^
T.to_string token ^ " -> " ^
kind_to_string kind ^ " vs " ^
kind_to_string old_kind)
with
| Not_found -> ST.add token kind table
let add_stem_kind table token kind =
let stem = T.stem token in
try
let old_kind = ST.find stem table in
if kind = old_kind then
table
else begin
match kind, old_kind with
| Charged, Anti -> ST.add stem Charged table
| Anti, Charged -> table
| _, _ ->
invalid_arg ("conflicting stem kind: " ^
T.to_string token ^ " -> " ^
T.to_string stem ^ " -> " ^
kind_to_string kind ^ " vs " ^
kind_to_string old_kind)
end
with
| Not_found -> ST.add stem kind table
let add_kind table token kind =
{ table with
symbol_kinds = add_symbol_kind table.symbol_kinds token kind;
stem_kinds = add_stem_kind table.stem_kinds token kind }
let add_stem table token =
let stem = T.stem token in
let set =
try
ST.find stem table.common_stems
with
| Not_found -> SS.empty in
{ table with
common_stems = ST.add stem (SS.add token set) table.common_stems }
(* Go through the list of attributes, make sure that
the [space] is declared and unique. Return the space. *)
exception Missing_Space of t
exception Conflicting_Space of t
let group_rep_of_tokens group rep =
let group =
match group with
| [] -> L.default_group
| group -> L.group_of_string (T.list_to_string group) in
Color (group, L.rep_of_string group (T.list_to_string rep))
let index_space index =
let spaces =
List.fold_left
(fun acc -> function
| I.Color (group, rep) -> group_rep_of_tokens group rep :: acc
| I.Flavor (group, rep) -> Flavor (rep, group) :: acc
| I.Lorentz t -> Lorentz t :: acc)
[] index.I.attr in
match ThoList.uniq (List.sort compare spaces) with
| [space] -> space
| [] -> raise (Missing_Space index.I.name)
| _ -> raise (Conflicting_Space index.I.name)
let tensor_space tensor =
let spaces =
List.fold_left
(fun acc -> function
| X.Color (group, rep) -> group_rep_of_tokens rep group :: acc
| X.Flavor (group, rep) -> Flavor (rep, group) :: acc
| X.Lorentz t -> Lorentz t :: acc)
[] tensor.X.attr in
match ThoList.uniq (List.sort compare spaces) with
| [space] -> space
| [] -> raise (Missing_Space tensor.X.name)
| _ -> raise (Conflicting_Space tensor.X.name)
(* NB: if [P.Charged (name, name)] below, only
the [Charged] will survive, [Anti] will be shadowed. *)
let insert_kind table = function
| F.Particle p ->
begin match p.P.name with
| P.Neutral name -> add_kind table name Neutral
| P.Charged (name, anti) ->
add_kind (add_kind table anti Anti) name Charged
end
| F.Index i -> add_kind table i.I.name (Index (index_space i))
| F.Tensor t -> add_kind table t.X.name (Tensor (tensor_space t))
| F.Parameter p ->
begin match p with
| Q.Parameter name -> add_kind table name.Q.name Parameter
| Q.Derived name -> add_kind table name.Q.name Derived
end
| F.Vertex _ -> table
let insert_stem table = function
| F.Particle p ->
begin match p.P.name with
| P.Neutral name -> add_stem table name
| P.Charged (name, anti) -> add_stem (add_stem table name) anti
end
| F.Index i -> add_stem table i.I.name
| F.Tensor t -> add_stem table t.X.name
| F.Parameter p ->
begin match p with
| Q.Parameter name
| Q.Derived name -> add_stem table name.Q.name
end
| F.Vertex _ -> table
let insert table token =
insert_stem (insert_kind table token) token
let load decls =
List.fold_left insert empty decls
let dump oc table =
Printf.fprintf oc "<<< Symbol Table: >>>\n";
ST.iter
(fun s k ->
Printf.fprintf oc "%s -> %s\n" (T.to_string s) (kind_to_string k))
table.symbol_kinds;
Printf.fprintf oc "<<< Stem Table: >>>\n";
ST.iter
(fun s k ->
Printf.fprintf oc "%s -> %s\n" (T.to_string s) (kind_to_string k))
table.stem_kinds;
Printf.fprintf oc "<<< Common Stems: >>>\n";
ST.iter
(fun stem symbols ->
Printf.fprintf
oc "%s -> %s\n"
(T.to_string stem)
(String.concat
", " (List.map T.to_string (SS.elements symbols))))
table.common_stems
end
(* \thocwmodulesubsection{Declarations} *)
module type Declaration =
sig
type t
val of_string : string -> t list
val to_string : t list -> string
(* For testing and debugging *)
val of_string_and_back : string -> string
val count_indices : t -> (int * Symbol.t) list
val indices_ok : t -> unit
end
module Declaration : Declaration =
struct
module S = Symbol
module T = Vertex_syntax.Token
type factor =
{ stem : T.t;
prefix : T.prefix list;
particle : T.t list;
color : T.t list;
flavor : T.t list;
lorentz : T.t list;
other : T.t list }
type t = factor list
let factor_stem token =
{ stem = token.T.stem;
prefix = token.T.prefix;
particle = [];
color = [];
flavor = [];
lorentz = [];
other = [] }
let rev factor =
{ stem = factor.stem;
prefix = List.rev factor.prefix;
particle = List.rev factor.particle;
color = List.rev factor.color;
flavor = List.rev factor.flavor;
lorentz = List.rev factor.lorentz;
other = List.rev factor.other }
let factor_add_prefix factor token =
{ factor with prefix = T.prefix_of_string token :: factor.prefix }
let factor_add_particle factor token =
{ factor with particle = token :: factor.particle }
let factor_add_color_index t factor token =
{ factor with color = token :: factor.color }
let factor_add_lorentz_index t factor token =
(* diagnostics: [Printf.eprintf "[L:[%s]]\n" (T.to_string token);] *)
{ factor with lorentz = token :: factor.lorentz }
let factor_add_flavor_index t factor token =
{ factor with flavor = token :: factor.flavor }
let factor_add_other_index factor token =
{ factor with other = token :: factor.other }
let factor_add_kind factor token = function
| S.Neutral | S.Charged | S.Anti -> factor_add_particle factor token
| S.Index (S.Color (rep, group)) ->
factor_add_color_index (rep, group) factor token
| S.Index (S.Flavor (rep, group)) ->
factor_add_flavor_index (rep, group) factor token
| S.Index (S.Lorentz t) -> factor_add_lorentz_index t factor token
| S.Tensor _ -> invalid_arg "factor_add_index: \\tensor"
| S.Parameter -> invalid_arg "factor_add_index: \\parameter"
| S.Derived -> invalid_arg "factor_add_index: \\derived"
let factor_add_index symbol_table factor = function
| T.Token "," -> factor
| T.Token ("*" | "\\ast" as star) -> factor_add_prefix factor star
| token ->
begin
match S.kind_of_symbol_or_stem symbol_table token with
| Some kind -> factor_add_kind factor token kind
| None -> factor_add_other_index factor token
end
let factor_of_token symbol_table token =
let token = T.wrap_scripted token in
rev (List.fold_left
(factor_add_index symbol_table)
(factor_stem token)
(token.T.super @ token.T.sub))
let list_to_string tag = function
| [] -> ""
| l -> "; " ^ tag ^ "=" ^ String.concat "," (List.map T.to_string l)
let factor_to_string factor =
"[" ^ T.to_string factor.stem ^
(match factor.prefix with
| [] -> ""
| l -> "; prefix=" ^
String.concat "," (List.map T.prefix_to_string l)) ^
list_to_string "particle" factor.particle ^
list_to_string "color" factor.color ^
list_to_string "flavor" factor.flavor ^
list_to_string "lorentz" factor.lorentz ^
list_to_string "other" factor.other ^ "]"
let count_indices factors =
ThoList.classify
(ThoList.flatmap (fun f -> f.color @ f.flavor @ f.lorentz) factors)
let format_mismatch (n, index) =
Printf.sprintf "index %s appears %d times" (T.to_string index) n
let indices_ok factors =
match List.filter (fun (n, _) -> n <> 2) (count_indices factors) with
| [] -> ()
| mismatches ->
invalid_arg (String.concat ", " (List.map format_mismatch mismatches))
let of_string s =
let decls = parse_string s in
let symbol_table = Symbol.load decls in
(* diagnostics: [Symbol.dump stderr symbol_table;] *)
let tokens =
List.fold_left
(fun acc -> function
| Vertex_syntax.File.Vertex (_, v) -> T.wrap_list v :: acc
| _ -> acc)
[] decls in
let vlist = List.map (List.map (factor_of_token symbol_table)) tokens in
List.iter indices_ok vlist;
vlist
let to_string decls =
String.concat "; "
(List.map
(fun v -> String.concat " * " (List.map factor_to_string v))
decls)
let of_string_and_back s =
to_string (of_string s)
type field =
{ name : T.t list }
end
(* \thocwmodulesubsection{Complete Models} *)
module Modelfile =
struct
end
module Modelfile_Test =
struct
let example () =
()
open OUnit
let index_mismatches =
"index mismatches" >:::
[ "1" >::
(fun () ->
assert_raises
(Invalid_argument "index a_1 appears 1 times, \
index a_2 appears 1 times")
(fun () -> Declaration.of_string_and_back
"\\index{a}\\color{3}\
\\vertex{\\bar\\psi_{a_1}\\psi_{a_2}}"));
"3" >::
(fun () ->
assert_raises
(Invalid_argument "index a appears 3 times")
(fun () -> Declaration.of_string_and_back
"\\index{a}\\color{3}\
\\vertex{\\bar\\psi_a\\psi_a\\phi_a}")) ]
let kind_conflicts =
"kind conflictings" >:::
[ "lorentz / color" >::
(fun () ->
assert_raises
(Invalid_argument
"conflicting stem kind: a_2 -> a -> \
Lorentz index vs color:SU(3):3 index")
(fun () -> Declaration.of_string_and_back
"\\index{a_1}\\color{3}\
\\index{a_2}\\lorentz{X}"));
"color / color" >::
(fun () ->
assert_raises
(Invalid_argument
"conflicting stem kind: a_2 -> a -> \
color:SU(3):8 index vs color:SU(3):3 index")
(fun () -> Declaration.of_string_and_back
"\\index{a_1}\\color{3}\
\\index{a_2}\\color{8}"));
"neutral / charged" >::
(fun () ->
assert_raises
(Invalid_argument
"conflicting stem kind: H^- -> H -> \
charged anti particle vs neutral particle")
(fun () -> Declaration.of_string_and_back
"\\neutral{H}\
\\charged{H^+}{H^-}")) ]
let suite =
"Modelfile_Test" >:::
[ "ok" >::
(fun () ->
assert_equal ~printer:(fun s -> s)
"[\\psi; prefix=\\bar; \
particle=e; color=a; lorentz=\\alpha_1] * \
[\\gamma; lorentz=\\mu,\\alpha_1,\\alpha_2] * \
[\\psi; particle=e; color=a; lorentz=\\alpha_2] * \
[A; lorentz=\\mu]"
(Declaration.of_string_and_back
"\\charged{e^-}{e^+}\
\\index{a}\\color{\\bar3}\
\\index{b}\\color[SU(3)]{8}\
\\index{\\mu}\\lorentz{X}\
\\index{\\alpha}\\lorentz{X}\
\\vertex{\\bar{\\psi_e}_{a,\\alpha_1}\
\\gamma^\\mu_{\\alpha_1\\alpha_2}\
{\\psi_e}_{a,\\alpha_2}A_\\mu}"));
index_mismatches;
kind_conflicts;
"QCD.omf" >::
(fun () ->
dump_file "QCD" (parse_file "QCD.omf"));
"SM.omf" >::
(fun () ->
dump_file "SM" (parse_file "SM.omf"));
"SM-error.omf" >::
(fun () ->
assert_raises
(Invalid_argument
"SM-error.omf:32.22-32.27: syntax error (syntax error)")
(fun () -> parse_file "SM-error.omf"));
"cyclic.omf" >::
(fun () ->
assert_raises
(Invalid_argument "cyclic \\include{cyclic.omf}")
(fun () -> parse_file "cyclic.omf")) ]
end
(* \thocwmodulesection{New Implementation: Obsolete Version~1} *)
(* Start of version 1 of the new implementation. The old syntax
will not be used in the real implementation, but the library
for dealing with indices and permutations will remail important. *)
(* Note that [arity = length lorentz_reps = length color_reps]. Do we
need to enforce this by an abstract type constructor?
A cleaner approach would be
[type context = (Coupling.lorentz, Color.t) array], but it would also
require more tedious deconstruction of the pairs. Well, an abstract
type with accessors might be the way to go after all \ldots *)
type context =
{ arity : int;
lorentz_reps : Coupling.lorentz array;
color_reps : Color.t array }
let distinct2 i j =
i <> j
let distinct3 i j k =
i <> j && j <> k && k <> i
let distinct ilist =
List.length (ThoList.uniq (List.sort compare ilist)) =
List.length ilist
(* An abstract type that allows us to distinguish offsets
in the field array from color and Lorentz indices in
different representations. *)
module type Index =
sig
type t
val of_int : int -> t
val to_int : t -> int
end
(* While the number of allowed indices is unlimited, the
allowed offsets into the field arrays are of course
restricted to the fields in the current [context]. *)
module type Field =
sig
type t
exception Out_of_range of int
val of_int : context -> int -> t
val to_int : t -> int
val get : 'a array -> t -> 'a
end
module Field : Field =
struct
type t = int
exception Out_of_range of int
let of_int context i =
if 0 <= i && i < context.arity then
i
else
raise (Out_of_range i)
let to_int i = 0
let get = Array.get
end
type field = Field.t
module type Lorentz =
sig
(* We combine indices~[I] and offsets~[F] into the field array
into a single type so that we can unify vectors with vector
components. *)
type index = I of int | F of field
type vector = Vector of index
type spinor = Spinor of index
type conjspinor = ConjSpinor of index
(* These are all the primitive ways to construct Lorentz tensors,
a.\,k.\,a.~objects with Lorentz indices, from momenta, other
Lorentz tensors and Dirac spinors: *)
type primitive =
| G of vector * vector (* $g_{\mu_1\mu_2}$ *)
| E of vector * vector * vector * vector (* $\epsilon_{\mu_1\mu_2\mu_3\mu_4}$ *)
| K of vector * field (* $k_{2}^{\mu_1}$ *)
| S of conjspinor * spinor (* $\bar\psi_1\psi_2$ *)
| V of vector * conjspinor * spinor (* $\bar\psi_1\gamma_{\mu_2}\psi_3$ *)
| T of vector * vector * conjspinor * spinor (* $\bar\psi_1\sigma_{\mu_2\mu_3}\psi_4$ *)
| A of vector * conjspinor * spinor (* $\bar\psi_1\gamma_{\mu_2}\gamma_5\psi_3$ *)
| P of conjspinor * spinor (* $\bar\psi_1\gamma_5\psi_2$ *)
type tensor = int * primitive list
(* Below, we will need to permute fields. For this purpose, we
introduce the function
[map_primitive v_idx v_fld s_idx s_fld c_idx c_fld tensor]
that returns a structurally identical tensor, with
[v_idx : int -> int] applied to all vector indices,
[v_fld : field -> field] to all vector fields,
[s_idx] and [c_idx] to all (conj)spinor indices and
[s_fld] and [c_fld] to all (conj)spinor fields.
Note we must treat spinors and vectors differently,
even for simple permuations, in order to handle the
statistics properly. *)
val map_tensor :
(int -> int) -> (field -> field) -> (int -> int) -> (field -> field) ->
(int -> int) -> (field -> field) -> tensor -> tensor
(* Check whether the [tensor] is well formed in the [context]. *)
val tensor_ok : context -> tensor -> bool
(* The lattice $\mathbf{N}+\mathrm{i}\mathbf{N}\subset\mathbf{C}$, which
suffices for representing the matrix elements of Dirac matrices.
We hope to be able to avoid the lattice
$\mathbf{Q}+\mathrm{i}\mathbf{Q}\subset\mathbf{C}$ or
$\mathbf{C}$ itself down the road. *)
module Complex :
sig
type t = int * int
type t' =
| Z (* $0$ *)
| O (* $1$ *)
| M (* $-1$ *)
| I (* $\mathrm{i}$ *)
| J (* $-\mathrm{i}$ *)
| C of int * int (* $x+\mathrm{i}y$ *)
val to_fortran : t' -> string
end
(* Sparse Dirac matrices as maps from Lorentz and Spinor indices
to complex numbers. This is supposed to be independent of
the representation. *)
module type Dirac =
sig
val scalar : int -> int -> Complex.t'
val vector : int -> int -> int -> Complex.t'
val tensor : int -> int -> int -> int -> Complex.t'
val axial : int -> int -> int -> Complex.t'
val pseudo : int -> int -> Complex.t'
end
(* Dirac matrices as tables of nonzero entries. There will
be one concrete Module per realization. *)
module type Dirac_Matrices =
sig
type t = (int * int * Complex.t') list
val scalar : t
val vector : (int * t) list
val tensor : (int * int * t) list
val axial : (int * t) list
val pseudo : t
end
(* E.\,g.~the chiral representation: *)
module Chiral : Dirac_Matrices
(* Here's the functor to create the maps corresponding to
a given realization. *)
module Dirac : functor (M : Dirac_Matrices) -> Dirac
end
module Lorentz : Lorentz =
struct
type index =
| I of int (* $\mu_0,\mu_1,\ldots$, not $0,1,2,3$ *)
| F of field
let map_index fi ff = function
| I i -> I (fi i)
| F i -> F (ff i)
let indices = function
| I i -> [i]
| F _ -> []
(* Is the following level of type checks useful or redundant? *)
(* TODO: should we also support a [tensor] like $F_{\mu_1\mu_2}$? *)
type vector = Vector of index
type spinor = Spinor of index
type conjspinor = ConjSpinor of index
let map_vector fi ff (Vector i) = Vector (map_index fi ff i)
let map_spinor fi ff (Spinor i) = Spinor (map_index fi ff i)
let map_conjspinor fi ff (ConjSpinor i) = ConjSpinor (map_index fi ff i)
let vector_ok context = function
| Vector (I _) ->
(* we could perform additional checks! *)
true
| Vector (F i) ->
begin
match Field.get context.lorentz_reps i with
| Coupling.Vector -> true
| Coupling.Vectorspinor ->
failwith "Lorentz.vector_ok: incomplete"
| _ -> false
end
let spinor_ok context = function
| Spinor (I _) ->
(* we could perfrom additional checks! *)
true
| Spinor (F i) ->
begin
match Field.get context.lorentz_reps i with
| Coupling.Spinor -> true
| Coupling.Vectorspinor | Coupling.Majorana ->
failwith "Lorentz.spinor_ok: incomplete"
| _ -> false
end
let conjspinor_ok context = function
| ConjSpinor (I _) ->
(* we could perform additional checks! *)
true
| ConjSpinor (F i) ->
begin
match Field.get context.lorentz_reps i with
| Coupling.ConjSpinor -> true
| Coupling.Vectorspinor | Coupling.Majorana ->
failwith "Lorentz.conjspinor_ok: incomplete"
| _ -> false
end
(* Note that [distinct2 i j] is automatically guaranteed
for Dirac spinors, because the $\bar\psi$ and $\psi$ can
not appear in the same slot. This is however not the
case for Weyl and Majorana spinors. *)
let spinor_sandwitch_ok context i j =
conjspinor_ok context i && spinor_ok context j
type primitive =
| G of vector * vector
| E of vector * vector * vector * vector
| K of vector * field
| S of conjspinor * spinor
| V of vector * conjspinor * spinor
| T of vector * vector * conjspinor * spinor
| A of vector * conjspinor * spinor
| P of conjspinor * spinor
let map_primitive fvi fvf fsi fsf fci fcf = function
| G (mu, nu) ->
G (map_vector fvi fvf mu, map_vector fvi fvf nu)
| E (mu, nu, rho, sigma) ->
E (map_vector fvi fvf mu,
map_vector fvi fvf nu,
map_vector fvi fvf rho,
map_vector fvi fvf sigma)
| K (mu, i) ->
K (map_vector fvi fvf mu, fvf i)
| S (i, j) ->
S (map_conjspinor fci fcf i, map_spinor fsi fsf j)
| V (mu, i, j) ->
V (map_vector fvi fvf mu,
map_conjspinor fci fcf i,
map_spinor fsi fsf j)
| T (mu, nu, i, j) ->
T (map_vector fvi fvf mu,
map_vector fvi fvf nu,
map_conjspinor fci fcf i,
map_spinor fsi fsf j)
| A (mu, i, j) ->
A (map_vector fvi fvf mu,
map_conjspinor fci fcf i,
map_spinor fsi fsf j)
| P (i, j) ->
P (map_conjspinor fci fcf i, map_spinor fsi fsf j)
let primitive_ok context =
function
| G (mu, nu) ->
distinct2 mu nu &&
vector_ok context mu && vector_ok context nu
| E (mu, nu, rho, sigma) ->
let i = [mu; nu; rho; sigma] in
distinct i && List.for_all (vector_ok context) i
| K (mu, i) ->
vector_ok context mu
| S (i, j) | P (i, j) ->
spinor_sandwitch_ok context i j
| V (mu, i, j) | A (mu, i, j) ->
vector_ok context mu && spinor_sandwitch_ok context i j
| T (mu, nu, i, j) ->
vector_ok context mu && vector_ok context nu &&
spinor_sandwitch_ok context i j
let primitive_vector_indices = function
| G (Vector mu, Vector nu) | T (Vector mu, Vector nu, _, _) ->
indices mu @ indices nu
| E (Vector mu, Vector nu, Vector rho, Vector sigma) ->
indices mu @ indices nu @ indices rho @ indices sigma
| K (Vector mu, _)
| V (Vector mu, _, _)
| A (Vector mu, _, _) -> indices mu
| S (_, _) | P (_, _) -> []
let vector_indices p =
ThoList.flatmap primitive_vector_indices p
let primitive_spinor_indices = function
| G (_, _) | E (_, _, _, _) | K (_, _) -> []
| S (_, Spinor alpha) | V (_, _, Spinor alpha)
| T (_, _, _, Spinor alpha)
| A (_, _, Spinor alpha) | P (_, Spinor alpha) -> indices alpha
let spinor_indices p =
ThoList.flatmap primitive_spinor_indices p
let primitive_conjspinor_indices = function
| G (_, _) | E (_, _, _, _) | K (_, _) -> []
| S (ConjSpinor alpha, _) | V (_, ConjSpinor alpha, _)
| T (_, _, ConjSpinor alpha, _)
| A (_, ConjSpinor alpha, _) | P (ConjSpinor alpha, _) -> indices alpha
let conjspinor_indices p =
ThoList.flatmap primitive_conjspinor_indices p
let vector_contraction_ok p =
let c = ThoList.classify (vector_indices p) in
print_endline
(String.concat ", "
(List.map
(fun (n, i) -> string_of_int n ^ " * " ^ string_of_int i)
c));
flush stdout;
let res = List.for_all (fun (n, _) -> n = 2) c in
res
let two_of_each indices p =
List.for_all (fun (n, _) -> n = 2) (ThoList.classify (indices p))
let vector_contraction_ok = two_of_each vector_indices
let spinor_contraction_ok = two_of_each spinor_indices
let conjspinor_contraction_ok = two_of_each conjspinor_indices
let contraction_ok p =
vector_contraction_ok p &&
spinor_contraction_ok p && conjspinor_contraction_ok p
type tensor = int * primitive list
let map_tensor fvi fvf fsi fsf fci fcf (factor, primitives) =
(factor, List.map (map_primitive fvi fvf fsi fsf fci fcf ) primitives)
let tensor_ok context (_, primitives) =
List.for_all (primitive_ok context) primitives &&
contraction_ok primitives
module Complex =
struct
type t = int * int
type t' = Z | O | M | I | J | C of int * int
let to_fortran = function
| Z -> "(0,0)"
| O -> "(1,0)"
| M -> "(-1,0)"
| I -> "(0,1)"
| J -> "(0,-1)"
| C (r, i) -> "(" ^ string_of_int r ^ "," ^ string_of_int i ^ ")"
end
module type Dirac =
sig
val scalar : int -> int -> Complex.t'
val vector : int -> int -> int -> Complex.t'
val tensor : int -> int -> int -> int -> Complex.t'
val axial : int -> int -> int -> Complex.t'
val pseudo : int -> int -> Complex.t'
end
module type Dirac_Matrices =
sig
type t = (int * int * Complex.t') list
val scalar : t
val vector : (int * t) list
val tensor : (int * int * t) list
val axial : (int * t) list
val pseudo : t
end
module Chiral : Dirac_Matrices =
struct
type t = (int * int * Complex.t') list
let scalar =
[ (1, 1, Complex.O);
(2, 2, Complex.O);
(3, 3, Complex.O);
(4, 4, Complex.O) ]
let vector =
[ (0, [ (1, 4, Complex.O);
(4, 1, Complex.O);
(2, 3, Complex.M);
(3, 2, Complex.M) ]);
(1, [ (1, 3, Complex.O);
(3, 1, Complex.O);
(2, 4, Complex.M);
(4, 2, Complex.M) ]);
(2, [ (1, 3, Complex.I);
(3, 1, Complex.I);
(2, 4, Complex.I);
(4, 2, Complex.I) ]);
(3, [ (1, 4, Complex.M);
(4, 1, Complex.M);
(2, 3, Complex.M);
(3, 2, Complex.M) ]) ]
let tensor =
[ (* TODO!!! *) ]
let axial =
[ (0, [ (1, 4, Complex.M);
(4, 1, Complex.O);
(2, 3, Complex.O);
(3, 2, Complex.M) ]);
(1, [ (1, 3, Complex.M);
(3, 1, Complex.O);
(2, 4, Complex.O);
(4, 2, Complex.M) ]);
(2, [ (1, 3, Complex.J);
(3, 1, Complex.I);
(2, 4, Complex.J);
(4, 2, Complex.I) ]);
(3, [ (1, 4, Complex.O);
(4, 1, Complex.M);
(2, 3, Complex.O);
(3, 2, Complex.M) ]) ]
let pseudo =
[ (1, 1, Complex.M);
(2, 2, Complex.M);
(3, 3, Complex.O);
(4, 4, Complex.O) ]
end
module Dirac (M : Dirac_Matrices) : Dirac =
struct
module Map2 =
Map.Make
(struct
type t = int * int
- let compare = pcompare
+ let compare = Stdlib.compare
end)
let init2 triples =
List.fold_left
(fun acc (i, j, e) -> Map2.add (i, j) e acc)
Map2.empty triples
let bounds_check2 i j =
if i < 1 || i > 4 || j < 0 || j > 4 then
invalid_arg "Chiral.bounds_check2"
let lookup2 map i j =
bounds_check2 i j;
try Map2.find (i, j) map with Not_found -> Complex.Z
module Map3 =
Map.Make
(struct
type t = int * (int * int)
- let compare = pcompare
+ let compare = Stdlib.compare
end)
let init3 quadruples =
List.fold_left
(fun acc (mu, gamma) ->
List.fold_right
(fun (i, j, e) -> Map3.add (mu, (i, j)) e)
gamma acc)
Map3.empty quadruples
let bounds_check3 mu i j =
bounds_check2 i j;
if mu < 0 || mu > 3 then
invalid_arg "Chiral.bounds_check3"
let lookup3 map mu i j =
bounds_check3 mu i j;
try Map3.find (mu, (i, j)) map with Not_found -> Complex.Z
module Map4 =
Map.Make
(struct
type t = int * int * (int * int)
- let compare = pcompare
+ let compare = Stdlib.compare
end)
let init4 quadruples =
List.fold_left
(fun acc (mu, nu, gamma) ->
List.fold_right
(fun (i, j, e) -> Map4.add (mu, nu, (i, j)) e)
gamma acc)
Map4.empty quadruples
let bounds_check4 mu nu i j =
bounds_check3 nu i j;
if mu < 0 || mu > 3 then
invalid_arg "Chiral.bounds_check4"
let lookup4 map mu nu i j =
bounds_check4 mu nu i j;
try Map4.find (mu, nu, (i, j)) map with Not_found -> Complex.Z
let scalar_map = init2 M.scalar
let vector_map = init3 M.vector
let tensor_map = init4 M.tensor
let axial_map = init3 M.axial
let pseudo_map = init2 M.pseudo
let scalar = lookup2 scalar_map
let vector = lookup3 vector_map
let tensor mu nu i j =
lookup4 tensor_map mu nu i j
let tensor mu nu i j =
failwith "tensor: incomplete"
let axial = lookup3 axial_map
let pseudo = lookup2 pseudo_map
end
end
module type Color =
sig
module Index : Index
type index = Index.t
type color_rep = F of field | C of field | A of field
type primitive =
| D of field * field
| E of field * field * field (* only for $SU(3)$ *)
| T of field * field * field
| F of field * field * field
val map_primitive : (field -> field) -> primitive -> primitive
val primitive_indices : primitive -> field list
val indices : primitive list -> field list
type tensor = int * primitive list
val map_tensor :
(field -> field) -> 'a * primitive list -> 'a * primitive list
val tensor_ok : context -> 'a * primitive list -> bool
end
module Color : Color =
struct
module Index : Index =
struct
type t = int
let of_int i = i
let to_int i = i
end
(* $a_0,a_1,\ldots$, not $0,1,\ldots$ *)
type index = Index.t
type color_rep =
| F of field
| C of field
| A of field
type primitive =
| D of field * field
| E of field * field * field
| T of field * field * field
| F of field * field * field
let map_primitive f = function
| D (i, j) -> D (f i, f j)
| E (i, j, k) -> E (f i, f j, f k)
| T (a, i, j) -> T (f a, f i, f j)
| F (a, b, c) -> F (f a, f b, f c)
let primitive_ok ctx =
function
| D (i, j) ->
distinct2 i j &&
(match Field.get ctx.color_reps i, Field.get ctx.color_reps j with
| Color.SUN (n1), Color.SUN (n2) ->
n1 = - n2 && n2 > 0
| _, _ -> false)
| E (i, j, k) ->
distinct3 i j k &&
(match Field.get ctx.color_reps i,
Field.get ctx.color_reps j, Field.get ctx.color_reps k with
| Color.SUN (n1), Color.SUN (n2), Color.SUN (n3) ->
n1 = 3 && n2 = 3 && n3 = 3 ||
n1 = -3 && n2 = -3 && n3 = -3
| _, _, _ -> false)
| T (a, i, j) ->
distinct3 a i j &&
(match Field.get ctx.color_reps a,
Field.get ctx.color_reps i, Field.get ctx.color_reps j with
| Color.AdjSUN(n1), Color.SUN (n2), Color.SUN (n3) ->
n1 = n3 && n2 = - n3 && n3 > 0
| _, _, _ -> false)
| F (a, b, c) ->
distinct3 a b c &&
(match Field.get ctx.color_reps a,
Field.get ctx.color_reps b, Field.get ctx.color_reps c with
| Color.AdjSUN(n1), Color.AdjSUN (n2), Color.AdjSUN (n3) ->
n1 = n2 && n2 = n3 && n1 > 0
| _, _, _ -> false)
let primitive_indices = function
| D (_, _) -> []
| E (_, _, _) -> []
| T (a, _, _) -> [a]
| F (a, b, c) -> [a; b; c]
let indices p =
ThoList.flatmap primitive_indices p
let contraction_ok p =
List.for_all
(fun (n, _) -> n = 2)
(ThoList.classify (indices p))
type tensor = int * primitive list
let map_tensor f (factor, primitives) =
(factor, List.map (map_primitive f) primitives)
let tensor_ok context (_, primitives) =
List.for_all (primitive_ok context) primitives
end
type t =
{ fields : string array;
lorentz : Lorentz.tensor list;
color : Color.tensor list }
module Test (M : Model.T) : Test =
struct
module Permutation = Permutation.Default
let context_of_flavors flavors =
{ arity = Array.length flavors;
lorentz_reps = Array.map M.lorentz flavors;
color_reps = Array.map M.color flavors }
let context_of_flavor_names names =
context_of_flavors (Array.map M.flavor_of_string names)
let context_of_vertex v =
context_of_flavor_names v.fields
let ok v =
let context = context_of_vertex v in
List.for_all (Lorentz.tensor_ok context) v.lorentz &&
List.for_all (Color.tensor_ok context) v.color
module PM =
Partial.Make (struct type t = field let compare = compare end)
let id x = x
let permute v p =
let context = context_of_vertex v in
let sorted =
List.map
(Field.of_int context)
(ThoList.range 0 (Array.length v.fields - 1)) in
let permute =
PM.apply (PM.of_lists sorted (List.map (Field.of_int context) p)) in
{ fields = Permutation.array (Permutation.of_list p) v.fields;
lorentz = List.map
(Lorentz.map_tensor id permute id permute id permute) v.lorentz;
color = List.map (Color.map_tensor permute) v.color }
let permutations v =
List.map (permute v)
(Combinatorics.permute (ThoList.range 0 (Array.length v.fields - 1)))
let wf_declaration flavor =
match M.lorentz (M.flavor_of_string flavor) with
| Coupling.Vector -> "vector"
| Coupling.Spinor -> "spinor"
| Coupling.ConjSpinor -> "conjspinor"
| _ -> failwith "wf_declaration: incomplete"
module Chiral = Lorentz.Dirac(Lorentz.Chiral)
let write_fusion v =
match Array.to_list v.fields with
| lhs :: rhs ->
let name = lhs ^ "_of_" ^ String.concat "_" rhs in
let momenta = List.map (fun n -> "k_" ^ n) rhs in
Printf.printf "pure function %s (%s) result (%s)\n"
name (String.concat ", "
(List.flatten
(List.map2 (fun wf p -> [wf; p]) rhs momenta)))
lhs;
Printf.printf " type(%s) :: %s\n" (wf_declaration lhs) lhs;
List.iter
(fun wf ->
Printf.printf " type(%s), intent(in) :: %s\n"
(wf_declaration wf) wf)
rhs;
List.iter
(Printf.printf " type(momentum), intent(in) :: %s\n")
momenta;
let rhs1 = List.hd rhs
and rhs2 = List.hd (List.tl rhs) in
begin match M.lorentz (M.flavor_of_string lhs) with
| Coupling.Vector ->
begin
for mu = 0 to 3 do
Printf.printf " %s(%d) =" lhs mu;
for i = 1 to 4 do
for j = 1 to 4 do
match Chiral.vector mu i j with
| Lorentz.Complex.Z -> ()
| c ->
Printf.printf " + %s*%s(%d)*%s(%d)"
(Lorentz.Complex.to_fortran c) rhs1 i rhs2 j
done
done;
Printf.printf "\n"
done
end;
| Coupling.Spinor | Coupling.ConjSpinor ->
begin
for i = 1 to 4 do
Printf.printf " %s(%d) =" lhs i;
for mu = 0 to 3 do
for j = 1 to 4 do
match Chiral.vector mu i j with
| Lorentz.Complex.Z -> ()
| c ->
Printf.printf " + %s*%s(%d)*%s(%d)"
(Lorentz.Complex.to_fortran c) rhs1 mu rhs2 j
done
done;
Printf.printf "\n"
done
end;
| _ -> failwith "write_fusion: incomplete"
end;
Printf.printf "end function %s\n" name;
()
| [] -> ()
let write_fusions v =
List.iter write_fusion (permutations v)
(* Testing: *)
let vector_field context i =
Lorentz.Vector (Lorentz.F (Field.of_int context i))
let spinor_field context i =
Lorentz.Spinor (Lorentz.F (Field.of_int context i))
let conjspinor_field context i =
Lorentz.ConjSpinor (Lorentz.F (Field.of_int context i))
let mu = Lorentz.Vector (Lorentz.I 0)
and nu = Lorentz.Vector (Lorentz.I 1)
let tbar_gl_t = [| "tbar"; "gl"; "t" |]
let context = context_of_flavor_names tbar_gl_t
let vector_current_ok =
{ fields = tbar_gl_t;
lorentz = [ (1, [Lorentz.V (vector_field context 1,
conjspinor_field context 0,
spinor_field context 2)]) ];
color = [ (1, [Color.T (Field.of_int context 1,
Field.of_int context 0,
Field.of_int context 2)])] }
let vector_current_vector_misplaced =
{ fields = tbar_gl_t;
lorentz = [ (1, [Lorentz.V (vector_field context 2,
conjspinor_field context 0,
spinor_field context 2)]) ];
color = [ (1, [Color.T (Field.of_int context 1,
Field.of_int context 0,
Field.of_int context 2)])] }
let vector_current_spinor_misplaced =
{ fields = tbar_gl_t;
lorentz = [ (1, [Lorentz.V (vector_field context 1,
conjspinor_field context 0,
spinor_field context 1)]) ];
color = [ (1, [Color.T (Field.of_int context 1,
Field.of_int context 0,
Field.of_int context 2)])] }
let vector_current_conjspinor_misplaced =
{ fields = tbar_gl_t;
lorentz = [ (1, [Lorentz.V (vector_field context 1,
conjspinor_field context 1,
spinor_field context 2)]) ];
color = [ (1, [Color.T (Field.of_int context 1,
Field.of_int context 0,
Field.of_int context 2)])] }
let vector_current_out_of_bounds () =
{ fields = tbar_gl_t;
lorentz = [ (1, [Lorentz.V (mu,
conjspinor_field context 3,
spinor_field context 2)]) ];
color = [ (1, [Color.T (Field.of_int context 1,
Field.of_int context 0,
Field.of_int context 2)])] }
let vector_current_color_mismatch =
let names = [| "t"; "gl"; "t" |] in
let context = context_of_flavor_names names in
{ fields = names;
lorentz = [ (1, [Lorentz.V (mu,
conjspinor_field context 0,
spinor_field context 2)]) ];
color = [ (1, [Color.T (Field.of_int context 1,
Field.of_int context 0,
Field.of_int context 2)])] }
let wwzz = [| "W+"; "W-"; "Z"; "Z" |]
let context = context_of_flavor_names wwzz
let anomalous_couplings =
{ fields = wwzz;
lorentz = [ (1, [ Lorentz.K (mu, Field.of_int context 0);
Lorentz.K (mu, Field.of_int context 1) ]) ];
color = [ ] }
let anomalous_couplings_index_mismatch =
{ fields = wwzz;
lorentz = [ (1, [ Lorentz.K (mu, Field.of_int context 0);
Lorentz.K (nu, Field.of_int context 1) ]) ];
color = [ ] }
exception Inconsistent_vertex
let example () =
if not (ok vector_current_ok) then begin
raise Inconsistent_vertex
end;
write_fusions vector_current_ok
open OUnit
let vertex_indices_ok =
"indices/ok" >::
(fun () ->
List.iter
(fun v ->
assert_bool "vector_current" (ok v))
(permutations vector_current_ok))
let vertex_indices_broken =
"indices/broken" >::
(fun () ->
assert_bool "vector misplaced"
(not (ok vector_current_vector_misplaced));
assert_bool "conjugate spinor misplaced"
(not (ok vector_current_spinor_misplaced));
assert_bool "conjugate spinor misplaced"
(not (ok vector_current_conjspinor_misplaced));
assert_raises (Field.Out_of_range 3)
vector_current_out_of_bounds;
assert_bool "color mismatch"
(not (ok vector_current_color_mismatch)))
let anomalous_couplings_ok =
"anomalous_couplings/ok" >::
(fun () ->
assert_bool "anomalous couplings"
(ok anomalous_couplings))
let anomalous_couplings_broken =
"anomalous_couplings/broken" >::
(fun () ->
assert_bool "anomalous couplings"
(not (ok anomalous_couplings_index_mismatch)))
let suite =
"Vertex" >:::
[vertex_indices_ok;
vertex_indices_broken;
anomalous_couplings_ok;
anomalous_couplings_broken]
end
Index: trunk/omega/src/targets.mli
===================================================================
--- trunk/omega/src/targets.mli (revision 8899)
+++ trunk/omega/src/targets.mli (revision 8900)
@@ -1,46 +1,36 @@
(* targets.mli --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
module Dummy : Target.Maker
-(* \thocwmodulesection{Supported Targets} *)
-module Fortran : Target.Maker
-module Fortran_Majorana : Target.Maker
-module VM : Target.Maker
-
(* \thocwmodulesection{Potential Targets} *)
+
+(* Most will probably never materialize \ldots{} *)
+
module Fortran77 : Target.Maker
module C : Target.Maker
module Cpp : Target.Maker
module Java : Target.Maker
module Ocaml : Target.Maker
module LaTeX : Target.Maker
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/omega.ocamlinit
===================================================================
--- trunk/omega/src/omega.ocamlinit (revision 8899)
+++ trunk/omega/src/omega.ocamlinit (revision 8900)
@@ -1,28 +1,58 @@
(* This is for running O'Mega inside the utop O'Caml
toplevel in order to debug some modules. *)
+#install_printer Algebra.Q.pp;;
+#install_printer Algebra.QC.pp;;
#install_printer Algebra.Laurent.pp;;
-#install_printer Color.Arrow.pp_free;;
-#install_printer Color.Arrow.pp_factor;;
-#install_printer Color.Birdtracks.pp;;
-#install_printer Color.SU3.pp;;
-(* #install_printer Color.U3.pp;; *)
+#install_printer Arrow.pp_free;;
+#install_printer Arrow.pp_factor;;
+#install_printer Young.pp;;
+#install_printer Birdtracks.pp;;
+#install_printer Color_Propagator.pp;;
#install_printer Dirac.Chiral.pp;;
#install_printer Dirac.Dirac.pp;;
#install_printer Dirac.Majorana.pp;;
-module A = Algebra.Laurent;;
-module SU3 = Color.SU3;;
-(* module U3 = Color.U3;; *)
-open SU3;;
+module Q = Algebra.Q;;
+module QC = Algebra.QC;;
+module L = Algebra.Laurent;;
+open Birdtracks;;
open Infix;;
+open SU3;;
+open Color_Propagator;;
+open Color_Fusion;;
(* parse and unparse *)
let pnup spins s =
let t = UFOx.Lorentz.of_string s in
String.concat
" >>>> "
[s; UFOx.Lorentz.to_string t;
UFO_Lorentz.to_string (UFO_Lorentz.parse spins t)];;
let pnup1 spin s =
pnup [spin; spin] s;;
+
+
+(* Abbreviations *)
+let e = Algebra.QC.unit
+let half = Algebra.QC.fraction 2
+let w = white
+
+(* Quarks and anti quarks: *)
+let q i = of_lists [i] []
+let aq i = of_lists [] [i]
+
+(* Diquarks and anti diquarks: *)
+let dq i j = of_lists [i; j] []
+let adq i j = of_lists [] [i; j]
+
+(* Gluons without ghosts *)
+let g i j = of_lists [i] [j]
+
+(* Couplings *)
+let d = delta3
+let d6 = delta6
+let t = t
+let t6 = t6
+let k6 = k6
+let k6b = k6bar
Index: trunk/omega/src/thoList.mli
===================================================================
--- trunk/omega/src/thoList.mli (revision 8899)
+++ trunk/omega/src/thoList.mli (revision 8900)
@@ -1,201 +1,236 @@
(* thoList.mli --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
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. *)
(* [splitn n l = (hdn l, tln l)], but more efficient. *)
val hdn : int -> 'a list -> 'a list
val tln : int -> 'a list -> 'a list
val splitn : int -> 'a list -> 'a list * 'a list
(* [split_last (l @ [a]) = (l, a)] *)
val split_last : 'a list -> 'a list * 'a
(* [chop n l] chops [l] into pieces of size [n] (except for the last
one, which contains th remainder). *)
val chopn : int -> 'a list -> 'a list list
(* [cycle_until a l] finds a member [a] in the list [l] and returns the
cyclically permuted list with [a] as head. Raises [Not_found] if
[a] is not in [l]. *)
val cycle_until : 'a -> 'a list -> 'a list
(* [cycle n l] cyclically permute the list [l] by [n >= 0]
positions. Raises [Not_found] [List.length l > n].
NB: [cycle n l = tln n l @ hdn n l], but more efficient. *)
val cycle : int -> 'a list -> 'a list
(* [of_subarray n m a] is $[\ocwlowerid{a.}(\ocwlowerid{n});
\ocwlowerid{a.}(\ocwlowerid{n}+1);\ldots;
\ocwlowerid{a.}(\ocwlowerid{m})]$. Values of~[n] and~[m]
out of bounds are silently shifted towards these bounds. *)
val of_subarray : int -> int -> 'a array -> 'a list
(* [range s n m] is $[\ocwlowerid{n}; \ocwlowerid{n}+\ocwlowerid{s};
\ocwlowerid{n}+2\ocwlowerid{s};\ldots;
\ocwlowerid{m} - ((\ocwlowerid{m}-\ocwlowerid{n})\mod s)]$ *)
val range : ?stride:int -> int -> int -> int list
(* [enumerate s n [a1;a2;...] is [(n,a1); (n+s,a2); ...] *)
val enumerate : ?stride:int -> int -> 'a list -> (int * 'a) list
(* [alist_of_list ~predicate ~offset list] takes the elements of
[list] that satisfy [predicate] and forms a list of pairs of
an offset into the original [list] and the element with the
offsets starting from [offset]. NB: the order of the returned
- alist is not specified! *)
+ alist is not specified! For example [ alist_of_list ["a";"b";"c"]
+ = [(2, "c"); (1, "b"); (0, "a")] ]*)
val alist_of_list :
?predicate:('a -> bool) -> ?offset:int -> 'a list -> (int * 'a) list
(* Compress identical elements in a sorted list. Identity
is determined using the polymorphic equality function
[Pervasives.(=)]. *)
val uniq : 'a list -> 'a list
(* Test if all members of a list are structurally identical
(actually [homogeneous l] and [List.length (uniq l) <= 1]
are equivalent, but the former is more efficient if a mismatch
comes early). *)
val homogeneous : 'a list -> bool
(* If all elements of the list [l] appear exactly twice,
[pairs l] returns a sorted list with these elements appearing
once. Otherwise [Invalid_argument] is raised. *)
val pairs : 'a list -> 'a list
(* [compare cmp l1 l2] compare two lists [l1] and [l2] according to
[cmp]. [cmp] defaults to the polymorphic [Pervasives.compare]. *)
val compare : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list -> int
(* Collect and count identical elements in a list. Identity
is determined using the polymorphic equality function
[Pervasives.(=)]. [classify] does not assume that the list
is sorted. However, it is~$O(n)$ for sorted lists and~$O(n^2)$
in the worst case. *)
val classify : 'a list -> (int * 'a) list
(* Collect the second factors with a common first factor in lists.
\label{ThoList.factorize} *)
val factorize : ('a * 'b) list -> ('a * 'b list) list
+(* [factorize_fold op init pairs] combines the second elements of the [pairs]
+ with common first element using the binary operator [op] and initial
+ value [init]. If [op] is not associative and commutative, the result is
+ \emph{not} well defined. *)
+val factorize_fold : ('b -> 'b -> 'b) -> 'b -> ('a * 'b) list -> ('a * 'b) list
+
(* [flatmap f] is equivalent to $\ocwlowerid{flatten} \circ
(\ocwlowerid{map}\;\ocwlowerid{f})$, but more efficient,
because no intermediate lists are built. Unfortunately, it is
not tail recursive. *)
val flatmap : ('a -> 'b list) -> 'a list -> 'b list
(* [rev_flatmap f] is equivalent to $\ocwlowerid{flatten} \circ
(\ocwlowerid{rev\_map}\;(\ocwlowerid{rev}\circ\ocwlowerid{f}))
= \ocwlowerid{rev}\circ(\ocwlowerid{flatmap}\;\ocwlowerid{f})$,
but more efficient, because no intermediate lists are built.
It is tail recursive. *)
val rev_flatmap : ('a -> 'b list) -> 'a list -> 'b list
(* [clone a n] builds a list from [n] copies of the element [a]. *)
val clone : 'a -> int -> 'a list
(* [multiply n l] concatenates [n] copies of the list [l]. *)
val multiply : int -> 'a list -> 'a list
(* [filtermap f l] applies [f] to each element of [l] and drops
the results [None]. *)
+(* \begin{dubious}
+ This will be [List.filter_map] starting with O'Caml 4.08!
+ \end{dubious} *)
val filtermap : ('a -> 'b option) -> 'a list -> 'b list
(* [power a_list] computes the list of all sublists of [a_list],
i.\,e.~the power set. The elements of the sublists are \emph{not}
required to have been sequential in [a_list]. *)
val power : 'a list -> 'a list list
(* Like [List.fold_left], but returns immediately, if the
folded function returns [None]. The analogous function
[val fold_right_opt : ('a -> 'b -> 'b option) -> 'a list -> 'b -> 'b option]
has not been implemented. It makes not much sense, because
the outer function evaluation can only be performed after
the results of all inner evaluations are available. *)
val fold_left_opt : ('b -> 'a -> 'b option) -> 'b -> 'a list -> 'b option
(* \begin{dubious}
Invent other names to avoid confusions with [List.fold_left2]
and [List.fold_right2].
\end{dubious} *)
val fold_right2 : ('a -> 'b -> 'b) -> 'a list list -> 'b -> 'b
val fold_left2 : ('b -> 'a -> 'b) -> 'b -> 'a list list -> 'b
(* [iteri f n [a;b;c]] evaluates [f n a], [f (n+1) b] and [f (n+2) c]. *)
val iteri : (int -> 'a -> unit) -> int -> 'a list -> unit
val mapi : (int -> 'a -> 'b) -> int -> 'a list -> 'b list
(* [iteri2 f n m [[aa;ab];[ba;bb]]] evaluates [f n m aa], [f n (m+1) ab],
[f (n+1) m ba] and [f (n+1) (m+1) bb].
NB: the nested lists need not be rectangular. *)
val iteri2 : (int -> int -> 'a -> unit) -> int -> int -> 'a list list -> unit
(* Just like [List.map3]: *)
val map3 : ('a -> 'b -> 'c -> 'd) -> 'a list -> 'b list -> 'c list -> 'd list
(* Transpose a \emph{rectangular} list of lists like a matrix. *)
val transpose : 'a list list -> 'a list list
(* [interleave f list] walks through [list] and inserts the result
of [f] applied to the reversed list of elements before and the
list of elements after. The empty lists at the beginning and
end are included! *)
val interleave : ('a list -> 'a list -> 'a list) -> 'a list -> 'a list
(* [interleave_nearest f list] is like [interleave f list], but
[f] looks only at the nearest neighbors. *)
val interleave_nearest : ('a -> 'a -> 'a list) -> 'a list -> 'a list
(* [partitioned_sort cmp index_sets list] sorts the sublists of [list] specified
by the [index_sets] and the complement of their union. \textbf{NB:} the sorting
follows to order in the lists in [index_sets]. \textbf{NB:} the indices are
0-based. *)
val partitioned_sort : ('a -> 'a -> int) -> int list list -> 'a list -> 'a list
exception Overlapping_indices
exception Out_of_bounds
(* [ariadne_sort cmp list] sorts [list] according to [cmp]
(default [Pervasives.compare]) keeping track of the original order
by a 0-based list of indices. *)
val ariadne_sort : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list * int list
(* [ariadne_unsort (ariadne_sort cmp list)] returns [list]. *)
val ariadne_unsort : 'a list * int list -> 'a list
(* [lexicographic cmp list1 list2] compares [list1] and [list2]
lexicographically. *)
val lexicographic : ?cmp:('a -> 'a -> int) -> 'a list -> 'a list -> int
(* [common l1 l2] returns the elements common to the lists [l1] and [l2].
The lists are not required to be ordered and the result will also
not be ordered. *)
val common : 'a list -> 'a list -> 'a list
(* [complement l1 l2] returns the list [l1] with elements of list [l2]
removed. The lists are not required to be ordered. Raises
[Invalid_argument "ThoList.complement"], if a member of [l1] is not
in [l1]. *)
val complement : 'a list -> 'a list -> 'a list
+(* [to_string f list] formats the elements of the list with [f],
+ concatenates them with ["; "] and encloses the result in brakets.*)
val to_string : ('a -> string) -> 'a list -> string
+(* [take_first_even_opt predicate list] find the first element [a] in
+ [list] with [predicate a = true]. It returns [Some (a, remainder)],
+ where [remainder] are all other elements of [list] reordered such
+ that [a :: remainder] is equal to an even permutation of [list].
+ It returns [None], if the predicate is never satisfied.
+
+ For a list of 2 elements, when the second element satisfies the
+ predicate, there are not enough elements to construct an even
+ permutation. Therefore the function is not well defined for this
+ input. Instead of returning [None], it raises the exception
+ [Invalid_argument "ThoList.take_first_even_opt: pair"] *)
+val take_first_even_opt : ('a -> bool) -> 'a list -> ('a * 'a list) option
+
+(* [merge_alist op f1 f2 l1 l2] applies [op] to the values in the association
+ lists with matching keys and [f1] or [f2] to the others. The result will
+ be sorted according to the keys. *)
+val merge_alist : ('a -> 'b -> 'c) -> ('a -> 'c) -> ('b -> 'c) ->
+ ('d * 'a) list -> ('d * 'b) list -> ('d * 'c) list
+
+(* Like [merge_alist], but faster since it assumes that the lists are sorted. *)
+val merge_sorted_alist : ('a -> 'b -> 'c) -> ('a -> 'c) -> ('b -> 'c) ->
+ ('d * 'a) list -> ('d * 'b) list -> ('d * 'c) list
+
module Test : sig val suite : OUnit.test end
Index: trunk/omega/src/omega_THDM_CKM_VM.ml
===================================================================
--- trunk/omega/src/omega_THDM_CKM_VM.ml (revision 8899)
+++ trunk/omega/src/omega_THDM_CKM_VM.ml (revision 8900)
@@ -1,36 +1,27 @@
(* omega_THDM_CKM_VM.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
cf. main AUTHORS file
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.VM)
- (Modellib_BSM.TwoHiggsDoublet(Modellib_BSM.THDM_CKM))
+module O = Omega.Mixed23(Target_VM.Make)(Modellib_BSM.TwoHiggsDoublet(Modellib_BSM.THDM_CKM))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/Makefile.am
===================================================================
--- trunk/omega/src/Makefile.am (revision 8899)
+++ trunk/omega/src/Makefile.am (revision 8900)
@@ -1,214 +1,217 @@
# Makefile.am -- Makefile for O'Mega within and without WHIZARD
##
## Process this file with automake to produce Makefile.in
##
########################################################################
#
# Copyright (C) 1999-2023 by
# Wolfgang Kilian <kilian@physik.uni-siegen.de>
# Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
# Juergen Reuter <juergen.reuter@desy.de>
# 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.
#
########################################################################
# Build the O'Mega Fortran library using libtool
# (?use pkglib_ instead of lib_ to make the -rpath and *.lai business work ...)
lib_LTLIBRARIES = libomega_core.la
execmoddir = $(fmoddir)/omega
nodist_execmod_HEADERS = $(OMEGALIB_MOD)
libomega_core_la_SOURCES = $(OMEGALIB_F90)
EXTRA_DIST = \
$(OMEGA_CONFIG_MLI) $(OMEGA_CAML) \
omegalib.nw $(OMEGALIB_F90)
OMEGA_CMXA = omega_core.cmxa omega_targets.cmxa omega_models.cmxa
OMEGA_CMA = $(OMEGA_CMXA:.cmxa=.cma)
if OCAML_AVAILABLE
all-local: $(OMEGA_CMXA) $(OMEGA_APPLICATIONS_CMX)
bytecode: $(OMEGA_CMA) $(OMEGA_APPLICATIONS_CMO)
else
all-local:
bytecode:
endif
# Compiled interfaces and libraries for out-of-tree compilation of models
if OCAML_AVAILABLE
camllibdir = $(libdir)/omega/caml
nodist_camllib_DATA = \
omega.cmi fusion.cmi targets.cmi coupling.cmi modeltools.cmi color.cmi \
options.cmi model.cmi \
omega_core.cmxa omega_core.a omega_targets.cmxa omega_targets.a \
charges.cmi
endif
########################################################################
include $(top_srcdir)/omega/src/Makefile.ocaml
include $(top_srcdir)/omega/src/Makefile.sources
if OCAML_AVAILABLE
config.cmo config.cmx: config.cmi
omega_core.a: omega_core.cmxa
omega_core.cmxa: $(OMEGA_CORE_CMX)
@if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi
$(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) -a -o $@ $^
omega_core.cma: $(OMEGA_CORE_CMO)
@if $(AM_V_P); then :; else echo " OCAMLC " $@; fi
$(AM_V_at)$(OCAMLC) $(OCAMLFLAGS) -a -o $@ $^
omega_targets.a: omega_targets.cmxa
omega_targets.cmxa: $(OMEGA_TARGETS_CMX)
@if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi
$(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) -a -o $@ $^
omega_targets.cma: $(OMEGA_TARGETS_CMO)
@if $(AM_V_P); then :; else echo " OCAMLC " $@; fi
$(AM_V_at)$(OCAMLC) $(OCAMLFLAGS) -a -o $@ $^
omega_models.cmxa: $(OMEGA_MODELS_CMX)
@if $(AM_V_P); then :; else echo " OCAMLOPT " $@; fi
$(AM_V_at)$(OCAMLOPT) $(OCAMLFLAGS) $(OCAMLOPTFLAGS) -a -o $@ $^
omega_models.cma: $(OMEGA_MODELS_CMO)
@if $(AM_V_P); then :; else echo " OCAMLC " $@; fi
$(AM_V_at)$(OCAMLC) $(OCAMLFLAGS) -a -o $@ $^
+orders_lexer.mli: orders_lexer.ml orders_parser.cmi
+ $(OCAMLC) -i $< | $(GREP) 'val token' >$@
+
cascade_lexer.mli: cascade_lexer.ml cascade_parser.cmi
$(OCAMLC) -i $< | $(GREP) 'val token' >$@
vertex_lexer.mli: vertex_lexer.ml vertex_parser.cmi
$(OCAMLC) -i $< | $(EGREP) 'val (token|init_position)' >$@
UFO_lexer.mli: UFO_lexer.ml UFO_parser.cmi UFO_tools.cmi
$(OCAMLC) -i $< | $(EGREP) 'val (token|init_position)' >$@
UFOx_lexer.mli: UFOx_lexer.ml UFOx_parser.cmi UFO_tools.cmi
$(OCAMLC) -i $< | $(EGREP) 'val (token|init_position)' >$@
endif
MYPRECIOUS = $(OMEGA_DERIVED_CAML)
SUFFIXES += .lo .$(FCMOD)
# Fortran90 module files are generated at the same time as object files
.lo.$(FCMOD):
@:
# touch $@
########################################################################
DISTCLEANFILES = kinds.f90
if NOWEB_AVAILABLE
omegalib.stamp: $(srcdir)/omegalib.nw
@rm -f omegalib.tmp
@touch omegalib.tmp
for src in $(OMEGALIB_DERIVED_F90); do \
$(NOTANGLE) -R[[$$src]] $< | $(CPIF) $$src; \
done
@mv -f omegalib.tmp omegalib.stamp
$(OMEGALIB_DERIVED_F90): omegalib.stamp
## Recover from the removal of $@
@if test -f $@; then :; else \
rm -f omegalib.stamp; \
$(MAKE) $(AM_MAKEFLAGS) omegalib.stamp; \
fi
DISTCLEANFILES += $(OMEGALIB_DERIVED_F90)
endif NOWEB_AVAILABLE
MYPRECIOUS += $(OMEGALIB_DERIVED_F90)
########################################################################
# The following line just says
# include Makefile.depend_fortran
# but in a portable fashion (depending on automake's AM_MAKE_INCLUDE
########################################################################
@am__include@ @am__quote@Makefile.depend_fortran@am__quote@
Makefile.depend_fortran: kinds.f90 $(libomega_core_la_SOURCES)
@rm -f $@
for src in $^; do \
module="`basename $$src | sed 's/\.f[90][0358]//'`"; \
grep '^ *use ' $$src \
| grep -v '!NODEP!' \
| sed -e 's/^ *use */'$$module'.lo: /' \
-e 's/, *only:.*//' \
-e 's/, *&//' \
-e 's/, *.*=>.*//' \
-e 's/ *$$/.lo/' ; \
done > $@
DISTCLEANFILES += Makefile.depend_fortran
if OCAML_AVAILABLE
@am__include@ @am__quote@Makefile.depend_ocaml@am__quote@
-PARSERS = cascade vertex UFO UFOx
+PARSERS = orders cascade vertex UFO UFOx
Makefile.depend_ocaml: $(OMEGA_CAML_PRIMARY)
@if $(AM_V_P); then :; else echo " OCAMLDEP " $@; fi
@rm -f $@
$(AM_V_at)$(OCAMLDEP) -I $(srcdir) $^ $(OMEGA_DERIVED_CAML) \
| sed 's,[^ ]*/,,g' > $@
$(AM_V_at)for parser in $(PARSERS); do \
echo $${parser}.cmi: $${parser}_lexer.cmi; \
echo $${parser}_lexer.cmi: $${parser}_parser.cmi; \
echo $${parser}_parser.cmi: $${parser}_syntax.cmi; \
echo $${parser}_parser.mli: $${parser}_parser.ml; \
echo $${parser}.cmo: $${parser}.cmi; \
echo $${parser}.cmx: $${parser}.cmi $${parser}_lexer.cmx; \
echo $${parser}_lexer.cmo: $${parser}_lexer.cmi; \
echo $${parser}_lexer.cmx: $${parser}_lexer.cmi $${parser}_parser.cmx; \
echo $${parser}_parser.cmo: $${parser}_parser.cmi $${parser}_syntax.cmi; \
echo $${parser}_parser.cmx: $${parser}_parser.cmi \
$${parser}_syntax.cmi $${parser}_syntax.cmx; \
done >>$@
DISTCLEANFILES += Makefile.depend_ocaml
endif OCAML_AVAILABLE
########################################################################
# Don't trigger remakes by deleting intermediate files.
.PRECIOUS = $(MYPRECIOUS)
clean-local:
rm -f *.cm[aiox] *.cmxa *.[ao] *.l[oa] *.$(FCMOD) \
$(OMEGA_DERIVED_CAML) omegalib.stamp
if FC_SUBMODULES
-rm -f *.smod
endif
distclean-local:
-test "$(srcdir)" != "." && rm -f config.mli
########################################################################
## The End.
########################################################################
Index: trunk/omega/src/arrow.mli
===================================================================
--- trunk/omega/src/arrow.mli (revision 0)
+++ trunk/omega/src/arrow.mli (revision 8900)
@@ -0,0 +1,237 @@
+(* arrow.mli --
+
+ Copyright (C) 2022-2023 by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+ with contributions from
+ Christian Speckner <cnspeckn@googlemail.com>
+
+ 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. *)
+
+(* The datatypes [Arrow.free] and [Arrow.factor] will be used as
+ building blocks for [Birdtracks.t] below. *)
+
+(* For fundamental and adjoint representations, the endpoints
+ of arrows are uniquely specified by a vertex (which will
+ be represented by a number). For representations with more
+ than one outgoing or incoming arrow, we need an additional index.
+ This is abstracted in the [endpoint] type. *)
+type endpoint = private
+ | I of int
+ | M of int * int
+
+(* Endpoints can be the the tip or tail of an arrow or a ghost.
+ Using incompatible types for each forces us to export three
+ identical copies of some functions, but should help to avoid
+ some simple mistakes, in which tips and tails are confused. *)
+type tip = private endpoint
+type tail = private endpoint
+type ghost = private endpoint
+
+(* The position of the endpoint is encoded as an integer, which
+ can be mapped, if necessary. *)
+val position_tip : tip -> int
+val position_tail : tail -> int
+val position_ghost : ghost -> int
+val relocate_tip : (int -> int) -> tip -> tip
+val relocate_tail : (int -> int) -> tail -> tail
+val relocate_ghost : (int -> int) -> tail -> tail
+
+(* An [Arrow.t] is either a genuine arrow or a ghost. The rationale
+ for the polymorphic definition is explained below. *)
+
+type ('tail, 'tip, 'ghost) t =
+ | Arrow of 'tail * 'tip
+ | Ghost of 'ghost
+
+(* $\epsilon_{i_1i_2\cdots i_n}$ and $\bar\epsilon^{i_1i_2\cdots i_n}$
+ are represented by lists~$\lbrack i_1; i_2; \ldots; i_n \rbrack$. *)
+
+type 'tip eps = 'tip list
+type 'tail eps_bar = 'tail list
+
+(* We distuish [free] arrows, $\epsilon$s and $\bar\epsilon$s
+ that must not contain
+ summation indices from [factor]s that may. Indices are
+ opaque. [('tail, 'tip, 'ghost) t] has been defined polymorphic
+ above so that we can use richer ['tail], ['tip] and ['ghost] in
+ [factor] to identify summation indices.
+ Not that it is \emph{not} enough to identify summation indices
+ by negative integers alone. Due to the presence of double arrows
+ representing gluons, we must distinguish summation indices
+ in the left factor of a product from those in the right factor. *)
+
+type free = (tail, tip, ghost) t
+type free_eps = tip eps
+type free_eps_bar = tail eps_bar
+type factor
+type factor_eps
+type factor_eps_bar
+
+val relocate : (int -> int) -> free -> free
+val rev : free -> free
+val rev_eps : free_eps -> free_eps_bar
+val rev_eps_bar : free_eps_bar -> free_eps
+
+(* Useful for testing compatibility when adding terms. *)
+val tips : free -> tip list
+val tips_eps : free_eps -> tip list
+val tails : free -> tail list
+val tails_eps_bar : free_eps_bar -> tail list
+
+(* For debugging, logging, etc. *)
+val free_to_string : free -> string
+val free_eps_to_string : free_eps -> string
+val free_eps_bar_to_string : free_eps_bar -> string
+val factor_to_string : factor -> string
+val factor_eps_to_string : factor_eps -> string
+val factor_eps_bar_to_string : factor_eps_bar -> string
+
+(* Turn the [endpoint]s satisfying the predicate into a
+ left or right hand side summation index. Left and right
+ refer to the two factors in a product and
+ we must only match arrows with [endpoint]s in both
+ factors, not double lines on either side.
+ Typically, the predicate will be set up to select only the
+ summation indices that appear on both sides.*)
+
+val to_left_factor : (endpoint -> bool) -> free -> factor
+val to_left_factor_eps : (endpoint -> bool) -> free_eps -> factor_eps
+val to_left_factor_eps_bar : (endpoint -> bool) -> free_eps_bar -> factor_eps_bar
+val to_right_factor : (endpoint -> bool) -> free -> factor
+val to_right_factor_eps : (endpoint -> bool) -> free_eps -> factor_eps
+val to_right_factor_eps_bar : (endpoint -> bool) -> free_eps_bar -> factor_eps_bar
+
+(* The incomplete inverse [of_factor] raises an exception
+ if there are remaining summation indices. [is_free] can
+ be used to check first. *)
+val of_factor : factor -> free
+val of_factor_eps : factor_eps -> free_eps
+val of_factor_eps_bar : factor_eps_bar -> free_eps_bar
+val is_free : factor -> bool
+val is_free_eps : factor_eps -> bool
+val is_free_eps_bar : factor_eps_bar -> bool
+
+(* Return all the endpoints of the arrow that have a [position]
+ encoded as a negative integer. These are treated as summation
+ indices in our applications. *)
+val negatives : free -> endpoint list
+val negatives_eps : free_eps -> endpoint list
+val negatives_eps_bar : free_eps_bar -> endpoint list
+
+(* We will need to test whether an arrow represents a ghost. *)
+val is_ghost : free -> bool
+
+(* An arrow looping back to itself. *)
+val is_tadpole : factor -> bool
+
+(* Merging an arrow with another arrow, $\epsilon$ or $\bar\epsilon$
+ can give a variety of results: *)
+
+type merge =
+ | Match of factor (* a tip fits the other's tail: make one arrow out of two *)
+ | Ghost_Match (* two matching ghosts *)
+ | Loop_Match (* both tips fit both tails: drop the arrows *)
+ | Mismatch (* ghost meets arrow: discard *)
+ | No_Match (* nothing to be done *)
+
+val merge_arrow_arrow : factor -> factor -> merge
+
+(* We can narrow this for $\epsilon$ and $\bar\epsilon$,
+ where [Loop_Match] and [Ghost_Match] are impossible! *)
+
+type 'a merge_eps =
+ | Match_Eps of 'a (* a tip fits the other's tail: make one arrow out of two *)
+ | Mismatch_Eps (* ghost meets arrow: discard *)
+ | No_Match_Eps (* nothing to be done *)
+
+val merge_arrow_eps : factor -> factor_eps -> factor_eps merge_eps
+val merge_arrow_eps_bar : factor -> factor_eps_bar -> factor_eps_bar merge_eps
+
+(* In order to merge an~$\epsilon$ with an $\bar\epsilon$, we use
+ \begin{equation}
+ \forall n, N \in\mathbf{N}, 2\le n \le N:\;
+ \epsilon_{i_1i_2\cdots i_n} \bar\epsilon^{j_1j_2\cdots j_n}
+ = \sum_{\sigma\in S_n} (-1)^{\varepsilon(\sigma)}
+ \delta_{i_1}^{\sigma(j_1)}
+ \delta_{i_2}^{\sigma(j_2)}
+ \cdots
+ \delta_{i_n}^{\sigma(j_n)}\,,
+ \end{equation}
+ where~$N=\delta_i^i$ is the dimension, to replace the pair by two lists of
+ lists of arrows: the first corresponding to the even permutations, the
+ second to the odd ones.
+ Return [None], if the rank of $\epsilon$ and $\bar\epsilon$ don't match. *)
+
+(* See section~\ref{sec:evaluation-of-epsilon-tensors}
+ on pages~\pageref{sec:evaluation-of-epsilon-tensors}ff for a justification
+ for using it also in the case~$n\not=N$. *)
+
+val merge_eps_eps_bar : factor_eps -> factor_eps_bar -> (factor list list * factor list list) option
+
+(* Break up an arrow [tee a (i => j) -> [i => a; a => j]], i.\,e.~insert
+ a gluon. Returns an empty list for a ghost and raises an exception
+ for~$\epsilon$ and~$\bar\epsilon$. *)
+val tee : int -> free -> free list
+
+(* [dir i j arrow] returns the direction of the arrow relative to [j => i].
+ Returns 0 for a ghost and raises an exception for~$\epsilon$
+ and~$\bar\epsilon$. *)
+val dir : int -> int -> free -> int
+
+(* It's intuitive to use infix operators to construct the lines. *)
+val single : endpoint -> endpoint -> free
+val double : endpoint -> endpoint -> free list
+val ghost : endpoint -> free
+
+module Infix : sig
+
+ (* [single i j] or [i => j] creates a single line from [i] to [j] and
+ [i ==> j] is a shorthard for [[i => j]]. *)
+ val (=>) : int -> int -> free
+ val (==>) : int -> int -> free list
+
+ (* [double i j] or [i <=> j] creates a double line from [i] to [j] and back. *)
+ val (<=>) : int -> int -> free list
+
+ (* Single lines with subindices at the tip and/or tail *)
+ val (>=>) : int * int -> int -> free
+ val (=>>) : int -> int * int -> free
+ val (>=>>) : int * int -> int * int -> free
+
+ (* [?? i] creates a ghost at [i]. *)
+ val (??) : int -> free
+
+(* NB: I wanted to use [~~] instead of [??], but ocamlweb can't handle
+ operators starting with [~] in the index properly. *)
+
+end
+
+val epsilon : int list -> free_eps
+val epsilon_bar : int list -> free_eps_bar
+
+(* [chain [1;2;3]] is a shorthand for [[1 => 2; 2 => 3]] and
+ [cycle [1;2;3]] for [[1 => 2; 2 => 3; 3 => 1]]. Other lists
+ and edge cases are handled in the natural way. *)
+val chain : int list -> free list
+val cycle : int list -> free list
+
+module Test : sig val suite : OUnit.test val suite_long : OUnit.test end
+
+(* Pretty printer for the toplevel. *)
+val pp_free : Format.formatter -> free -> unit
+val pp_factor : Format.formatter -> factor -> unit
Index: trunk/omega/src/omega_NoH_rx.ml
===================================================================
--- trunk/omega/src/omega_NoH_rx.ml (revision 8899)
+++ trunk/omega/src/omega_NoH_rx.ml (revision 8900)
@@ -1,36 +1,27 @@
(* omega_NoH_rx.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
Marco Sekulla <marco.sekulla@kit.edu>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.Fortran)
- (Modellib_NoH.NoH(Modellib_NoH.NoH_k_matrix))
+module O = Omega.Mixed23(Target_Fortran.Make)(Modellib_NoH.NoH(Modellib_NoH.NoH_k_matrix))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/omega_UFO_Majorana.ml
===================================================================
--- trunk/omega/src/omega_UFO_Majorana.ml (revision 8899)
+++ trunk/omega/src/omega_UFO_Majorana.ml (revision 8900)
@@ -1,26 +1,26 @@
(* omega_UFO_Majorana.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Nary_Majorana(Targets.Fortran_Majorana)(UFO.Model)
+module O = Omega.Nary_Majorana(Target_Fortran.Make_Majorana)(UFO.Model)
let _ = O.main ()
Index: trunk/omega/src/color_Propagator.ml
===================================================================
--- trunk/omega/src/color_Propagator.ml (revision 0)
+++ trunk/omega/src/color_Propagator.ml (revision 8900)
@@ -0,0 +1,225 @@
+(* color_Propagator.ml --
+
+ Copyright (C) 2022-2023 by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+ with contributions from
+ Christian Speckner <cnspeckn@googlemail.com>
+
+ 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. *)
+
+type cf_in = int
+type cf_out = int
+
+type eps = cf_out list
+type s_eps = cf_out list
+type cf_in_or_eps =
+ | CF_in of cf_in
+ | Epsilon of eps
+
+type eps_bar = cf_in list
+type s_eps_bar = cf_in list
+type cf_out_or_eps_bar =
+ | CF_out of cf_out
+ | Epsilon_Bar of eps_bar
+
+type flow = cf_in PArray.t * cf_out PArray.t
+type flow_eps = cf_in_or_eps PArray.t * cf_out PArray.t
+type flow_eps_bar = cf_in PArray.t * cf_out_or_eps_bar PArray.t
+type t =
+ | Flow of flow
+ | Flow_with_Epsilons of flow_eps * s_eps list
+ | Flow_with_Epsilon_Bars of flow_eps_bar * s_eps_bar list
+ | Ghost
+ | Ghost_with_Epsilons of s_eps_bar list
+ | Ghost_with_Epsilon_Bars of s_eps_bar list
+
+(* For partial maps of ['a Map.t], an exception is the right
+ choice, since we would have to use ['a Map.fold] to
+ reconstruct resulting map completele. *)
+exception Fail
+
+let to_cf_in_opt cfi =
+ let project = function
+ | CF_in cf -> cf
+ | Epsilon _ -> raise Fail in
+ try Some (PArray.map project cfi) with Fail -> None
+
+let to_cf_out_opt cfo =
+ let project = function
+ | CF_out cf -> cf
+ | Epsilon_Bar _ -> raise Fail in
+ try Some (PArray.map project cfo) with Fail -> None
+
+let normalize = function
+ | (Ghost | Ghost_with_Epsilons _ | Ghost_with_Epsilon_Bars _ | Flow _) as flow -> flow
+ | Flow_with_Epsilons ((cfi, cfo), []) as flow ->
+ begin match to_cf_in_opt cfi with
+ | None -> flow
+ | Some cfi -> Flow (cfi, cfo)
+ end
+ | Flow_with_Epsilons (_, _ :: _) as flow -> flow
+ | Flow_with_Epsilon_Bars ((cfi, cfo), []) as flow ->
+ begin match to_cf_out_opt cfo with
+ | None -> flow
+ | Some cfo -> Flow (cfi, cfo)
+ end
+ | Flow_with_Epsilon_Bars (_, _ :: _) as flow -> flow
+
+let white = Flow (PArray.empty, PArray.empty)
+
+let of_lists cfi cfo =
+ let cfi = ThoList.mapi (fun n cf -> (n, cf)) 0 cfi
+ and cfo = ThoList.mapi (fun n cf -> (n, cf)) 0 cfo in
+ Flow (PArray.of_pairs cfi, PArray.of_pairs cfo)
+
+let is_white = function
+ | Flow (incoming, outgoing) -> PArray.is_empty incoming && PArray.is_empty outgoing
+ | Flow_with_Epsilons (_, _) | Flow_with_Epsilon_Bars (_, _) -> false
+ | Ghost | Ghost_with_Epsilons _ | Ghost_with_Epsilon_Bars _ -> false
+
+let cfi_or_eps_to_cfo_or_eps_bar = function
+ | CF_in cf -> CF_out cf
+ | Epsilon eps -> Epsilon_Bar eps
+
+let cfo_or_eps_bar_to_cfi_or_eps = function
+ | CF_out cf -> CF_in cf
+ | Epsilon_Bar eps -> Epsilon eps
+
+let conjugate = function
+ | Flow (cfi, cfo) -> Flow (cfo, cfi)
+ | Flow_with_Epsilons ((cfi, cfo), eps) ->
+ Flow_with_Epsilon_Bars ((cfo, PArray.map cfi_or_eps_to_cfo_or_eps_bar cfi), eps)
+ | Flow_with_Epsilon_Bars ((cfi, cfo), eps) ->
+ Flow_with_Epsilons ((PArray.map cfo_or_eps_bar_to_cfi_or_eps cfo, cfi), eps)
+ | Ghost -> Ghost
+ | Ghost_with_Epsilons eps -> Ghost_with_Epsilon_Bars eps
+ | Ghost_with_Epsilon_Bars eps -> Ghost_with_Epsilons eps
+
+let cf_in_or_eps_to_string = function
+ | CF_in i -> string_of_int i
+ | Epsilon cfos -> Printf.sprintf "E(%s)" (ThoList.to_string string_of_int cfos)
+
+let cf_out_or_eps_bar_to_string = function
+ | CF_out i -> string_of_int i
+ | Epsilon_Bar cfis -> Printf.sprintf "B(%s)" (ThoList.to_string string_of_int cfis)
+
+let cf_in_out_to_string cfi cfo =
+ match PArray.is_empty cfi, PArray.is_empty cfo with
+ | true, true -> "W"
+ | false, true -> Printf.sprintf "I(%s)" (PArray.to_string string_of_int cfi)
+ | true, false -> Printf.sprintf "O(%s)" (PArray.to_string string_of_int cfo)
+ | false, false ->
+ Printf.sprintf "IO(%s,%s)"
+ (PArray.to_string string_of_int cfi)
+ (PArray.to_string string_of_int cfo)
+
+let to_string = function
+ | Ghost -> "G"
+ | Flow (cfi, cfo) -> cf_in_out_to_string cfi cfo
+ | Ghost_with_Epsilons epsilons ->
+ failwith "Color_Propagator.to_string: incomplete"
+ | Ghost_with_Epsilon_Bars epsilon_bars ->
+ failwith "Color_Propagator.to_string: incomplete"
+ | Flow_with_Epsilons ((cfi, cfo), epsilons) ->
+ failwith "Color_Propagator.to_string: incomplete"
+ | Flow_with_Epsilon_Bars ((cfi, cfo), epsilon_bars) ->
+ failwith "Color_Propagator.to_string: incomplete"
+
+let digit_option_to_symbol = function
+ | None -> "_"
+ | Some i ->
+ if i < 0 then
+ invalid_arg "Color_Propagator.digit_option_to_symbol: negative"
+ else
+ if i < 10 then
+ string_of_int i
+ else if i < 36 then
+ String.make 1 (Char.chr (Char.code 'A' + i - 10))
+ else
+ invalid_arg "Color_Propagator.digit_option_to_symbol: too large"
+
+let cf_in_cf_out_to_symbol cfi cfo =
+ match PArray.to_option_list cfi, PArray.to_option_list cfo with
+ | [], [] -> "w"
+ | cfi, [] -> "i" ^ String.concat "" (List.map digit_option_to_symbol cfi)
+ | [], cfo -> "o" ^ String.concat "" (List.map digit_option_to_symbol cfo)
+ | cfi, cfo ->
+ "i" ^ String.concat "" (List.map digit_option_to_symbol cfi) ^
+ "_o" ^ String.concat "" (List.map digit_option_to_symbol cfo)
+
+let to_symbol = function
+ | Ghost -> "g"
+ | Flow (cfi, cfo) -> cf_in_cf_out_to_symbol cfi cfo
+ | Ghost_with_Epsilons epsilons ->
+ failwith "Color_Propagator.to_string: incomplete"
+ | Ghost_with_Epsilon_Bars epsilon_bars ->
+ failwith "Color_Propagator.to_string: incomplete"
+ | Flow_with_Epsilons ((cfi, cfo), epsilons) ->
+ failwith "Color_Propagator.to_string: incomplete"
+ | Flow_with_Epsilon_Bars ((cfi, cfo), epsilon_bars) ->
+ failwith "Color_Propagator.to_string: incomplete"
+
+let pp fmt p =
+ Format.fprintf fmt "%s" (to_string p)
+
+let compare_pairs compare_x compare_y (x1, y1) (x2, y2) =
+ let c = compare_x x1 x2 in
+ if c <> 0 then
+ c
+ else
+ compare_y y1 y2
+
+let compare_flows p1 p2 =
+ compare_pairs (PArray.compare compare) (PArray.compare compare) p1 p2
+
+let compare_eps e1 e2 =
+ compare_pairs (compare_pairs (PArray.compare compare) (PArray.compare compare)) compare e1 e2
+
+let compare p1 p2 =
+ match normalize p1, normalize p2 with
+ | Flow f1, Flow f2 -> compare_flows f1 f2
+ | Flow_with_Epsilons (f1, e1), Flow_with_Epsilons (f2, e2) -> compare_eps (f1, e1) (f2, e2)
+ | Flow_with_Epsilon_Bars (f1, e1), Flow_with_Epsilon_Bars (f2, e2) -> compare_eps (f1, e1) (f2, e2)
+ | Ghost, Ghost -> 0
+ | Ghost_with_Epsilons e1, Ghost_with_Epsilons e2 -> compare e1 e2
+ | Ghost_with_Epsilon_Bars e1, Ghost_with_Epsilon_Bars e2 -> compare e1 e2
+
+ | Flow _, (Flow_with_Epsilons _ | Flow_with_Epsilon_Bars _ | Ghost
+ | Ghost_with_Epsilons _ | Ghost_with_Epsilon_Bars _)
+ | Flow_with_Epsilons _, (Flow_with_Epsilon_Bars _ | Ghost
+ | Ghost_with_Epsilons _ | Ghost_with_Epsilon_Bars _)
+ | Flow_with_Epsilon_Bars _ , (Ghost | Ghost_with_Epsilons _ | Ghost_with_Epsilon_Bars _)
+ | Ghost, (Ghost_with_Epsilons _ | Ghost_with_Epsilon_Bars _)
+ | Ghost_with_Epsilons _, Ghost_with_Epsilon_Bars _ -> -1
+
+ | (Flow_with_Epsilons _ | Flow_with_Epsilon_Bars _ | Ghost
+ | Ghost_with_Epsilons _ | Ghost_with_Epsilon_Bars _), Flow _
+ | (Flow_with_Epsilon_Bars _ | Ghost
+ | Ghost_with_Epsilons _ | Ghost_with_Epsilon_Bars _), Flow_with_Epsilons _
+ | (Ghost | Ghost_with_Epsilons _ | Ghost_with_Epsilon_Bars _), Flow_with_Epsilon_Bars _
+ | (Ghost_with_Epsilons _ | Ghost_with_Epsilon_Bars _), Ghost
+ | Ghost_with_Epsilon_Bars _, Ghost_with_Epsilons _ -> 1
+
+let equal p1 p2 =
+ compare p1 p2 = 0
+
+(* Since [PArray.Alist.t] has a unique physical representation, we can fall back
+ on the polymorphic [compare] again. *)
+
+let compare = compare
+let equal = (=)
Index: trunk/omega/src/color.ml
===================================================================
--- trunk/omega/src/color.ml (revision 8899)
+++ trunk/omega/src/color.ml (revision 8900)
@@ -1,4031 +1,800 @@
(* color.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-(* Avoid refering to [Pervasives.compare], because [Pervasives] will
- become [Stdlib.Pervasives] in O'Caml 4.07 and [Stdlib] in O'Caml 4.08. *)
-let pcompare = compare
-
module type Test =
sig
val suite : OUnit.test
val suite_long : OUnit.test
end
(* \thocwmodulesection{Quantum Numbers} *)
type t =
| Singlet
| SUN of int
| AdjSUN of int
+ | YT of int Young.tableau
+ | YTC of int Young.tableau
let conjugate = function
| Singlet -> Singlet
| SUN n -> SUN (-n)
| AdjSUN n -> AdjSUN n
+ | YT y -> YTC y
+ | YTC y -> YT y
let compare c1 c2 =
match c1, c2 with
| Singlet, Singlet -> 0
| Singlet, _ -> -1
| _, Singlet -> 1
| SUN n, SUN n' -> compare n n'
| SUN _, AdjSUN _ -> -1
| AdjSUN _, SUN _ -> 1
| AdjSUN n, AdjSUN n' -> compare n n'
-
-module type Line =
- sig
- type t
- val conj : t -> t
- val equal : t -> t -> bool
- val to_string : t -> string
- end
-
-module type Cycles =
- sig
-
- type line
- type t = (line * line) list
-
-(* Contract the graph by connecting lines and return the number of
- cycles together with the contracted graph.
- \begin{dubious}
- The semantics of the contracted graph is not yet 100\%ly fixed.
- \end{dubious} *)
- val contract : t -> int * t
-
-(* The same as [contract], but returns only the number of cycles
- and raises [Open_line] when not all lines are closed. *)
- val count : t -> int
- exception Open_line
-
- (* Mainly for debugging \ldots *)
- val to_string : t -> string
-
- end
-
-module Cycles (L : Line) : Cycles with type line = L.t =
- struct
-
- type line = L.t
- type t = (line * line) list
-
- exception Open_line
-
-(* NB: The following algorithm for counting the cycles is quadratic since it
- performs nested scans of the lists. If this was a serious problem one could
- replace the lists of pairs by a [Map] and replace one power by a logarithm. *)
-
- let rec find_fst c_final c1 disc seen = function
- | [] -> ((L.conj c_final, c1) :: disc, List.rev seen)
- | (c1', c2') as c12' :: rest ->
- if L.equal c1 c1' then
- find_snd c_final (L.conj c2') disc [] (List.rev_append seen rest)
- else
- find_fst c_final c1 disc (c12' :: seen) rest
-
- and find_snd c_final c2 disc seen = function
- | [] -> ((L.conj c_final, L.conj c2) :: disc, List.rev seen)
- | (c1', c2') as c12' :: rest->
- if L.equal c2' c2 then begin
- if L.equal c1' c_final then
- (disc, List.rev_append seen rest)
- else
- find_fst c_final (L.conj c1') disc [] (List.rev_append seen rest)
- end else
- find_snd c_final c2 disc (c12' :: seen) rest
-
- let consume = function
- | [] -> ([], [])
- | (c1, c2) :: rest -> find_snd (L.conj c1) (L.conj c2) [] [] rest
-
- let contract lines =
- let rec contract' acc disc = function
- | [] -> (acc, List.rev disc)
- | rest ->
- begin match consume rest with
- | [], rest' -> contract' (succ acc) disc rest'
- | disc', rest' -> contract' acc (List.rev_append disc' disc) rest'
- end in
- contract' 0 [] lines
-
- let count lines =
- match contract lines with
- | n, [] -> n
- | n, _ -> raise Open_line
-
- let to_string lines =
- String.concat ""
- (List.map
- (fun (c1, c2) -> "[" ^ L.to_string c1 ^ "," ^ L.to_string c2 ^ "]")
- lines)
-
- end
+ | YT y, YT y' -> compare y y'
+ | YT _, YTC _ -> -1
+ | YTC _, YT _ -> 1
+ | YTC y, YTC y' -> compare y y'
+ | _, (YT _ | YTC _) -> -1
+ | (YT _ | YTC _) , _ -> 1
(* \thocwmodulesection{Color Flows} *)
module type Flow =
sig
type color
type t = color list * color list
val rank : t -> int
val of_list : int list -> color
val ghost : unit -> color
val to_lists : t -> int list list
val in_to_lists : t -> int list list
val out_to_lists : t -> int list list
val ghost_flags : t -> bool list
val in_ghost_flags : t -> bool list
val out_ghost_flags : t -> bool list
type power = { num : int; den : int; power : int }
type factor = power list
val factor : t -> t -> factor
val zero : factor
+ val factor_table : t list -> factor array array
module Test : Test
end
module Flow : Flow =
struct
(* All [int]s are non-zero! *)
type color =
- | N of int
- | N_bar of int
- | SUN of int * int
- | Singlet
+ | Flow of Color_Propagator.flow
| Ghost
+ let to_cp = function
+ | Flow cf -> Color_Propagator.Flow cf
+ | Ghost -> Color_Propagator.Ghost
+
+ let color_to_string c =
+ Color_Propagator.to_string (to_cp c)
+
(* Incoming and outgoing, since we need to cross the incoming states. *)
type t = color list * color list
let rank cflow =
2
(* \thocwmodulesubsection{Constructors} *)
let ghost () =
Ghost
let of_list = function
- | [0; 0] -> Singlet
- | [c; 0] -> N c
- | [0; c] -> N_bar c
- | [c1; c2] -> SUN (c1, c2)
+ | [0; 0] -> Flow (PArray.empty, PArray.empty)
+ | [c; 0] -> Flow (PArray.of_pairs [(1, c)], PArray.empty)
+ | [0; c] -> Flow (PArray.empty, PArray.of_pairs [(1, -c)])
+ | [c1; c2] -> Flow (PArray.of_pairs [(1, c1)], PArray.of_pairs [(1, -c2)])
| _ -> invalid_arg "Color.Flow.of_list: num_lines != 2"
let to_list = function
- | N c -> [c; 0]
- | N_bar c -> [0; c]
- | SUN (c1, c2) -> [c1; c2]
- | Singlet -> [0; 0]
| Ghost -> [0; 0]
+ | Flow (cfi, cfo) ->
+ begin match PArray.to_pairs cfi, PArray.to_pairs cfo with
+ | [], [] -> [0; 0]
+ | [(1, c)], [] -> [c; 0]
+ | [], [(1, c)] -> [0; -c]
+ | [(1, c1)], [(1, c2)] -> [c1; -c2]
+ | _, _ -> failwith "Color.Flow.to_list: incomplete"
+ end
let to_lists (cfin, cfout) =
(List.map to_list cfin) @ (List.map to_list cfout)
let in_to_lists (cfin, _) =
List.map to_list cfin
let out_to_lists (_, cfout) =
List.map to_list cfout
let ghost_flag = function
- | N _ | N_bar _ | SUN (_, _) | Singlet -> false
+ | Flow _ -> false
| Ghost -> true
let ghost_flags (cfin, cfout) =
(List.map ghost_flag cfin) @ (List.map ghost_flag cfout)
let in_ghost_flags (cfin, _) =
List.map ghost_flag cfin
let out_ghost_flags (_, cfout) =
List.map ghost_flag cfout
(* \thocwmodulesubsection{Evaluation} *)
type power = { num : int; den : int; power : int }
type factor = power list
let zero = []
- let count_ghosts1 colors =
- List.fold_left
- (fun acc -> function Ghost -> succ acc | _ -> acc)
- 0 colors
-
- let count_ghosts (fin, fout) =
- count_ghosts1 fin + count_ghosts1 fout
-
- type 'a square =
- | Square of 'a
- | Mismatch
+ let factor_to_string = function
+ | [] -> "0"
+ | factor ->
+ String.concat "+"
+ (List.map
+ (fun p ->
+ Printf.sprintf
+ "%d%s%s"
+ p.num
+ (if p.den <> 1 then "/" ^ string_of_int p.den else "")
+ (match p.power with
+ | 0 -> ""
+ | 1 -> "*N"
+ | n -> "*N^" ^ string_of_int n))
+ factor)
let conjugate = function
- | N c -> N_bar (-c)
- | N_bar c -> N (-c)
- | SUN (c1, c2) -> SUN (-c2, -c1)
- | Singlet -> Singlet
+ | Flow (cfi, cfo) -> Flow (cfo, cfi)
| Ghost -> Ghost
let cross_in (cin, cout) =
cin @ (List.map conjugate cout)
let cross_out (cin, cout) =
(List.map conjugate cin) @ cout
- module C = Cycles (struct
- type t = int
- let conj = (~-)
- let equal = (=)
- let to_string = string_of_int
- end)
-
-(* Match lines in the color flows [f1] and [f2] after crossing the
- incoming states. This will be used to compute squared diagrams
- in [square] and [square2] below. *)
-
- let match_lines match1 match2 f1 f2 =
- let rec match_lines' acc f1' f2' =
- match f1', f2' with
-
- (* If we encounter an empty list, we're done --- unless the
- lengths don't match (which should never happen!): *)
- | [], [] -> Square (List.rev acc)
- | _ :: _, [] | [], _ :: _ -> Mismatch
-
- (* Handle matching \ldots *)
- | Ghost :: rest1, Ghost :: rest2
- | Singlet :: rest1, Singlet :: rest2 ->
- match_lines' acc rest1 rest2
-
- (* \ldots{} and mismatched ghosts and singlet gluons: *)
- | Ghost :: _, Singlet :: _
- | Singlet :: _, Ghost :: _ ->
- Mismatch
-
- (* Ghosts and singlet gluons can't match anything else *)
- | (Ghost | Singlet) :: _, (N _ | N_bar _ | SUN (_, _)) :: _
- | (N _ | N_bar _ | SUN (_, _)) :: _, (Ghost | Singlet) :: _ ->
- Mismatch
-
- (* Handle matching \ldots *)
- | N_bar c1 :: rest1, N_bar c2 :: rest2
- | N c1 :: rest1, N c2 :: rest2 ->
- match_lines' (match1 c1 c2 acc) rest1 rest2
-
- (* \ldots{} and mismatched $N$ or $\bar N$ states: *)
- | N _ :: _, N_bar _ :: _
- | N_bar _ :: _, N _ :: _ ->
- Mismatch
-
- (* The $N$ and $\bar N$ don't match non-singlet gluons: *)
- | (N _ | N_bar _) :: _, SUN (_, _) :: _
- | SUN (_, _) :: _, (N _ | N_bar _) :: _ ->
- Mismatch
-
- (* Now we're down to non-singlet gluons: *)
- | SUN (c1, c1') :: rest1, SUN (c2, c2') :: rest2 ->
- match_lines' (match2 c1 c1' c2 c2' acc) rest1 rest2 in
-
- match_lines' [] (cross_out f1) (cross_out f2)
-
-(* NB: in WHIZARD versions before 3.0, the code for [match_lines]
- contained a bug in the pattern matching of [Singlet], [N], [N_bar]
- and [SUN] states, because they all were represented as
- [SUN (c1, c2)], only distinguished by the numeric conditions
- [c1 = 0] and/or [c2 = 0].
- This prevented the use of exhaustiveness checking and introduced a
- subtle dependence on the pattern order. *)
-
- let square f1 f2 =
- match_lines
- (fun c1 c2 pairs -> (c1, c2) :: pairs)
- (fun c1 c1' c2 c2' pairs -> (c1', c2') :: (c1, c2) :: pairs)
- f1 f2
-
-(*i
- let square f1 f2 =
- let ll2s ll =
- String.concat "; "
- (List.map (ThoList.to_string string_of_int) ll)
- and lp2s lp =
- String.concat "; "
- (List.map
- (fun (c1, c2) ->
- string_of_int c1 ^ ", " ^ string_of_int c2)
- lp) in
- Printf.eprintf
- "square ([%s], [%s]) ([%s], [%s]) = "
- (ll2s (in_to_lists f1)) (ll2s (out_to_lists f1))
- (ll2s (in_to_lists f2)) (ll2s (out_to_lists f2));
- let res = square f1 f2 in
- begin match res with
- | Mismatch -> Printf.eprintf "Mismatch!\n"
- | Square f12 -> Printf.eprintf "Square [%s]\n" (lp2s f12)
- end;
- res
-i*)
-
-(* In addition to counting closed color loops, we also need to count closed
- gluon loops. Fortunately, we can use the same algorithm on a different
- data type, provided it doesn't require all lines to be closed. *)
-
- module C2 = Cycles (struct
- type t = int * int
- let conj (c1, c2) = (- c2, - c1)
- let equal (c1, c2) (c1', c2') = c1 = c1' && c2 = c2'
- let to_string (c1, c2) = "(" ^ string_of_int c1 ^ "," ^ string_of_int c2 ^ ")"
- end)
-
- let square2 f1 f2 =
- match_lines
- (fun c1 c2 pairs -> pairs)
- (fun c1 c1' c2 c2' pairs -> ((c1, c1'), (c2, c2')) :: pairs)
- f1 f2
-
-(* $\ocwlowerid{int\_power}: n\, p \to n^p$
- for integers is missing from [Pervasives]! *)
-
- let int_power n p =
- let rec int_power' acc i =
- if i < 0 then
- invalid_arg "int_power"
- else if i = 0 then
- acc
- else
- int_power' (n * acc) (pred i) in
- int_power' 1 p
-
-(* Instead of implementing a full fledged algebraic evaluator, let's
- simply expand the binomial by hand:
- \begin{equation}
- \left(\frac{N_C^2-2}{N_C^2}\right)^n =
- \sum_{i=0}^n \binom{n}{i} (-2)^i N_C^{-2i}
- \end{equation} *)
-
-(* NB: Any result of [square] other than [Mismatch] guarantees
- [count_ghosts f1 = count_ghosts f2]. *)
-
- let factor f1 f2 =
- match square f1 f2, square2 f1 f2 with
- | Mismatch, _ | _, Mismatch -> []
- | Square f12, Square f12' ->
- let num_cycles = C.count f12
- and num_cycles2, disc = C2.contract f12'
- and num_ghosts = count_ghosts f1 in
-(*i Printf.eprintf "f12 = %s -> #loops = %d\n"
- (C.to_string f12) num_cycles;
- Printf.eprintf "f12' = %s -> #loops = %d, disc = %s\n"
- (C2.to_string f12') num_cycles2 (C2.to_string disc);
- flush stderr; i*)
- List.map
- (fun i ->
- let parity = if num_ghosts mod 2 = 0 then 1 else -1
- and power = num_cycles - num_ghosts in
- let coeff = int_power (-2) i * Combinatorics.binomial num_cycles2 i
- and power2 = - 2 * i in
- { num = parity * coeff;
- den = 1;
- power = power + power2 })
- (ThoList.range 0 num_cycles2)
-
- module Test : Test =
- struct
+(* \thocwmodulesubsection{Handling $\tr(F_{\mu\nu}F^{\mu\nu})$ couplings, a.k.a.~$Hgg$}
- open OUnit
-
-(* Here and elsewhere, we have to resist the temptation to define
- these tests as functions with an additional argument [()] in the
- hope to avoid having to package them into an explicit thunk
- [fun () -> eq v1 v2] in order to delay
- evaluation. It turns out that the runtime would then sometimes
- evaluate the argument [v1] or [v2] even \emph{before} the test
- is run. For pure functions, there is no difference, but the
- compiler appears to treat explicit thunks specially.
+ If the model contains couplings of the form $\tr(F_{\mu\nu}F^{\mu\nu})$,
+ e.\,g.~the effective $Hgg$ couplings, the color flow rules and the evaluation
+ of color weights require special care.
+ These couplings are problematic in our recursive construction, since
+ fusing a colorless state with a $\mathrm{U}(1)$ ghost produces
+ a trace gluon in addition to a $\mathrm{U}(1)$ ghost. But for this
+ fresh trace gluon, no canonical color flow index is available!
\begin{dubious}
- I haven't yet managed to construct a small demonstrator to find
- out in which circumstances the premature evaluation happens.
- \end{dubious} *)
-
- let suite_square =
- "square" >:::
-
- [ "square ([], []) ([], [])" >::
- (fun () ->
- assert_equal (Square []) (square ([], []) ([], [])));
-
- "square ([3], [3; 0]) ([3], [3; 0])" >::
- (fun () ->
- assert_equal
- (Square [(-1, -1); (1, 1)])
- (square
- ([N 1], [N 1; Singlet])
- ([N 1], [N 1; Singlet])));
-
- "square ([0], [3; -3]) ([0], [3; -3])" >::
- (fun () ->
- assert_equal
- (Square [(1, 1); (-1, -1)])
- (square
- ([Singlet], [N 1; N_bar (-1)])
- ([Singlet], [N 1; N_bar (-1)])));
-
- "square ([3], [3; 0]) ([0], [3; -3])" >::
- (fun () ->
- assert_equal
- Mismatch
- (square
- ([N 1], [N 1; Singlet])
- ([Singlet], [N 1; N_bar (-1)])));
-
- "square ([3; 8], [3]) ([3; 8], [3])" >::
- (fun () ->
- assert_equal
- (Square [-1, -1; 1, 1; -2, -2; 2, 2])
- (square
- ([N 1; SUN (2, -1)], [N 2])
- ([N 1; SUN (2, -1)], [N 2]))) ]
-
- let suite =
- "Color.Flow" >:::
- [suite_square]
-
- let suite_long =
- "Color.Flow long" >:::
- []
-
- end
- end
-
-(* later: *)
-
-module General_Flow =
- struct
-
- type color =
- | Lines of int list
- | Ghost of int
-
- type t = color list * color list
-
- let rank_default = 2 (* Standard model *)
-
- let rank cflow =
- try
- begin match List.hd cflow with
- | Lines lines -> List.length lines
- | Ghost n_lines -> n_lines
- end
- with
- | _ -> rank_default
- end
-
-(* \thocwmodulesection{Vertex Color Flows} *)
-
-(* \newcommand{\setupFourAmp}{%
+ A possible solution could be the introduction of ``wild card'' color flow
+ that are replaced be concrete color flows only at the matching of the
+ brakets. This is worth investigating, but can be postponed in favor of the
+ well tested pragmatic approach.
+ \end{dubious} *)
+
+(* There are three different cases to consider:
+ \begin{enumerate}
+ \item
+ First consider the case that neither gluon is directly connected by a string
+ of such couplings to the external states. In this case, the gluons must be
+ connected to matter, since the gluon self couplings contain no ghost terms.
+ Fortunately, if suffices to ajust the ghost-ghost coupling to account for the
+ missing ghost-trace couplings.
+
+ The prototypical example is Higgs production in $q\bar q$ scattering via the
+ effective $Hgg$ coupling expanded as in~\cite{Kilian:2012pz}:
+ \newcommand{\setupFiveAmp}{%
\fmfleft{i1,i2}
\fmfright{o1,o2}
+ \fmftop{H}
\fmf{phantom}{i1,v1,i2}
\fmf{phantom}{o2,v2,o1}
- \fmf{phantom}{v1,v2}
+ \fmf{phantom}{v1,vH,v2}
\fmffreeze}
- \fmfcmd{%
- numeric joindiameter;
- joindiameter := 7thick;}
- \fmfcmd{%
- vardef sideways_at (expr d, p, frac) =
- save len; len = length p;
- (point frac*len of p) shifted ((d,0) rotated (90 + angle direction frac*len of p))
- enddef;
- secondarydef p sideways d =
- for frac = 0 step 0.01 until 0.99:
- sideways_at (d, p, frac) ..
- endfor
- sideways_at (d, p, 1)
- enddef;
- secondarydef p choptail d =
- subpath (ypart (fullcircle scaled d shifted (point 0 of p) intersectiontimes p), infinity) of p
- enddef;
- secondarydef p choptip d =
- reverse ((reverse p) choptail d)
- enddef;
- secondarydef p pointtail d =
- fullcircle scaled d shifted (point 0 of p) intersectionpoint p
- enddef;
- secondarydef p pointtip d =
- (reverse p) pointtail d
- enddef;
- secondarydef pa join pb =
- pa choptip joindiameter .. pb choptail joindiameter
- enddef;
- vardef cyclejoin (expr p) =
- subpath (0.5*length p, infinity) of p join subpath (0, 0.5*length p) of p .. cycle
- enddef;}
- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
- \fmfcmd{%
- style_def double_line_arrow expr p =
- save pi, po;
- path pi, po;
- pi = reverse (p sideways thick);
- po = p sideways -thick;
- cdraw pi;
- cdraw po;
- cfill (arrow (subpath (0, 0.9 length pi) of pi));
- cfill (arrow (subpath (0, 0.9 length po) of po));
- enddef;}
- \fmfcmd{%
- style_def double_line_arrow_beg expr p =
- save pi, po, pc;
- path pi, po, pc;
- pc = p choptail 7thick;
- pi = reverse (pc sideways thick);
- po = pc sideways -thick;
- cdraw pi .. p pointtail 5thick .. po;
- cfill (arrow pi);
- cfill (arrow po);
- enddef;}
- \fmfcmd{%
- style_def double_line_arrow_end expr p =
- save pi, po, pc;
- path pi, po, pc;
- pc = p choptip 7thick;
- pi = reverse (pc sideways thick);
- po = pc sideways -thick;
- cdraw po .. p pointtip 5thick .. pi;
- cfill (arrow pi);
- cfill (arrow po);
- enddef;}
- \fmfcmd{%
- style_def double_line_arrow_both expr p =
- save pi, po, pc;
- path pi, po, pc;
- pc = p choptip 7thick choptail 7thick;
- pi = reverse (pc sideways thick);
- po = pc sideways -thick;
- cdraw po .. p pointtip 5thick .. pi .. p pointtail 5thick .. cycle;
- cfill (arrow pi);
- cfill (arrow po);
- enddef;}
- \fmfcmd{%
- style_def double_arrow_parallel expr p =
- save pi, po;
- path pi, po;
- pi = p sideways thick;
- po = p sideways -thick;
- save li, lo;
- li = length pi;
- lo = length po;
- cdraw pi;
- cdraw po;
- cfill (arrow pi);
- cfill (arrow po);
- enddef;}
- \fmfcmd{%
- style_def double_arrow_crossed_beg expr p =
- save lp; lp = length p;
- save pi, po;
- path pi, po;
- pi = p sideways thick;
- po = p sideways -thick;
- save li, lo;
- li = length pi;
- lo = length po;
- cdraw subpath (0, 0.1 li) of pi .. subpath (0.3 lo, lo) of po;
- cdraw subpath (0, 0.1 lo) of po .. subpath (0.3 li, li) of pi;
- cfill (arrow pi);
- cfill (arrow po);
- enddef;}
- \fmfcmd{%
- style_def double_arrow_crossed_end expr p =
- save lp; lp = length p;
- save pi, po;
- path pi, po;
- pi = p sideways thick;
- po = p sideways -thick;
- save li, lo;
- li = length pi;
- lo = length po;
- cdraw subpath (0, 0.7 li) of pi .. subpath (0.9 lo, lo) of po;
- cdraw subpath (0, 0.7 lo) of po .. subpath (0.9 li, li) of pi;
- cfill (arrow pi);
- cfill (arrow po);
- enddef;} *)
-
-(* \thocwmodulesubsection{Arrows and Epsilons} *)
-module type Arrow =
- sig
- type endpoint
- type tip = endpoint
- type tail = endpoint
- type ghost = endpoint
- val position : endpoint -> int
- val relocate : (int -> int) -> endpoint -> endpoint
- type ('tail, 'tip, 'ghost) t =
- | Arrow of 'tail * 'tip
- | Ghost of 'ghost
- type 'tip eps = 'tip list
- type 'tail eps_bar = 'tail list
- type free = (tail, tip, ghost) t
- type free_eps = tip eps
- type free_eps_bar = tail eps_bar
- type factor
- type factor_eps
- type factor_eps_bar
- val tips : free -> tip list
- val tips_eps : free_eps -> tip list
- val tails : free -> tail list
- val tails_eps_bar : free_eps_bar -> tail list
- val free_to_string : free -> string
- val free_eps_to_string : free_eps -> string
- val free_eps_bar_to_string : free_eps_bar -> string
- val factor_to_string : factor -> string
- val factor_eps_to_string : factor_eps -> string
- val factor_eps_bar_to_string : factor_eps_bar -> string
- val map : (endpoint -> endpoint) -> free -> free
- val to_left_factor : (endpoint -> bool) -> free -> factor
- val to_left_factor_eps : (endpoint -> bool) -> free_eps -> factor_eps
- val to_left_factor_eps_bar : (endpoint -> bool) -> free_eps_bar -> factor_eps_bar
- val to_right_factor : (endpoint -> bool) -> free -> factor
- val to_right_factor_eps : (endpoint -> bool) -> free_eps -> factor_eps
- val to_right_factor_eps_bar : (endpoint -> bool) -> free_eps_bar -> factor_eps_bar
- val of_factor : factor -> free
- val of_factor_eps : factor_eps -> free_eps
- val of_factor_eps_bar : factor_eps_bar -> free_eps_bar
- val is_free : factor -> bool
- val is_free_eps : factor_eps -> bool
- val is_free_eps_bar : factor_eps_bar -> bool
- val negatives : free -> endpoint list
- val negatives_eps : free_eps -> endpoint list
- val negatives_eps_bar : free_eps_bar -> endpoint list
- val is_ghost : free -> bool
- val is_tadpole : factor -> bool
- type merge =
- | Match of factor
- | Ghost_Match
- | Loop_Match
- | Mismatch
- | No_Match
- val merge_arrow_arrow : factor -> factor -> merge
- type 'a merge_eps =
- | Match_Eps of 'a
- | Mismatch_Eps
- | No_Match_Eps
- val merge_arrow_eps : factor -> factor_eps -> factor_eps merge_eps
- val merge_arrow_eps_bar : factor -> factor_eps_bar -> factor_eps_bar merge_eps
- val merge_eps_eps_bar : factor_eps -> factor_eps_bar -> (factor list list * factor list list) option
- val tee : int -> free -> free list
- val dir : int -> int -> free -> int
- val single : endpoint -> endpoint -> free
- val double : endpoint -> endpoint -> free list
- val ghost : endpoint -> free
- module Infix : sig
- val (=>) : int -> int -> free
- val (==>) : int -> int -> free list
- val (<=>) : int -> int -> free list
- val (>=>) : int * int -> int -> free
- val (=>>) : int -> int * int -> free
- val (>=>>) : int * int -> int * int -> free
- val (??) : int -> free
- end
- val epsilon : int list -> free_eps
- val epsilon_bar : int list -> free_eps_bar
- val chain : int list -> free list
- val cycle : int list -> free list
- module Test : Test
- val pp_free : Format.formatter -> free -> unit
- val pp_factor : Format.formatter -> factor -> unit
- end
-
-module Arrow : Arrow =
- struct
-
- type endpoint =
- | I of int
- | M of int * int
-
- let position = function
- | I i -> i
- | M (i, _) -> i
-
- let relocate f = function
- | I i -> I (f i)
- | M (i, n) -> M (f i, n)
-
- type tip = endpoint
- type tail = endpoint
- type ghost = endpoint
-
- (* Note that in the case of double lines for the adjoint
- representation the \emph{same} [endpoint] appears twice:
- once as a [tip] and once as a [tail]. If we want to
- multiply two factors by merging arrows with matching
- [tip] and [tail], we must make sure that the [tip] is from
- one factor and the [tail] from the other factor. *)
-
- (* The [Free] variant contains positive indices
- as well as negative indices that don't appear on both sides
- and will be summed in a later product. [SumL] and [SumR]
- indices appear on both sides. *)
- type 'a index =
- | Free of 'a
- | SumL of 'a
- | SumR of 'a
-
- let is_free_index = function
- | Free _ -> true
- | SumL _ | SumR _ -> false
-
- type ('tail, 'tip, 'ghost) t =
- | Arrow of 'tail * 'tip
- | Ghost of 'ghost
- type 'tip eps = 'tip list
- type 'tail eps_bar = 'tail list
-
- type free = (tail, tip, ghost) t
- type free_eps = tip eps
- type factor_eps = tip index eps
-
- type factor = (tail index, tip index, ghost index) t
- type free_eps_bar = tail eps_bar
- type factor_eps_bar = tail index eps_bar
-
- let tips = function
- | Arrow (_, tip) -> [tip]
- | Ghost _ -> []
- let tails = function
- | Arrow (tail, _) -> [tail]
- | Ghost _ -> []
- let tips_eps tips = tips
- let tails_eps_bar tails = tails
-
- let endpoint_to_string = function
- | I i -> string_of_int i
- | M (i, n) -> Printf.sprintf "%d.%d" i n
-
- let index_to_string = function
- | Free i -> endpoint_to_string i
- | SumL i -> endpoint_to_string i ^ "L"
- | SumR i -> endpoint_to_string i ^ "R"
-
- let to_string i2s = function
- | Arrow (tail, tip) -> Printf.sprintf "%s>%s" (i2s tail) (i2s tip)
- | Ghost ghost -> Printf.sprintf "{%s}" (i2s ghost)
- let to_string_eps i2s tips = Printf.sprintf ">>>%s" (ThoList.to_string i2s tips)
- let to_string_eps_bar i2s tails = Printf.sprintf "<<<%s" (ThoList.to_string i2s tails)
-
- let free_to_string = to_string endpoint_to_string
- let free_eps_to_string = to_string_eps endpoint_to_string
- let free_eps_bar_to_string = to_string_eps_bar endpoint_to_string
-
- let factor_to_string = to_string index_to_string
- let factor_eps_to_string = to_string_eps index_to_string
- let factor_eps_bar_to_string = to_string_eps_bar index_to_string
-
- let index_matches i1 i2 =
- match i1, i2 with
- | SumL i1, SumR i2 | SumR i1, SumL i2 -> i1 = i2
- | _ -> false
-
- let map f = function
- | Arrow (tail, tip) -> Arrow (f tail, f tip)
- | Ghost ghost -> Ghost (f ghost)
- let map_eps = List.map
- let map_eps_bar = List.map
-
- let free_index = function
- | Free i -> i
- | SumL i -> invalid_arg "Color.Arrow.free_index: leftover LHS summation"
- | SumR i -> invalid_arg "Color.Arrow.free_index: leftover RHS summation"
-
- let to_left_index is_sum i =
- if is_sum i then
- SumL i
- else
- Free i
-
- let to_right_index is_sum i =
- if is_sum i then
- SumR i
- else
- Free i
-
- let to_left_factor is_sum = map (to_left_index is_sum)
- let to_right_factor is_sum = map (to_right_index is_sum)
- let of_factor = map free_index
-
- let to_left_factor_eps is_sum = map_eps (to_left_index is_sum)
- let to_right_factor_eps is_sum = map_eps (to_right_index is_sum)
- let of_factor_eps = map_eps free_index
-
- let to_left_factor_eps_bar is_sum = map_eps_bar (to_left_index is_sum)
- let to_right_factor_eps_bar is_sum = map_eps_bar (to_right_index is_sum)
- let of_factor_eps_bar = map_eps_bar free_index
-
- let negatives = function
- | Arrow (tail, tip) ->
- if position tail < 0 then
- if position tip < 0 then
- [tail; tip]
- else
- [tail]
- else if position tip < 0 then
- [tip]
- else
- []
- | Ghost ghost ->
- if position ghost < 0 then
- [ghost]
- else
- []
- let negatives_eps = List.filter (fun tip -> position tip < 0)
- let negatives_eps_bar = List.filter (fun tip -> position tip < 0)
-
- let is_free = function
- | Arrow (Free _, Free _) | Ghost (Free _) -> true
- | Arrow (_, _) | Ghost _ -> false
- let is_free_eps = List.for_all is_free_index
- let is_free_eps_bar = List.for_all is_free_index
-
- let is_ghost = function
- | Ghost _ -> true
- | Arrow _ -> false
-
- let single tail tip =
- Arrow (tail, tip)
-
- let double a b =
- if a = b then
- [single a b]
- else
- [single a b; single b a]
-
- let ghost g =
- Ghost g
-
- module Infix =
- struct
- let ( => ) i j = single (I i) (I j)
- let ( ==> ) i j = [i => j]
- let ( <=> ) i j = double (I i) (I j)
- let ( >=> ) (i, n) j = single (M (i, n)) (I j)
- let ( =>> ) i (j, m) = single (I i) (M (j, m))
- let ( >=>> ) (i, n) (j, m) = single (M (i, n)) (M (j, m))
- let ( ?? ) i = ghost (I i)
- end
-
- open Infix
-
-(* Split [a_list] at the first element equal to [a] according
- to [eq]. Return the reversed first part and the rest as a
- pair and wrap it in [Some]. Return [None] if there is no match. *)
- let take_first_match_opt ?(eq=(=)) a a_list =
- let rec take_first_match_opt' rev_head = function
- | [] -> None
- | elt :: tail ->
- if eq elt a then
- Some (rev_head, tail)
- else
- take_first_match_opt' (elt :: rev_head) tail in
- take_first_match_opt' [] a_list
-
-(* Split [a_list] and [b_list] at the first element equal according
- to [eq]. Return the reversed first part and the rest of each
- as a pair of pairs wrap it in [Some].
- Return [None] if there is no match. *)
- let take_first_matching_pair_opt ?(eq=(=)) a_list b_list =
- let rec take_first_matching_pair_opt' rev_a_head = function
- | [] -> None
- | a :: a_tail ->
- begin match take_first_match_opt ~eq a b_list with
- | Some (rev_b_head, b_tail) ->
- Some ((rev_a_head, a_tail), (rev_b_head, b_tail))
- | None ->
- take_first_matching_pair_opt' (a :: rev_a_head) a_tail
- end in
- take_first_matching_pair_opt' [] a_list
-
-(* Replace the first occurence of an element equal to [a] according
- to [eq] in [a_list] by [a'] and wrap the new list in [Some].
- Return [None] if there is no match. *)
- let replace_first_opt ?(eq=(=)) a a' a_list =
- match take_first_match_opt ~eq a a_list with
- | Some (rev_head, tail) -> Some (List.rev_append rev_head (a' :: tail))
- | None -> None
-
- let tee a = function
- | Arrow (tail, tip) -> [Arrow (tail, I a); Arrow (I a, tip)]
- | Ghost _ as g -> [g]
-
- let dir i j = function
- | Arrow (tail, tip) ->
- let tail = position tail
- and tip = position tip in
- if tip = i && tail = j then
- 1
- else if tip = j && tail = i then
- -1
- else
- invalid_arg "Arrow.dir"
- | Ghost _ -> 0
-
- type merge =
- | Match of factor
- | Ghost_Match
- | Loop_Match
- | Mismatch
- | No_Match
-
-(* As an optimization, don't attempt to merge if neither of the arrows
- contains a summation index and return immediately. *)
-
- let merge_arrow_arrow arrow1 arrow2 =
- if is_free arrow1 || is_free arrow2 then
- No_Match
- else
- match arrow1, arrow2 with
- | Ghost g1, Ghost g2 ->
- if index_matches g1 g2 then
- Ghost_Match
- else
- No_Match
- | Arrow (tail, tip), Ghost g
- | Ghost g, Arrow (tail, tip) ->
- if index_matches g tail || index_matches g tip then
- Mismatch
- else
- No_Match
- | Arrow (tail, tip), Arrow (tail', tip') ->
- if index_matches tip tail' then
- if index_matches tip' tail then
- Loop_Match
- else
- Match (Arrow (tail, tip'))
- else if index_matches tip' tail then
- Match (Arrow (tail', tip))
- else
- No_Match
-
- type 'a merge_eps =
- | Match_Eps of 'a
- | Mismatch_Eps
- | No_Match_Eps
-
- let merge_arrow_eps arrow tips =
- if is_free_eps tips || is_free arrow then
- No_Match_Eps
- else
- match arrow with
- | Arrow (tail, tip) ->
- begin match replace_first_opt ~eq:index_matches tail tip tips with
- | None -> No_Match_Eps
- | Some tips -> Match_Eps tips
- end
- | Ghost g ->
- if List.exists (index_matches g) tips then
- Mismatch_Eps
- else
- No_Match_Eps
-
- let merge_arrow_eps_bar arrow tails =
- if is_free_eps_bar tails || is_free arrow then
- No_Match_Eps
- else
- match arrow with
- | Arrow (tail, tip) ->
- begin match replace_first_opt ~eq:index_matches tip tail tails with
- | None -> No_Match_Eps
- | Some tails -> Match_Eps tails
- end
- | Ghost g ->
- if List.exists (index_matches g) tails then
- Mismatch_Eps
- else
- No_Match_Eps
-
-(* Starting with the case of matching dimension~$N$ and rank
- of~$\epsilon$ and $\bar\epsilon$, there is the well known formula
+ \begin{subequations}
+ \label{eq:qqqqH}
+ \begin{multline}
+ \label{eq:qqqqH-full}
+ \parbox{38\unitlength}{%
+ \fmfframe(4,2)(4,4){%
+ \begin{fmfgraph*}(30,20)
+ \setupFiveAmp
+ \fmflabel{$H$}{H}
+ \fmflabel{$q$}{i2}
+ \fmflabel{$q$}{i1}
+ \fmflabel{$\bar q$}{o1}
+ \fmflabel{$\bar q$}{o2}
+ \fmf{fermion}{i1,v1,i2}
+ \fmf{fermion}{o2,v2,o1}
+ \fmf{gluon}{v1,vH,v2}
+ \fmf{plain}{vH,H}
+ \end{fmfgraph*}}} =
+ \parbox{38\unitlength}{%
+ \fmfframe(4,2)(4,4){%
+ \begin{fmfgraph*}(30,20)
+ \setupFiveAmp
+ \fmfi{phantom_arrow}{vpath (__i1, __v1)}
+ \fmfi{phantom_arrow}{vpath (__v1, __vH) sideways -thick}
+ \fmfi{phantom_arrow}{vpath (__vH, __v2) sideways -thick}
+ \fmfi{phantom_arrow}{vpath (__v2, __o1)}
+ \fmfi{phantom_arrow}{vpath (__o2, __v2)}
+ \fmfi{phantom_arrow}{reverse vpath (__v1, __vH) sideways -thick}
+ \fmfi{phantom_arrow}{reverse vpath (__vH, __v2) sideways -thick}
+ \fmfi{phantom_arrow}{vpath (__v1, __i2)}
+ \fmfi{plain}{vpath (__i1, __v1) join
+ (vpath (__v1, __vH) sideways -thick) join
+ (vpath (__vH, __v2) sideways -thick) join
+ vpath (__v2, __o1)}
+ \fmfi{plain}{vpath (__o2, __v2) join
+ (reverse vpath (__vH, __v2) sideways -thick) join
+ (reverse vpath (__v1, __vH) sideways -thick) join
+ vpath (__v1, __i2)}
+ \fmf{plain}{H,vH}
+ \end{fmfgraph*}}} + \left(-\frac{1}{N_C}\right)
+ \parbox{38\unitlength}{%
+ \fmfframe(4,2)(4,4){%
+ \begin{fmfgraph*}(30,20)
+ \setupFiveAmp
+ \fmfi{phantom_arrow}{vpath (__i1, __v1)}
+ \fmfi{phantom_arrow}{vpath (__v2, __o1)}
+ \fmfi{phantom_arrow}{vpath (__v1, __vH) sideways -thick}
+ \fmfi{phantom_arrow}{reverse vpath (__v1, __vH) sideways -thick}
+ \fmfi{phantom_arrow}{vpath (__o2, __v2)}
+ \fmfi{phantom_arrow}{vpath (__v1, __i2)}
+ \fmfi{plain}{vpath (__i1, __v1) join
+ (vpath (__v1, __vH) sideways -thick) join
+ (reverse vpath (__v1, __vH) sideways -thick) join
+ vpath (__v1, __i2)}
+ \fmfi{plain}{vpath (__o2, __v2) join
+ vpath (__v2, __o1)}
+ \fmf{dots}{vH,v2}
+ \fmf{plain}{vH,H}
+ \end{fmfgraph*}}} \\ + \left(-\frac{1}{N_C}\right)
+ \parbox{38\unitlength}{%
+ \fmfframe(4,2)(4,4){%
+ \begin{fmfgraph*}(30,20)
+ \setupFiveAmp
+ \fmfi{phantom_arrow}{vpath (__i1, __v1)}
+ \fmfi{phantom_arrow}{vpath (__v1, __i2)}
+ \fmfi{phantom_arrow}{vpath (__v2, __o1)}
+ \fmfi{phantom_arrow}{vpath (__vH, __v2) sideways -thick}
+ \fmfi{phantom_arrow}{reverse vpath (__vH, __v2) sideways -thick}
+ \fmfi{phantom_arrow}{vpath (__o2, __v2)}
+ \fmfi{plain}{vpath (__i1, __v1) join
+ vpath (__v1, __i2)}
+ \fmfi{plain}{vpath (__o2, __v2) join
+ (reverse vpath (__vH, __v2) sideways -thick) join
+ (vpath (__vH, __v2) sideways -thick) join
+ vpath (__v2, __o1)}
+ \fmf{dots}{v1,vH}
+ \fmf{plain}{vH,H}
+ \end{fmfgraph*}}} + N_C \left(-\frac{1}{N_C}\right)^2
+ \parbox{38\unitlength}{%
+ \fmfframe(4,2)(4,4){%
+ \begin{fmfgraph*}(30,20)
+ \setupFiveAmp
+ \fmfi{phantom_arrow}{vpath (__i1, __v1)}
+ \fmfi{phantom_arrow}{vpath (__v2, __o1)}
+ \fmfi{phantom_arrow}{vpath (__o2, __v2)}
+ \fmfi{phantom_arrow}{vpath (__v1, __i2)}
+ \fmfi{plain}{vpath (__i1, __v1) join
+ vpath (__v1, __i2)}
+ \fmfi{plain}{vpath (__o2, __v2) join
+ vpath (__v2, __o1)}
+ \fmf{dots}{v1,vH,v2}
+ \fmf{plain}{vH,H}
+ \end{fmfgraph*}}}
+ \end{multline}
+ the sum of which corresponds to the same simple color flows as gluon exchange
\begin{equation}
- \forall k, n = N \in \mathbf{N}, 0\le k \le n \ge 2:\;
- \epsilon_{i_1\cdots i_n}
- \bar\epsilon^{i_1\cdots i_kj_{k+1}\cdots j_n}
- = k! \sum_{\sigma\in S_{n-k}} (-1)^{\varepsilon(\sigma)}
- \delta_{i_{k+1}}^{\sigma(j_{k+1})}
- \delta_{i_{k+2}}^{\sigma(j_{k+2})}
- \cdots
- \delta_{i_n}^{\sigma(j_n)}\,.
+ \parbox{28\unitlength}{%
+ \fmfframe(4,2)(4,4){%
+ \begin{fmfgraph*}(20,20)
+ \setupFiveAmp
+ \fmfi{phantom_arrow}{vpath (__i1, __v1)}
+ \fmfi{phantom_arrow}{vpath (__v1, __vH) sideways -thick}
+ \fmfi{phantom_arrow}{vpath (__vH, __v2) sideways -thick}
+ \fmfi{phantom_arrow}{vpath (__v2, __o1)}
+ \fmfi{phantom_arrow}{vpath (__o2, __v2)}
+ \fmfi{phantom_arrow}{reverse vpath (__v1, __vH) sideways -thick}
+ \fmfi{phantom_arrow}{reverse vpath (__vH, __v2) sideways -thick}
+ \fmfi{phantom_arrow}{vpath (__v1, __i2)}
+ \fmfi{plain}{vpath (__i1, __v1) join
+ (vpath (__v1, __vH) sideways -thick) join
+ (vpath (__vH, __v2) sideways -thick) join
+ vpath (__v2, __o1)}
+ \fmfi{plain}{vpath (__o2, __v2) join
+ (reverse vpath (__vH, __v2) sideways -thick) join
+ (reverse vpath (__v1, __vH) sideways -thick) join
+ vpath (__v1, __i2)}
+ \end{fmfgraph*}}} - \frac{1}{N_C}
+ \parbox{28\unitlength}{%
+ \fmfframe(4,2)(4,4){%
+ \begin{fmfgraph*}(20,20)
+ \setupFiveAmp
+ \fmfi{phantom_arrow}{vpath (__i1, __v1)}
+ \fmfi{phantom_arrow}{vpath (__v2, __o1)}
+ \fmfi{phantom_arrow}{vpath (__o2, __v2)}
+ \fmfi{phantom_arrow}{vpath (__v1, __i2)}
+ \fmfi{plain}{vpath (__i1, __v1) join
+ vpath (__v1, __i2)}
+ \fmfi{plain}{vpath (__o2, __v2) join
+ vpath (__v2, __o1)}
+ \end{fmfgraph*}}}\,.
\end{equation}
- In the general case, we have from anti-symmetry alone
+ Squaring and summing these produces the correct result
\begin{equation}
- \forall n, N \in\mathbf{N}, 2\le n \le N:\;
- \epsilon_{i_1i_2\cdots i_n} \bar\epsilon^{j_1j_2\cdots j_n}
- = \sum_{\sigma\in S_n} (-1)^{\varepsilon(\sigma)}
- \delta_{i_1}^{\sigma(j_1)}
- \delta_{i_2}^{\sigma(j_2)}
- \cdots
- \delta_{i_n}^{\sigma(j_n)}\,,
+ N_C^2 + N_C \left(-\frac{1}{N_C}\right) + N_C \left(-\frac{1}{N_C}\right)
+ + N_C^2 \left(-\frac{1}{N_C}\right)^2 = N_C^2 - 1\,.
\end{equation}
- where~$N=\delta_i^i$ is the dimension. *)
-
- let merge_eps_eps_bar tips tails =
- if List.length tails <> List.length tips then
- None
- else
- Some (List.fold_left
- (fun (even, odd) (eps, tips) ->
- if eps > 0 then
- (List.rev_map2 single tails tips :: even, odd)
- else
- (even, List.rev_map2 single tails tips :: odd))
- ([], []) (Combinatorics.permute_signed tips))
-
-(* From this, we derive
+ \end{subequations}
+ This result can be reproduced without coupling of trace gluons to ghosts
+ by simply replacing the ghost-ghost
+ coupling~$N_C$ by $-N_C$ in order to cancel the minus sign from the
+ additional ghost propagator\footnote{%
+ For comparison, naively leaving out the coupling of ghosts to traces results in
+ different color flows
+ \begin{equation*}
+ \parbox{28\unitlength}{%
+ \fmfframe(4,2)(4,4){%
+ \begin{fmfgraph*}(20,20)
+ \setupFiveAmp
+ \fmfi{phantom_arrow}{vpath (__i1, __v1)}
+ \fmfi{phantom_arrow}{vpath (__v1, __vH) sideways -thick}
+ \fmfi{phantom_arrow}{vpath (__vH, __v2) sideways -thick}
+ \fmfi{phantom_arrow}{vpath (__v2, __o1)}
+ \fmfi{phantom_arrow}{vpath (__o2, __v2)}
+ \fmfi{phantom_arrow}{reverse vpath (__v1, __vH) sideways -thick}
+ \fmfi{phantom_arrow}{reverse vpath (__vH, __v2) sideways -thick}
+ \fmfi{phantom_arrow}{vpath (__v1, __i2)}
+ \fmfi{plain}{vpath (__i1, __v1) join
+ (vpath (__v1, __vH) sideways -thick) join
+ (vpath (__vH, __v2) sideways -thick) join
+ vpath (__v2, __o1)}
+ \fmfi{plain}{vpath (__o2, __v2) join
+ (reverse vpath (__vH, __v2) sideways -thick) join
+ (reverse vpath (__v1, __vH) sideways -thick) join
+ vpath (__v1, __i2)}
+ \end{fmfgraph*}}} + \frac{1}{N_C}
+ \parbox{28\unitlength}{%
+ \fmfframe(4,2)(4,4){%
+ \begin{fmfgraph*}(20,20)
+ \setupFiveAmp
+ \fmfi{phantom_arrow}{vpath (__i1, __v1)}
+ \fmfi{phantom_arrow}{vpath (__v2, __o1)}
+ \fmfi{phantom_arrow}{vpath (__o2, __v2)}
+ \fmfi{phantom_arrow}{vpath (__v1, __i2)}
+ \fmfi{plain}{vpath (__i1, __v1) join
+ vpath (__v1, __i2)}
+ \fmfi{plain}{vpath (__o2, __v2) join
+ vpath (__v2, __o1)}
+ \end{fmfgraph*}}}
+ \end{equation*}
+ Squaring and summing these would produce the incorrect result
+ \begin{equation*}
+ N_C^2 + N_C \frac{1}{N_C} + N_C \frac{1}{N_C}
+ + N_C^2 \left(\frac{1}{N_C}\right)^2 = N_C^2 + 3\,.
+ \end{equation*}}.
+
+ \item
+ In the second case of one gluon connected to matter and the other to
+ an external state, no special treatment is required. The prototypical
+ example is $q\bar q\to Hg$
\begin{multline}
- \label{eq:epsilon*epsilonbar-single-contraction}
- \forall n, N \in\mathbf{N}, 2\le n \le N:\;
- \epsilon_{ki_2\cdots i_n} \bar\epsilon^{kj_2\cdots j_n}
- = \sum_{\sigma\in S_n} (-1)^{\varepsilon(\sigma)}
- \delta_{k}^{\sigma(k)}
- \delta_{i_2}^{\sigma(j_2)}
- \cdots
- \delta_{i_n}^{\sigma(j_n)} \\
- = (N-n+1)
- \sum_{\sigma\in S_{n-1}} (-1)^{\varepsilon(\sigma)}
- \delta_{i_2}^{\sigma(j_2)}
- \cdots
- \delta_{i_n}^{\sigma(j_n)}\,,
+ \label{eq:qqHg-full}
+ \parbox{38\unitlength}{%
+ \fmfframe(4,2)(4,4){%
+ \begin{fmfgraph*}(30,20)
+ \setupFiveAmp
+ \fmflabel{$H$}{H}
+ \fmflabel{$q$}{i2}
+ \fmflabel{$q$}{i1}
+ \fmf{fermion}{i1,v1,i2}
+ \fmf{phantom}{o2,v2,o1}
+ \fmf{gluon}{v1,vH,v2}
+ \fmf{plain}{vH,H}
+ \end{fmfgraph*}}} =
+ \parbox{38\unitlength}{%
+ \fmfframe(4,2)(4,4){%
+ \begin{fmfgraph*}(30,20)
+ \setupFiveAmp
+ \fmfi{phantom_arrow}{vpath (__i1, __v1)}
+ \fmfi{phantom_arrow}{vpath (__v1, __vH) sideways -thick}
+ \fmfi{phantom_arrow}{vpath (__vH, __v2) sideways -thick}
+ \fmfi{phantom_arrow}{reverse vpath (__v1, __vH) sideways -thick}
+ \fmfi{phantom_arrow}{reverse vpath (__vH, __v2) sideways -thick}
+ \fmfi{phantom_arrow}{vpath (__v1, __i2)}
+ \fmfi{plain}{vpath (__i1, __v1) join
+ (vpath (__v1, __vH) sideways -thick) join
+ (vpath (__vH, __v2) sideways -thick)}
+ \fmfi{plain}{(reverse vpath (__vH, __v2) sideways -thick) join
+ (reverse vpath (__v1, __vH) sideways -thick) join
+ vpath (__v1, __i2)}
+ \fmf{plain}{H,vH}
+ \end{fmfgraph*}}} +
+ \parbox{38\unitlength}{%
+ \fmfframe(4,2)(4,4){%
+ \begin{fmfgraph*}(30,20)
+ \setupFiveAmp
+ \fmfi{phantom_arrow}{vpath (__i1, __v1)}
+ \fmfi{phantom_arrow}{vpath (__v1, __vH) sideways -thick}
+ \fmfi{phantom_arrow}{reverse vpath (__v1, __vH) sideways -thick}
+ \fmfi{phantom_arrow}{vpath (__v1, __i2)}
+ \fmfi{plain}{vpath (__i1, __v1) join
+ (vpath (__v1, __vH) sideways -thick) join
+ (reverse vpath (__v1, __vH) sideways -thick) join
+ vpath (__v1, __i2)}
+ \fmf{dots}{vH,v2}
+ \fmf{plain}{vH,H}
+ \end{fmfgraph*}}} \\ + \left(-\frac{1}{N_C}\right)
+ \parbox{38\unitlength}{%
+ \fmfframe(4,2)(4,4){%
+ \begin{fmfgraph*}(30,20)
+ \setupFiveAmp
+ \fmfi{phantom_arrow}{vpath (__i1, __v1)}
+ \fmfi{phantom_arrow}{vpath (__v1, __i2)}
+ \fmfi{phantom_arrow}{vpath (__vH, __v2) sideways -thick}
+ \fmfi{phantom_arrow}{reverse vpath (__vH, __v2) sideways -thick}
+ \fmfi{plain}{vpath (__i1, __v1) join
+ vpath (__v1, __i2)}
+ \fmfi{plain}{(reverse vpath (__vH, __v2) sideways -thick) join
+ (vpath (__vH, __v2) sideways -thick)}
+ \fmf{dots}{v1,vH}
+ \fmf{plain}{vH,H}
+ \end{fmfgraph*}}} + N_C \left(-\frac{1}{N_C}\right)
+ \parbox{38\unitlength}{%
+ \fmfframe(4,2)(4,4){%
+ \begin{fmfgraph*}(30,20)
+ \setupFiveAmp
+ \fmfi{phantom_arrow}{vpath (__i1, __v1)}
+ \fmfi{phantom_arrow}{vpath (__v1, __i2)}
+ \fmfi{plain}{vpath (__i1, __v1) join
+ vpath (__v1, __i2)}
+ \fmf{dots}{v1,vH,v2}
+ \fmf{plain}{vH,H}
+ \end{fmfgraph*}}}
\end{multline}
- where the~$N=\delta_k^k$ comes from the permutations with~$\sigma(k)=k$
- that correspond to a loop in the color flow and the~$n-1$ from the
- permutations with~$\sigma(k)\in\{i_2,\ldots,i_n\}$ that do not
- lead to a loop. Note that~$N-n+1=1$ in the special case~$N=n$ when
- rank and dimension match.
-
- By induction
+ The correct result for the summed square is
+ again $N_C^2-1$, where the two color flow diagrams with an external ghost
+ cancel. In the simplified rules, the $\mathrm{U}(N_C)$ gluons contribute
+ $N_C^2$ and the ghost $-1$.
+
+ \item
+ In the third and final case of both gluons connected to external states, we have
+ to apply a fudge factor replacing $N_C^2$ by $N_C^2-2$ for each cycle
+ of color disconnected gluons.
+ The calculation is straightforward, since there is no interference of
+ external ghosts and $\mathrm{U}(N_C)$ gluons in the sum of squares.
\begin{multline}
- \forall k, n, N \in \mathbf{N}, 2\le n \le N \land 1\le k \le n:\;
- \epsilon_{i_1\cdots i_n}
- \bar\epsilon^{i_1\cdots i_kj_{k+1}\cdots j_n}\\
- = \frac{(N-n+k)!}{(N-n)!}
- \sum_{\sigma\in S_{n-k}} (-1)^{\varepsilon(\sigma)}
- \delta_{i_{k+1}}^{\sigma(j_{k+1})}
- \delta_{i_{k+2}}^{\sigma(j_{k+2})}
- \cdots
- \delta_{i_n}^{\sigma(j_n)}\,,
+ \label{eq:gHg-full}
+ \parbox{38\unitlength}{%
+ \fmfframe(4,2)(4,4){%
+ \begin{fmfgraph*}(30,20)
+ \setupFiveAmp
+ \fmflabel{$H$}{H}
+ \fmf{phantom}{i1,v1,i2}
+ \fmf{phantom}{o2,v2,o1}
+ \fmf{gluon}{v1,vH,v2}
+ \fmf{plain}{vH,H}
+ \end{fmfgraph*}}} =
+ \parbox{38\unitlength}{%
+ \fmfframe(4,2)(4,4){%
+ \begin{fmfgraph*}(30,20)
+ \setupFiveAmp
+ \fmfi{phantom_arrow}{vpath (__v1, __vH) sideways -thick}
+ \fmfi{phantom_arrow}{vpath (__vH, __v2) sideways -thick}
+ \fmfi{phantom_arrow}{reverse vpath (__v1, __vH) sideways -thick}
+ \fmfi{phantom_arrow}{reverse vpath (__vH, __v2) sideways -thick}
+ \fmfi{plain}{(vpath (__v1, __vH) sideways -thick) join
+ (vpath (__vH, __v2) sideways -thick)}
+ \fmfi{plain}{(reverse vpath (__vH, __v2) sideways -thick) join
+ (reverse vpath (__v1, __vH) sideways -thick)}
+ \fmf{plain}{H,vH}
+ \end{fmfgraph*}}} +
+ \parbox{38\unitlength}{%
+ \fmfframe(4,2)(4,4){%
+ \begin{fmfgraph*}(30,20)
+ \setupFiveAmp
+ \fmfi{phantom_arrow}{vpath (__v1, __vH) sideways -thick}
+ \fmfi{phantom_arrow}{reverse vpath (__v1, __vH) sideways -thick}
+ \fmfi{plain}{(vpath (__v1, __vH) sideways -thick) join
+ (reverse vpath (__v1, __vH) sideways -thick)}
+ \fmf{dots}{vH,v2}
+ \fmf{plain}{vH,H}
+ \end{fmfgraph*}}} \\ +
+ \parbox{38\unitlength}{%
+ \fmfframe(4,2)(4,4){%
+ \begin{fmfgraph*}(30,20)
+ \setupFiveAmp
+ \fmfi{phantom_arrow}{vpath (__vH, __v2) sideways -thick}
+ \fmfi{phantom_arrow}{reverse vpath (__vH, __v2) sideways -thick}
+ \fmfi{plain}{(reverse vpath (__vH, __v2) sideways -thick) join
+ (vpath (__vH, __v2) sideways -thick)}
+ \fmf{dots}{v1,vH}
+ \fmf{plain}{vH,H}
+ \end{fmfgraph*}}} + N_C
+ \parbox{38\unitlength}{%
+ \fmfframe(4,2)(4,4){%
+ \begin{fmfgraph*}(30,20)
+ \setupFiveAmp
+ \fmf{dots}{v1,vH,v2}
+ \fmf{plain}{vH,H}
+ \end{fmfgraph*}}}
\end{multline}
- where
+ The latter contributes a factor of~$N_C^2$ (two loops) and the former
+ a factor of~$(-N_C)^2(-1/N_C)^2=1$ (one $-N_C$ fom each vertex and one $-1/N_C$
+ from each line across the cut). Therefore the sum would be $N_C^2+1$ in contrast
+ to the correct result~$N_C^2-1$. The correct result is then obtained by
+ multiplying the gluon term~$N_C^2$ by $1-2/N_C^2$
\begin{equation}
- \frac{(N-n+k)!}{(N-n)!} = (N-n+1)(N-n+2)\cdots(N-n+k)
+ N_C^2 + 1 \to N_C^2 \left(1-\frac{2}{N_C^2}\right) + 1
+ = N_C^2 - 2 + 1 = N_C^2 -1\,.
\end{equation}
- and in the special case~$N=n$
+ \end{enumerate} *)
+
+(* The factor $(1-2/N_C^2)^n$ in the formula
\begin{equation}
- \frac{(N-n+k)!}{(N-n)!} = k!\,.
+ N_C^{l} \left(-\frac{1}{N_C}\right)^{k}
+ \left(\frac{N_C^2-2}{N_C^2}\right)^{n}\,,
\end{equation}
- In the case~$k=1$ we
- get~\eqref{eq:epsilon*epsilonbar-single-contraction},
- of course. *)
-
- let is_tadpole = function
- | Arrow (tail, tip) -> index_matches tail tip
- | Ghost _ -> false
-
- let epsilon = function
- | [] -> invalid_arg "Color.Arrow.epsilon []"
- | [_] -> invalid_arg "Color.Arrow.epsilon lone index"
- | tips -> List.map (fun tip -> I tip) tips
-
- let epsilon_bar = function
- | [] -> invalid_arg "Color.Arrow.epsilon []"
- | [_] -> invalid_arg "Color.Arrow.epsilon lone index"
- | tails -> List.map (fun tail -> I tail) tails
-
- (* Composite Arrows. *)
-
- let rec chain = function
- | [] -> []
- | [a] -> [a => a]
- | [a; b] -> [a => b]
- | a :: (b :: _ as rest) -> (a => b) :: chain rest
-
- let rec cycle' a = function
- | [] -> [a => a]
- | [b] -> [b => a]
- | b :: (c :: _ as rest) -> (b => c) :: cycle' a rest
-
- let cycle = function
- | [] -> []
- | a :: _ as a_list -> cycle' a a_list
-
- module Test : Test =
- struct
-
- open OUnit
-
- let suite_chain =
- "chain" >:::
- [ "[]" >:: (fun () -> assert_equal [] (chain []));
- "[1]" >:: (fun () -> assert_equal [1 => 1] (chain [1]));
- "[1;2]" >:: (fun () -> assert_equal [1 => 2] (chain [1; 2]));
- "[1;2;3]" >:: (fun () -> assert_equal [1 => 2; 2 => 3] (chain [1; 2; 3]));
- "[1;2;3;4]" >:: (fun () -> assert_equal [1 => 2; 2 => 3; 3 => 4] (chain [1; 2; 3; 4])) ]
-
- let suite_cycle =
- "cycle" >:::
- [ "[]" >:: (fun () -> assert_equal [] (cycle []));
- "[1]" >:: (fun () -> assert_equal [1 => 1] (cycle [1]));
- "[1;2]" >:: (fun () -> assert_equal [1 => 2; 2 => 1] (cycle [1; 2]));
- "[1;2;3]" >:: (fun () -> assert_equal [1 => 2; 2 => 3; 3 => 1] (cycle [1; 2; 3]));
-
- "[1;2;3;4]" >:: (fun () -> assert_equal [1 => 2; 2 => 3; 3 => 4; 4 => 1] (cycle [1; 2; 3; 4])) ]
-
- let suite_take =
- "take" >:::
- [ "1 []" >:: (fun () -> assert_equal None (take_first_match_opt 1 []));
- "1 [1]" >:: (fun () -> assert_equal (Some ([], [])) (take_first_match_opt 1 [1]));
- "1 [2;3;4]" >:: (fun () -> assert_equal None (take_first_match_opt 1 [2;3;4]));
- "1 [1;2;3]" >:: (fun () -> assert_equal (Some ([], [2;3])) (take_first_match_opt 1 [1;2;3]));
- "2 [1;2;3]" >:: (fun () -> assert_equal (Some ([1], [3])) (take_first_match_opt 2 [1;2;3]));
- "3 [1;2;3]" >:: (fun () -> assert_equal (Some ([2;1], [])) (take_first_match_opt 3 [1;2;3])) ]
-
- let suite_take2 =
- "take2" >:::
- [ "[] []" >::
- (fun () -> assert_equal None (take_first_matching_pair_opt [] []));
-
- "[] [1;2;3]" >::
- (fun () -> assert_equal None (take_first_matching_pair_opt [] [1;2;3]));
-
- "[1] [2;3;4]" >::
- (fun () -> assert_equal None (take_first_matching_pair_opt [1] [2;3;4]));
-
- "[2;3;4] [1]" >::
- (fun () -> assert_equal None (take_first_matching_pair_opt [2;3;4] [1]));
-
- "[1;2;3] [4;5;6;7]" >::
- (fun () -> assert_equal None (take_first_matching_pair_opt [1;2;3] [4;5;6;7]));
-
- "[1] [1;2;3]" >::
- (fun () ->
- assert_equal
- (Some (([],[]), ([],[2;3])))
- (take_first_matching_pair_opt [1] [1;2;3]));
-
- "[1;2;3] [1;20;30]" >::
- (fun () ->
- assert_equal
- (Some (([],[2;3]), ([],[20;30])))
- (take_first_matching_pair_opt [1;2;3] [1;20;30]));
-
- "[1;2;3;4;5;6] [10;20;4;30;40]" >::
- (fun () ->
- assert_equal
- (Some (([3;2;1],[5;6]), ([20;10],[30;40])))
- (take_first_matching_pair_opt [1;2;3;4;5;6] [10;20;4;30;40])) ]
-
- let suite_replace =
- "replace" >:::
- [ "1 10 []" >:: (fun () -> assert_equal None (replace_first_opt 1 2 []));
- "1 10 [1]" >:: (fun () -> assert_equal (Some [10]) (replace_first_opt 1 10 [1]));
- "1 [2;3;4]" >:: (fun () -> assert_equal None (replace_first_opt 1 10 [2;3;4]));
- "1 [1;2;3]" >:: (fun () -> assert_equal (Some [10;2;3]) (replace_first_opt 1 10 [1;2;3]));
- "2 [1;2;3]" >:: (fun () -> assert_equal (Some [1;10;3]) (replace_first_opt 2 10 [1;2;3]));
- "3 [1;2;3]" >:: (fun () -> assert_equal (Some [1;2;10]) (replace_first_opt 3 10 [1;2;3])) ]
-
- let suite =
- "Color.Arrow" >:::
- [suite_chain;
- suite_cycle;
- suite_take;
- suite_take2;
- suite_replace]
-
- let suite_long =
- "Color.Arrow long" >:::
- []
-
- end
-
- let pp_free fmt f =
- Format.fprintf fmt "%s" (free_to_string f)
-
- let pp_factor fmt f =
- Format.fprintf fmt "%s" (factor_to_string f)
-
- end
-
-(* \thocwmodulesubsection{Whizard Interface} *)
-
-module type Propagator =
- sig
- type cf_in = int
- type cf_out = int
- type t = W | I of cf_in | O of cf_out | IO of cf_in * cf_out | G
- val to_string : t -> string
- end
-
-module Propagator : Propagator =
- struct
- type cf_in = int
- type cf_out = int
- type t = W | I of cf_in | O of cf_out | IO of cf_in * cf_out | G
- let to_string = function
- | W -> "W"
- | I cf -> Printf.sprintf "I(%d)" cf
- | O cf' -> Printf.sprintf "O(%d)" cf'
- | IO (cf, cf') -> Printf.sprintf "IO(%d,%d)" cf cf'
- | G -> "G"
- end
-
-(* \thocwmodulesubsection{Rational Algebra} *)
-
-module Q = Algebra.Q
-module QC = Algebra.QC
-
-module type LP =
- sig
- val rationals : (Algebra.Q.t * int) list -> Algebra.Laurent.t
- val ints : (int * int) list -> Algebra.Laurent.t
-
- val rational : Algebra.Q.t -> Algebra.Laurent.t
- val int : int -> Algebra.Laurent.t
- val fraction : int -> Algebra.Laurent.t
- val imag : int -> Algebra.Laurent.t
- val nc : int -> Algebra.Laurent.t
- val over_nc : int -> Algebra.Laurent.t
- end
-
-module LP : LP =
- struct
- module L = Algebra.Laurent
-
- (* Rationals from integers. *)
- let q_int n = Q.make n 1
- let q_fraction n = Q.make 1 n
-
- (* Complex rationals: *)
- let qc_rational q = QC.make q Q.null
- let qc_int n = qc_rational (q_int n)
- let qc_fraction n = qc_rational (q_fraction n)
- let qc_imag n = QC.make Q.null (q_int n)
-
- (* Laurent polynomials: *)
- let of_pairs f pairs =
- L.sum (List.map (fun (coeff, power) -> L.atom (f coeff) power) pairs)
-
- let rationals = of_pairs qc_rational
- let ints = of_pairs qc_int
-
- let rational q = rationals [(q, 0)]
- let int n = ints [(n, 0)]
- let fraction n = L.const (qc_fraction n)
- let imag n = L.const (qc_imag n)
- let nc n = ints [(n, 1)]
- let over_nc n = ints [(n, -1)]
-
- end
-
-(* \thocwmodulesubsection{Lists with Typed Lengths} *)
-
-(* Inspired by an example posted on github by Izaak Meckler that in turn
- appears to be based on ideas well known in the Haskell community. *)
-
-(* \begin{dubious}
- This will become a seperate file, after we have convinced ourselves of
- its utility.
- \end{dubious} *)
-
-module type NList =
- sig
-
- (* These types are just Peano numerals ['n] used as indices
- for [('n, 'a) t]. [z] encodes 0 and ['a s] the successor. *)
- type z
- type 'a s
-
- (* A [('n, 'a) t] is a list of ['a] of length ['n] with ['n]
- encoded as a church numeral and must not be too large! *)
- type ('n, 'a) t
-
- (* Constructors. *)
- val empty : (z, 'a) t
- val cons : 'a -> ('n, 'a) t -> ('n s, 'a) t
-
- (* Deconstructors. Note that they cannot be applied to the empty list. *)
- val hd : ('n s, 'a) t -> 'a
- val tl : ('n s, 'a) t -> ('n, 'a) t
-
- (* Turn the a list with typed length into an ordinary list.
- Note also, that we can not implement the inverse function
- [of_list : 'a list -> ('n, 'a t)], because in that case the
- type ['n] depends on the list and is \emph{not} known at
- compile time. *)
- val to_list : ('n, 'a) t -> 'a list
-
- (* The usual suspects. *)
- val map : ('a -> 'b) -> ('n, 'a) t -> ('n, 'b) t
- val fold_right : ('a -> 'b -> 'b) -> ('n, 'a) t -> 'b -> 'b
-
- (* A version of [append] is complicated, since we need to compute
- the sum of the lengths in the type system. It can be done by
- introducing additional wrappers, but the result is difficult to
- deconstruct and we don't need it for our applications.
- The usual implementation of [rev] will also not work, because we
- need again to maintain the sum of the lengths as an invariant.
- Simple successor relationships are not enough. *)
-
- (* On the other hand, [map2], [fold_right2] etc.{} can be
- implemented easily. Here, the type shines, because it can
- avoid the [Invalid_argument] exception. *)
- val map2 : ('a -> 'b -> 'c) -> ('n, 'a) t -> ('n, 'b) t -> ('n, 'c) t
-
- (* The algorithm is not suitable for long lists, but we expect the
- lists to be very short anyway. *)
- val sort : ('a -> 'a -> int) -> ('n, 'a) t -> ('n, 'a) t
-
- end
-
-module NList : NList =
- struct
-
- (* The constructor [Zero] appears to be not needed,
- but the constructor [Successor] is required. *)
- type z = Zero
- type 'a s = Successor
-
- type (_, _) t =
- | Nil : (z, 'a) t
- | Cons : 'a * ('n, 'a) t -> ('n s, 'a) t
-
- let empty = Nil
-
- let cons : type n. 'a -> (n, 'a) t -> (n s, 'a) t =
- fun x xs ->
- Cons (x, xs)
-
- let hd : type n. (n s, 'a) t -> 'a = function
- | Cons (x, _) -> x
-
- let tl : type n. (n s, 'a) t -> (n, 'a) t = function
- | Cons (_, xs) -> xs
-
- let rec fold_right : type n. ('a -> 'b -> 'b) -> (n, 'a) t -> 'b -> 'b=
- fun f alist b ->
- match alist with
- | Nil -> b
- | Cons (a, rest) -> f a (fold_right f rest b)
-
- let rec map : type n. ('a -> 'b) -> (n, 'a) t -> (n, 'b) t =
- fun f ->
- function
- | Nil -> Nil
- | Cons (x, xs) -> Cons (f x, map f xs)
-
- let rec to_list : type n. (n, 'a) t -> 'a list = function
- | Nil -> []
- | Cons (a, a_list) -> a :: to_list a_list
-
- let rec map2 : type n. ('a -> 'b -> 'c) -> (n, 'a) t -> (n, 'b) t -> (n, 'c) t =
- fun f a_list b_list ->
- match a_list, b_list with
- | Nil, Nil -> Nil
- | Cons (x, xs), Cons (y, ys) -> Cons (f x y, map2 f xs ys)
-
-(* This corresponds to a bubble sort. Don't use this for long lists!
- However, we expect the lists to be very short anyway and type safe
- reversing or concatenating two lists as required by the better performing
- algorithms requires to much effort for our applications. *)
-
-(* Inner step: find an element that is out of order and push it past
- the adjacent lesser elements. Report whether a transposition was made. *)
-
- let rec cycle : type n. ('a -> 'a -> int) -> (n, 'a) t -> bool * (n, 'a) t =
- fun cmp -> function
- | Nil -> (false, Nil)
- | Cons (_, Nil) as a -> (false, a)
- | Cons (a1, (Cons (a2, alist2) as alist1)) ->
- if cmp a1 a2 <= 0 then
- let flipped, alist = cycle cmp alist1 in
- (flipped, Cons (a1, alist))
- else
- let flipped, alist = cycle cmp (Cons (a1, alist2)) in
- (true, Cons (a2, alist))
-
-(* Repeat the inner step until no more elements are out of order. *)
-
- let rec sort : type n. ('a -> 'a -> int) -> (n, 'a) t -> (n, 'a) t =
- fun cmp alist ->
- let flipped, cycled = cycle cmp alist in
- if flipped then
- sort cmp cycled
- else
- cycled
-
- end
-
-(* \thocwmodulesubsection{Expressions of Arrows and Epsilons} *)
-
-module type Birdtracks =
- sig
- type t
- val canonicalize : t -> t
- val to_string : t -> string
- val trivial : t -> bool
- val is_null : t -> bool
- val const : Algebra.Laurent.t -> t
- val null : t
- val one : t
- val two : t
- val half : t
- val third : t
- val minus : t
- val int : int -> t
- val fraction : int -> t
- val nc : t
- val over_nc : t
- val imag : t
- val ints : (int * int) list -> t
- val scale : QC.t -> t -> t
- val sum : t list -> t
- val diff : t -> t -> t
- val times : t -> t -> t
- val multiply : t list -> t
- module Infix : sig
- val ( +++ ) : t -> t -> t
- val ( --- ) : t -> t -> t
- val ( *** ) : t -> t -> t
- end
- val f_of_rep : (int -> int -> int -> t) -> int -> int -> int -> t
- val d_of_rep : (int -> int -> int -> t) -> int -> int -> int -> t
- val relocate : (int -> int) -> t -> t
- val fuse : int -> t -> Propagator.t list -> (QC.t * Propagator.t) list
- module Test : Test
- val pp : Format.formatter -> t -> unit
- end
-
-module Birdtracks =
- struct
-
- module A = Arrow
- open A.Infix
- module P = Propagator
- module L = Algebra.Laurent
-
- (* There can be one or more $\epsilon$ or $\bar\epsilon$, but
- not both at the same time. *)
-
- (* I wanted to use a GADT with Peano numerals to track the number
- of $\epsilon$ and $\bar\epsilon$ in the type system. However,
- I would have needed to implement a ``multiplication'' function
- of the type ['n1 term -> 'n2 term -> ('n1 + 'n2) term]
- that I have not been able to implement using Peano numerals for
- the type variables ['n1] and ['n2], due to the lack of an
- addition operator for Peano numerals in the type system.
-
- Therefore I will use normal lists, sacrificing some type safety. *)
-
- type 'a aterm = { coeff : L.t; arrows : 'a list }
- type ('a, 'e) eterm = 'a aterm * 'e list
- type ('a, 'b) bterm = 'a aterm * 'b list
-
- type ('a, 'e, 'b) term =
- | Arrows of 'a aterm
- | Epsilons of ('a, 'e) eterm
- | Epsilon_Bars of ('a, 'b) bterm
-
-(* \begin{dubious}
- Having already added type annotations for polymorphic
- recursion, I could use a simple GADT instead of an ADT at the toplevel, trying
- to maintain some unboxing potential:
-
- [ type ('a, 'e, 'b) term =
- | Arrows : 'a aterm -> ('a, 'e, 'b) term
- | Epsilons : ('a, 'e) eterm -> ('a, 'e, 'b) term
- | Epsilon_Bars : ('a, 'b) bterm -> ('a, 'e, 'b) term ]
-
- but it is not obvious that this produces a real performance benefit.
- \end{dubious} *)
-
- type afree = A.free aterm
- type efree = (A.free, A.free_eps) eterm
- type bfree = (A.free, A.free_eps_bar) bterm
- type free = (A.free, A.free_eps, A.free_eps_bar) term
-
- type afactor = A.factor aterm
- type efactor = (A.factor, A.factor_eps) eterm
- type bfactor = (A.factor, A.factor_eps_bar) bterm
- type factor = (A.factor, A.factor_eps, A.factor_eps_bar) term
-
- type t = free list
-
- let tips_and_tails_of_aterm { arrows } =
- List.fold_left
- (fun (tips, tails) arrow ->
- (List.rev_append (A.tips arrow) tips,
- List.rev_append (A.tails arrow) tails))
- ([], []) arrows
-
- let tips_and_tails_raw = function
- | Arrows aterm -> tips_and_tails_of_aterm aterm
- | Epsilons (aterm, epsilons) ->
- let tips, tails = tips_and_tails_of_aterm aterm in
- (List.rev_append epsilons tips, tails)
- | Epsilon_Bars (aterm, epsilon_bars) ->
- let tips, tails = tips_and_tails_of_aterm aterm in
- (tips, List.rev_append epsilon_bars tails)
-
- let tips_and_tails term =
- let tips, tails =tips_and_tails_raw term in
- (List.sort pcompare tips, List.sort pcompare tails)
-
- let trivial = function
- | [] -> true
- | [Arrows { coeff; arrows = [] }] -> coeff = L.unit
- | _ -> false
-
- (* Rationals from integers. *)
- let q_int n = Q.make n 1
- let q_fraction n = Q.make 1 n
-
- (* Complex rationals: *)
- let qc_rational q = QC.make q Q.null
- let qc_int n = qc_rational (q_int n)
- let qc_fraction n = qc_rational (q_fraction n)
- let qc_imag n = QC.make Q.null (q_int n)
-
- (* Laurent polynomials: *)
- let laurent_of_pairs f pairs =
- L.sum (List.map (fun (coeff, power) -> L.atom (f coeff) power) pairs)
-
- let l_rationals = laurent_of_pairs qc_rational
- let l_ints = laurent_of_pairs qc_int
-
- let l_rational q = l_rationals [(q, 0)]
- let l_int n = l_ints [(n, 0)]
- let l_fraction n = L.const (qc_fraction n)
- let l_imag n = L.const (qc_imag n)
- let l_nc n = l_ints [(n, 1)]
- let l_over_nc n = l_ints [(n, -1)]
-
- (* Expressions *)
- let const coeff = [ Arrows { coeff; arrows = [] } ]
- let ints pairs = const (LP.ints pairs)
- let null = const L.null
- let half = const (LP.fraction 2)
- let third = const (LP.fraction 3)
- let fraction n = const (LP.fraction n)
- let one = const (LP.int 1)
- let two = const (LP.int 2)
- let minus = const (LP.int (-1))
- let int n = const (LP.int n)
- let nc = const (LP.nc 1)
- let over_nc = const (LP.ints [(1, -1)])
- let imag = const (LP.imag 1)
-
- module AMap = Pmap.Tree
-
- let id a = a
- let psort alist = List.sort pcompare alist
-
- let find_term_opt term map =
- AMap.find_opt pcompare term map
-
- let map_aterm fc fa aterm =
- { coeff = fc aterm.coeff; arrows = fa aterm.arrows }
-
- let map_term fc fa fe fb = function
- | Arrows aterm -> Arrows (map_aterm fc fa aterm)
- | Epsilons (aterm, elist) -> Epsilons (map_aterm fc fa aterm, fe elist)
- | Epsilon_Bars (aterm, blist) -> Epsilon_Bars (map_aterm fc fa aterm, fb blist)
-
- let canonicalize_aterm term =
- map_aterm id psort term
-
- (* \begin{dubious}
- We're \emph{not yet} canonicalizing the $\epsilon$ and
- $\bar\epsilon$ themselves. This could be done, if
- necessary, using [Combinatorics.sort_signed] to keep track of
- the signs. While we're debugging, it could be beneficial to
- keep the indices where they are.
- \end{dubious} *)
-
- let canonicalize_term : type a e b. (a, e, b) term -> (a, e, b) term =
- fun term ->
- map_term id psort psort psort term
-
- let split_coeff : type a e b. (a, e, b) term -> L.t * (a, e, b) term = function
- | Arrows aterm -> (aterm.coeff, Arrows { aterm with coeff = LP.int 1 })
- | Epsilons (aterm, epsilons) ->
- (aterm.coeff, Epsilons ({ aterm with coeff = LP.int 1 }, epsilons))
- | Epsilon_Bars (aterm, epsilon_bars) ->
- (aterm.coeff, Epsilon_Bars ({ aterm with coeff = LP.int 1 }, epsilon_bars))
-
- let inject_coeff : type a e b. L.t -> (a, e, b) term -> (a, e, b) term =
- fun coeff -> map_term (fun _ -> coeff) id id id
-
-(* \begin{dubious}
- Note that the final result
- must be a homogeneous list with all elements containing the same
- number of $\epsilon$ and $\bar\epsilon$, because otherwise the number
- of incoming and outgoing color lince would not match.
-
- Nevertheless, we might have to work very hard to avoid too much code
- duplication.
- \end{dubious} *)
-
- let canonicalize : type a e b. (a, e, b) term list -> (a, e, b) term list =
- fun terms ->
- let map =
- List.fold_left
- (fun acc term ->
- let coeff, term = split_coeff (canonicalize_term term) in
- if L.is_null coeff then
- acc
- else
- match find_term_opt term acc with
- | None -> AMap.add pcompare term coeff acc
- | Some coeff' ->
- let coeff'' = L.add coeff coeff' in
- if L.is_null coeff'' then
- AMap.remove pcompare term acc
- else
- AMap.add pcompare term coeff'' acc)
- AMap.empty terms in
- if AMap.is_empty map then
- []
- else
- AMap.fold (fun term coeff acc -> inject_coeff coeff term :: acc) map []
-
- let aterm_to_string f term =
- match term.arrows with
- | [] -> Printf.sprintf "(%s)" (L.to_string "N" term.coeff)
- | arrows ->
- Printf.sprintf
- "(%s) * %s"
- (L.to_string "N" term.coeff) (ThoList.to_string f arrows)
-
- let to_string1_aux fa fe fb = function
- | Arrows aterm -> aterm_to_string fa aterm
- | Epsilons (aterm, epsilons) ->
- aterm_to_string fa aterm ^ " * " ^ ThoList.to_string fe epsilons
- | Epsilon_Bars (aterm, epsilon_bars) ->
- aterm_to_string fa aterm ^ " * " ^ ThoList.to_string fb epsilon_bars
-
- let to_string1 term =
- to_string1_aux A.free_to_string A.free_eps_to_string A.free_eps_bar_to_string term
-
- let to_string_raw terms =
- ThoList.to_string to_string1 terms
-
- let to_string terms =
- to_string_raw (canonicalize terms)
-
-(*i
- let trivial terms =
- let result = trivial terms in
- Printf.eprintf
- "trivial %s -> %b\n"
- (to_string terms)
- result;
- trivial terms
-i*)
-
- let pp fmt v =
- Format.fprintf fmt "%s" (to_string v)
-
- let is_null v =
- match canonicalize v with
- | [] -> true
- | _ -> false
-
- let is_white = function
- | P.W -> true
- | _ -> false
-
- let relocate1 f term =
- map_term id
- (List.map (A.map (A.relocate f)))
- (List.map (List.map (A.relocate f)))
- (List.map (List.map (A.relocate f)))
- term
-
- let relocate f = List.map (relocate1 f)
-
- let of_afactor aterm =
- map_aterm id (List.map A.of_factor) aterm
-
- let of_factor term =
- map_term id
- (List.map A.of_factor)
- (List.map A.of_factor_eps)
- (List.map A.of_factor_eps_bar)
- term
-
- let to_left_factor is_sum term =
- map_term id
- (List.map (A.to_left_factor is_sum))
- (List.map (A.to_left_factor_eps is_sum))
- (List.map (A.to_left_factor_eps_bar is_sum))
- term
-
- let to_right_factor is_sum term =
- map_term id
- (List.map (A.to_right_factor is_sum))
- (List.map (A.to_right_factor_eps is_sum))
- (List.map (A.to_right_factor_eps_bar is_sum))
- term
-
- (* The will be [Option.map] from [Stdlib] from 4.08 on. *)
- let option_map f = function
- | None -> None
- | Some x -> Some (f x)
-
- (* The will be [Fun.flip] from [Stdlib] from 4.08 on. *)
- let fun_flip f x y = f y x
-
- (* We start with the simply recursive evaluation functions,
- leaving the the more complicated mutually recursive
- functions for later. *)
-
- (* Add one [arrow] to a list of arrows, updating [coeff]
- if necessary. Accumulate already processed arrows in [seen].
- Returns [None] if there is a mismatch (a gluon meeting
- a ghost) and [Some afactor] containing a coefficient and a
- list of arrows otherwise. *)
-
- (* We assume that the trivial cases of no summation indices
- and the arrow looping back to itself have already been filtered
- out. *)
-
- let rec add_arrow_to_arrows_list' coeff seen arrow = function
- | [] -> (* visited all [arrows]: no opportunities for further matches *)
- Some ({ coeff; arrows = arrow :: seen })
- | arrow' :: arrows' ->
- begin match A.merge_arrow_arrow arrow arrow' with
- | A.Mismatch ->
- None
- | A.Ghost_Match -> (* replace matching ghosts by $-1/N_C$ *)
- Some ({ coeff = L.mul (LP.over_nc (-1)) coeff;
- arrows = List.rev_append seen arrows' })
- | A.Loop_Match -> (* replace a loop by $N_C$ *)
- Some ({ coeff = L.mul (LP.nc 1) coeff;
- arrows = List.rev_append seen arrows' })
- | A.Match arrow'' -> (* two arrows have been merged into one *)
- if A.is_free arrow'' then (* no opportunities for further matches *)
- Some ({ coeff; arrows = arrow'' :: List.rev_append seen arrows' })
- else (* the new [arrow''] ist not yet saturated, try again: *)
- add_arrow_to_arrows_list' coeff seen arrow'' arrows'
- | A.No_Match -> (* recurse to the remaining arrows *)
- add_arrow_to_arrows_list' coeff (arrow' :: seen) arrow arrows'
- end
-
- let add_arrow_to_arrows_list coeff arrow arrows =
- add_arrow_to_arrows_list' coeff [] arrow arrows
-
- (* Similarly, add one [arrow] to a list of $\epsilon$ and
- accumulate already processed arrows in [seen].
- Returns [[]] if there is no match. Note that there is
- never the need to update the coefficient and that only
- the tail of the [arrow] can match. *)
-
- let rec add_arrow_to_epsilon_list' seen arrow = function
- | [] -> []
- | epsilon :: epsilons ->
- begin match A.merge_arrow_eps arrow epsilon with
- | A.Mismatch_Eps -> []
- | A.Match_Eps epsilon' -> List.rev_append seen (epsilon' :: epsilons)
- | A.No_Match_Eps -> add_arrow_to_epsilon_list' (epsilon :: seen) arrow epsilons
- end
-
- let add_arrow_to_epsilon_list arrow epsilons =
- add_arrow_to_epsilon_list' [] arrow epsilons
-
- (* Same preocedure for adding one [arrow] to a list of $\bar\epsilon$. *)
-
- let rec add_arrow_to_epsilon_bar_list' seen arrow = function
- | [] -> []
- | epsilon_bar :: epsilon_bars ->
- begin match A.merge_arrow_eps_bar arrow epsilon_bar with
- | A.Mismatch_Eps -> []
- | A.Match_Eps epsilon_bar' -> List.rev_append seen (epsilon_bar' :: epsilon_bars)
- | A.No_Match_Eps -> add_arrow_to_epsilon_bar_list' (epsilon_bar :: seen) arrow epsilon_bars
- end
-
- let add_arrow_to_epsilon_bar_list arrow epsilon_bars =
- add_arrow_to_epsilon_bar_list' [] arrow epsilon_bars
-
- (* Avoid a recursion, if there is no summation index in [arrow].
- Likewise, if [arrow] loops back to itself, just replace it by
- a factor of~$N_C$. *)
-
- let add_arrow_to_aterm_trivial : A.factor -> afactor -> afactor option =
- fun arrow term ->
- if A.is_free arrow then
- Some ({ coeff = term.coeff; arrows = arrow :: term.arrows })
- else if A.is_tadpole arrow then
- Some ({ coeff = L.mul (LP.nc 1) term.coeff; arrows = term.arrows })
- else
- None
-
- (* Straightforwardly add an arrow or an arrow list to a term
- containing no $\epsilon$ or $\bar\epsilon$, using the functions
- implemented above. *)
-
- let add_arrow_to_aterm : A.factor -> afactor -> afactor option =
- fun arrow term ->
- match add_arrow_to_aterm_trivial arrow term with
- | None -> add_arrow_to_arrows_list term.coeff arrow term.arrows
- | term_opt -> term_opt
-
- let add_arrow_list_to_aterm : A.factor list -> afactor -> afactor option =
- fun arrows term ->
- ThoList.fold_left_opt (fun_flip add_arrow_to_aterm) term arrows
-
- (* Adding an arrow or an arrow list to a term containing
- $\epsilon$ or $\bar\epsilon$ is not more complicated, we only
- have to make two attempts. *)
-
- (* \begin{dubious}
- Caveat: if the arrow matches one of the $\epsilon$s and
- this $\epsilon$ has a tip appearing among the remaining
- tips of this $\epsilon$, the result should be set to zero
- explicitelty. But such expressions are illegal anyway!
- \end{dubious} *)
-
- let add_arrow_to_eterm : A.factor -> efactor -> efactor option =
- fun arrow (aterm, epsilons) ->
- match add_arrow_to_aterm_trivial arrow aterm with
- | Some aterm -> Some (aterm, epsilons)
- | None ->
- begin match add_arrow_to_epsilon_list arrow epsilons with
- | [] ->
- begin match add_arrow_to_arrows_list aterm.coeff arrow aterm.arrows with
- | None -> None
- | Some aterm -> Some (aterm, epsilons)
- end
- | epsilons -> Some (aterm, epsilons)
- end
-
- let add_arrow_list_to_eterm : A.factor list -> efactor -> efactor option =
- fun arrows term ->
- ThoList.fold_left_opt (fun_flip add_arrow_to_eterm) term arrows
-
- let add_arrow_to_bterm : A.factor -> bfactor -> bfactor option =
- fun arrow (aterm, epsilon_bars) ->
- match add_arrow_to_aterm_trivial arrow aterm with
- | Some aterm -> Some (aterm, epsilon_bars)
- | None ->
- begin match add_arrow_to_epsilon_bar_list arrow epsilon_bars with
- | [] ->
- begin match add_arrow_to_arrows_list aterm.coeff arrow aterm.arrows with
- | None -> None
- | Some aterm -> Some (aterm, epsilon_bars)
- end
- | epsilon_bars -> Some (aterm, epsilon_bars)
+ where $l$ is the number of closed color cycles ([cycles] below),
+ $k$ is the number of external ghosts ([ghosts]) and
+ $n$ is the number of gluon cycles ([gluon_cycles]).
+ is the fudge factor taking care of the couplings of $\mathrm{U}(1)$
+ ghosts to trace gluons. *)
+
+ (* [endpoints_of_colors colors] creates maps from the position of the
+ external colors in [colors] to the tips and tails connected by color
+ flow lines. Also produce a set of the positions of external ghosts. *)
+
+ module IMap = Map.Make(Int)
+ module ISet = Set.Make(Int)
+
+ type endpoints =
+ { tails : int IMap.t;
+ tips : int IMap.t;
+ ghosts : ISet.t }
+
+ type color_kind =
+ | CK_Flow of int * int
+ | CK_Ghost
+
+ let color_kind = function
+ | Flow (cfi, cfo) -> CK_Flow (List.length (PArray.to_pairs cfi), List.length (PArray.to_pairs cfo))
+ | Ghost -> CK_Ghost
+
+ let equal_color_kind1 c1 c2 =
+ color_kind c1 = color_kind c2
+
+ let equal_color_kind f1 f2 =
+ List.for_all2 equal_color_kind1 f1 f2
+
+ let empty_endpoints =
+ { tails = IMap.empty;
+ tips = IMap.empty;
+ ghosts = ISet.empty }
+
+ let add_endpoint endpoints n = function
+ | Ghost -> { endpoints with ghosts = ISet.add n endpoints.ghosts }
+ | Flow (cfi, cfo) ->
+ begin match PArray.to_pairs cfi, PArray.to_pairs cfo with
+ | [], [] -> endpoints
+ | [(1, c)], [] -> { endpoints with tips = IMap.add (abs c) n endpoints.tips }
+ | [], [(1, c)] -> { endpoints with tails = IMap.add (abs c) n endpoints.tails }
+ | [(1, c1)], [(1, c2)] ->
+ { endpoints with
+ tips = IMap.add (abs c1) n endpoints.tips;
+ tails = IMap.add (abs c2) n endpoints.tails }
+ | _, _ -> failwith "Color.Flow.add_endpoint: incomplete"
end
- let add_arrow_list_to_bterm : A.factor list -> bfactor -> bfactor option =
- fun arrows term ->
- ThoList.fold_left_opt (fun_flip add_arrow_to_bterm) term arrows
-
- (* Adding an $\epsilon$ to a term containing $\epsilon$s is trivial,
- if there are no summation indices. Otherwise, we add the arrows
- back in to find matches.
- \begin{dubious}
- Here's potential for optimization, since the arrows can only
- match the new $\epsilon$.
- \end{dubious} *)
-
- let add_epsilon_to_eterm : A.factor_eps -> efactor -> efactor option =
- fun epsilon (aterm, epsilons) ->
- if A.is_free_eps epsilon then
- Some (aterm, epsilon :: epsilons)
- else
- let coeff = { coeff = aterm.coeff; arrows = []} in
- add_arrow_list_to_eterm aterm.arrows (coeff, epsilon :: epsilons)
-
- let add_epsilon_list_to_eterm : A.factor_eps list -> efactor -> efactor option =
- fun epsilons eterm ->
- ThoList.fold_left_opt (fun_flip add_epsilon_to_eterm) eterm epsilons
-
- (* Once more for $\bar\epsilon$. *)
-
- let add_epsilon_bar_to_bterm : A.factor_eps_bar -> bfactor -> bfactor option =
- fun epsilon_bar (aterm, epsilon_bars) ->
- if A.is_free_eps_bar epsilon_bar then
- Some (aterm, epsilon_bar :: epsilon_bars)
- else
- let coeff = { coeff = aterm.coeff; arrows = []} in
- add_arrow_list_to_bterm aterm.arrows (coeff, epsilon_bar :: epsilon_bars)
-
- let add_epsilon_bar_list_to_bterm : A.factor_eps_bar list -> bfactor -> bfactor option =
- fun epsilon_bars bterm ->
- ThoList.fold_left_opt (fun_flip add_epsilon_bar_to_bterm) bterm epsilon_bars
-
- (* Here we simply have to select the correct function. *)
-
- let add_arrow_to_term : A.factor -> factor -> factor option =
- fun arrow -> function
- | Arrows aterm ->
- option_map (fun a -> Arrows a) (add_arrow_to_aterm arrow aterm)
- | Epsilons eterm ->
- option_map (fun e -> Epsilons e) (add_arrow_to_eterm arrow eterm)
- | Epsilon_Bars bterm ->
- option_map (fun b -> Epsilon_Bars b) (add_arrow_to_bterm arrow bterm)
-
- let add_arrow_list_to_term : A.factor list -> factor -> factor option =
- fun arrows term ->
- ThoList.fold_left_opt (fun_flip add_arrow_to_term) term arrows
-
- let scale_aterm : L.t -> afactor -> afactor =
- fun coeff aterm ->
- { coeff = L.mul coeff aterm.coeff; arrows = aterm.arrows}
-
- let scale_eterm : L.t -> efactor -> efactor =
- fun coeff (aterm, epsilons) ->
- (scale_aterm coeff aterm, epsilons)
-
- let scale_bterm : L.t -> bfactor -> bfactor =
- fun coeff (aterm, epsilon_bars) ->
- (scale_aterm coeff aterm, epsilon_bars)
-
- let scale_term : L.t -> factor -> factor =
- fun coeff -> function
- | Arrows aterm -> Arrows (scale_aterm coeff aterm)
- | Epsilons eterm -> Epsilons (scale_eterm coeff eterm)
- | Epsilon_Bars bterm -> Epsilon_Bars (scale_bterm coeff bterm)
-
- let aterm_times_aterm : afactor -> afactor -> afactor option =
- fun aterm1 aterm2 ->
- option_map (scale_aterm aterm1.coeff) (add_arrow_list_to_aterm aterm1.arrows aterm2)
-
- (* Almost the same as [aterm_times_term] below, but the arguments
- are exchanged an the result are [factor]s and not [free]. *)
-
- let term_times_aterm : factor -> afactor -> factor list =
- fun term aterm ->
- match add_arrow_list_to_term aterm.arrows term with
- | None -> []
- | Some factor -> [scale_term aterm.coeff factor]
-
- (* The return type is [factor list], because adding a
- product of~$\epsilon$ and~$\bar\epsilon$ will produce
- a sum of terms and the result can be a [afactor], [efactor]
- or [bfactor] depending on the number of~$\epsilon$s
- and~$\bar\epsilon$s in the arguments. *)
-
- (* \begin{dubious}
- Add more tests for multiple $\epsilon$ and $\bar\epsilon$!
- I'm not yet convinced by playing with the toplevel.
- \end{dubious} *)
-
- (* \begin{dubious}
- Calling [aterm_times_aterm] in each recursion step and
- only using the last result ist wasteful. Find a better
- way!
- \end{dubious} *)
-
- let rec match_eterm_and_bterm : efactor -> bfactor -> factor list =
- fun (aterm1, epsilons) (aterm2, epsilon_bars) ->
- match epsilons, epsilon_bars with
- | [], _ | _, [] -> failwith "add_epsilon_to_bterm: unexpected []"
- | epsilon :: epsilons, epsilon_bar :: epsilon_bars ->
- begin match aterm_times_aterm aterm1 aterm2 with
- | None -> []
- | Some aterm ->
- match A.merge_eps_eps_bar epsilon epsilon_bar with
- | None -> []
- | Some (even, odd) ->
- let even = List.rev_map (fun arrows -> { coeff = L.unit; arrows }) even
- and odd = List.rev_map (fun arrows -> { coeff = L.neg L.unit; arrows }) odd in
- let terms =
- match epsilons, epsilon_bars with
- | [], [] -> [Arrows aterm]
- | epsilons, []-> [Epsilons (aterm, epsilons)]
- | [], epsilon_bars-> [Epsilon_Bars (aterm, epsilon_bars)]
- | epsilon, epsilon_bars ->
- match_eterm_and_bterm (aterm1, epsilon) (aterm2, epsilon_bars) in
- Product.fold2
- (fun term aterm acc ->
- List.rev_append (term_times_aterm term aterm) acc)
- terms (List.rev_append even odd) []
- end
-
- (* NB: we can reject the contributions with unsaturated summation indices
- from Ghost contributions to~$T_a$ only \emph{after} adding all
- arrows that might saturate an open index. *)
-
- (* Note that a negative index might be summed only
- later in a sequence of binary products and must
- therefore be treated as free in this product. Therefore,
- we have to classify the indices as summation indices
- \emph{not only} based on their sign, but in addition based on
- whether they appear in both factors. Only then can we reject
- surviving ghosts. *)
-
- module ESet =
- Set.Make
- (struct
- type t = A.endpoint
- let compare = pcompare
- end)
-
- let negatives_arrows arrows acc =
- List.fold_right (fun a -> List.fold_right ESet.add (A.negatives a)) arrows acc
-
- let negatives_eps epsilons acc =
- List.fold_right
- (fun e -> List.fold_right ESet.add (A.negatives_eps e))
- epsilons acc
-
- let negatives_eps_bar epsilon_bars acc =
- List.fold_right
- (fun b -> List.fold_right ESet.add (A.negatives_eps_bar b))
- epsilon_bars acc
-
- let negatives = function
- | Arrows aterm -> negatives_arrows aterm.arrows ESet.empty
- | Epsilons (aterm, epsilons) ->
- negatives_eps epsilons (negatives_arrows aterm.arrows ESet.empty)
- | Epsilon_Bars (aterm, epsilon_bars) ->
- negatives_eps_bar epsilon_bars (negatives_arrows aterm.arrows ESet.empty)
-
- let aterm_times_term : afactor -> factor -> free list =
- fun aterm term ->
- match add_arrow_list_to_term aterm.arrows term with
- | None -> []
- | Some factor -> [of_factor (scale_term aterm.coeff factor)]
-
- let eterm_times_eterm : efactor -> efactor -> free list =
- fun (aterm, epsilons) eterm ->
- match add_epsilon_list_to_eterm epsilons eterm with
- | None -> []
- | Some factor ->
- begin match add_arrow_list_to_eterm aterm.arrows factor with
- | None -> []
- | Some factor -> [of_factor (Epsilons (scale_eterm aterm.coeff factor))]
- end
-
- let bterm_times_bterm : bfactor -> bfactor -> free list =
- fun (aterm, epsilon_bars) bterm ->
- match add_epsilon_bar_list_to_bterm epsilon_bars bterm with
- | None -> []
- | Some factor ->
- begin match add_arrow_list_to_bterm aterm.arrows factor with
- | None -> []
- | Some factor -> [of_factor (Epsilon_Bars (scale_bterm aterm.coeff factor))]
- end
-
- let eterm_times_bterm : efactor -> bfactor -> free list =
- fun eterm bterm ->
- List.map of_factor (match_eterm_and_bterm eterm bterm)
-
- let times1 term1 term2 =
- let summations = ESet.inter (negatives term1) (negatives term2) in
- let is_sum i = ESet.mem i summations in
- match to_left_factor is_sum term1, to_right_factor is_sum term2 with
- | Arrows aterm, factor | factor, Arrows aterm ->
- aterm_times_term aterm factor
- | Epsilons eterm1, Epsilons eterm2 ->
- eterm_times_eterm eterm1 eterm2
- | Epsilon_Bars bterm1, Epsilon_Bars bterm2 ->
- bterm_times_bterm bterm1 bterm2
- | Epsilons eterm, Epsilon_Bars bterm
- | Epsilon_Bars bterm, Epsilons eterm ->
- eterm_times_bterm eterm bterm
-
- let sum terms =
- canonicalize (List.concat terms)
-
- let times term term' =
- canonicalize
- (Product.fold2
- (fun x y -> List.rev_append (times1 x y))
- term term' [])
-
- (* \begin{dubious}
- Is that more efficient than the following implementation?
- \end{dubious} *)
-
-(*i
- let rec multiply1' acc = function
- | [] -> [acc]
- | factor :: factors ->
- List.fold_right multiply1' (times1 acc factor) factors
-
- let multiply1 = function
- | [] -> [(L.unit, [])]
- | [factor] -> [factor]
- | factor :: factors -> multiply1' factor factors
-
- let multiply terms =
- canonicalize
- (Product.fold (fun x -> List.rev_append (multiply1 x)) terms [])
-
-i*)
- (* \begin{dubious}
- Isn't that the more straightforward implementation?
- \end{dubious} *)
-
- let multiply = function
- | [] -> []
- | term :: terms ->
- canonicalize (List.fold_left times term terms)
-
- let scale1 : type a e b. L.c -> (a, e, b) term -> (a, e, b) term =
- fun q term ->
- map_term (L.scale q) id id id term
-
- let scale q = List.map (scale1 q)
-
- let diff term1 term2 =
- canonicalize (List.rev_append term1 (scale (qc_int (-1)) term2))
-
- module Infix =
- struct
- let ( +++ ) term term' = sum [term; term']
- let ( --- ) = diff
- let ( *** ) = times
- end
-
- open Infix
-
- (* Compute $ \tr(r(T_a) r(T_b) r(T_c)) $. NB: this uses the
- summation indices $-1$, $-2$ and $-3$. Therefore
- it \emph{must not} appear unevaluated more than once in a product! *)
- let trace3 r a b c =
- r a (-1) (-2) *** r b (-2) (-3) *** r c (-3) (-1)
-
- let f_of_rep r a b c =
- minus *** imag *** (trace3 r a b c --- trace3 r a c b)
-
- (* $ d_{abc} = \tr(r(T_a) [r(T_b), r(T_c)]_+) $ *)
- let d_of_rep r a b c =
- trace3 r a b c +++ trace3 r a c b
-
-(* \thocwmodulesubsection{Fusions} *)
-
-(* Here we will use the color flow described by a [Arrow.free list]
- to determine the possible outgoing color flows for the incoming
- color flows in a fusion. This translates from vertices described
- by connections among integers describing factors in the tensor product
- to color flows with integers describing individual color flow lines. *)
-
-(* \begin{dubious}
- At the moment both the factors in the tensor product and
- the color flow lines are [int]s. This could be make clearer
- by abstract types.
- \end{dubious} *)
-
-(* \begin{dubious}
- This still needs to be extended to $\epsilon$ and $\bar\epsilon$,
- i.\,e.~[Arrow.free_eps] and [Arrow.free_eps_bar].
- \end{dubious} *)
-
- module IMap =
- Map.Make (struct type t = int let compare = pcompare end)
-
- (* Take a [Propagator.t list], ignore the uncolored ([Propagator.W])
- ones and construct a map of the colored ones indexed by
- the offset into the original list. *)
- let line_map lines =
- let _, map =
+ let endpoints_of_colors colors =
+ let _, endpoints =
List.fold_left
- (fun (i, acc) line ->
- (succ i,
- match line with
- | P.W -> acc
- | _ -> IMap.add i line acc))
- (1, IMap.empty)
- lines in
- map
-
- (* For debugging: *)
- let lines_to_string lines =
- match IMap.bindings lines with
- | [] -> "W"
- | lines ->
- String.concat
- " "
- (List.map
- (fun (i, c) -> Printf.sprintf "%s@%d" (P.to_string c) i)
- lines)
-
- (* [clear i lines] removes the [Propagator.t] at position [i]
- from the map [lines]. *)
- let clear = IMap.remove
-
- (* Add the incoming color flow line [cf] at position [i]
- to the map [lines]. If there is already an outgoing
- color flow, replace it by an incoming/outgoing pair.
- \begin{dubious}
- This will overwrite any other [Propagator.t] in [lines].
- Should we be more careful and raise an exception, if the
- spot has already been taken?
- \end{dubious} *)
- let add_in i cf lines =
- match IMap.find_opt i lines with
- | Some (P.O cf') -> IMap.add i (P.IO (cf, cf')) lines
- | _ -> IMap.add i (P.I cf) lines
-
- (* Again for an outgoing color flow line \ldots *)
- let add_out i cf' lines =
- match IMap.find_opt i lines with
- | Some (P.I cf) -> IMap.add i (P.IO (cf, cf')) lines
- | _ -> IMap.add i (P.O cf') lines
-
- (* \ldots{} and a ghost without color flow. *)
- let add_ghost i lines =
- IMap.add i P.G lines
-
- (* [connect_opt n lines arrow] tries to form a new connection in the
- map [lines] using a single [arrow]. The outgoing line in the fusion
- is represented by the index [n]. *)
-
- (* If the arrow is a ghost and is connected to the outgoing line,
- just add it. If it is connected to an incoming line, remove
- this propagator, as it is saturated. *)
- let connect_ghost_opt n g lines =
- let g = A.position g in
- if g = n then
- Some (add_ghost n lines)
- else
- match IMap.find_opt g lines with
- | Some P.G -> Some (clear g lines)
- | _ -> None
-
- (* If the arrow is a connection and is connected on one side
- to the outgoing line, find the matching incoming line.
- If it is connected to two incoming lines, merge them. *)
- let connect_arrow_opt n i o lines =
- let i = A.position i and o = A.position o in
- if o = n then
- match IMap.find_opt i lines with
- | Some (P.I cfi) -> Some (add_in o cfi (clear i lines))
- | Some (P.IO (cfi, cfi')) -> Some (add_in o cfi (add_out i cfi' lines))
- | _ -> None
- else if i = n then
- match IMap.find_opt o lines with
- | Some (P.O cfo') -> Some (add_out i cfo' (clear o lines))
- | Some (P.IO (cfo, cfo')) -> Some (add_out i cfo' (add_in o cfo lines))
- | _ -> None
- else
- match IMap.find_opt i lines, IMap.find_opt o lines with
- | Some (P.I cfi), Some (P.O cfo') when cfi = cfo' ->
- Some (clear o (clear i lines))
- | Some (P.I cfi), Some (P.IO (cfo, cfo')) when cfi = cfo'->
- Some (add_in o cfo (clear i lines))
- | Some (P.IO (cfi, cfi')), Some (P.O cfo') when cfi = cfo' ->
- Some (add_out i cfi' (clear o lines))
- | Some (P.IO (cfi, cfi')), Some (P.IO (cfo, cfo')) when cfi = cfo' ->
- Some (add_in o cfo (add_out i cfi' lines))
- | _ -> None
-
- let connect_opt n lines = function
- | A.Ghost g -> connect_ghost_opt n g lines
- | A.Arrow (i, o) -> connect_arrow_opt n i o lines
-
- (* Use the ghosts and arrows in [connections] to combine the color flows
- in [lines]. *)
- let connect : A.free list -> P.t list -> P.t option =
- fun connections lines ->
- let n = succ (List.length lines)
- and lines = line_map lines in
- let rec connect' acc = function
- | arrow :: arrows ->
- begin match connect_opt n acc arrow with
- | None -> None
- | Some acc -> connect' acc arrows
- end
- | [] -> Some acc in
- match connect' lines connections with
- | None -> None
- | Some acc ->
- begin match IMap.bindings acc with
- | [] -> Some P.W
- | [(i, cf)] when i = n -> Some cf
- | _ -> None
- end
-
- let fuse1 nc lines vertex =
- match vertex with
- | Arrows { coeff; arrows } ->
- begin match connect arrows lines with
- | None -> []
- | Some cf -> [(L.eval (qc_int nc) coeff, cf)]
- end
- | Epsilons _ -> failwith "Birdtracks.fuse1: Epsilons"
- | Epsilon_Bars _ -> failwith "Birdtracks.fuse1: Epsilon_Bars"
-
- let fuse nc vertex lines =
- match vertex with
- | [] ->
- if List.for_all is_white lines then
- [(QC.unit, P.W)]
- else
- []
- | vertex ->
- ThoList.flatmap (fuse1 nc lines) vertex
+ (fun (n, endpoints) endpoint -> (succ n, add_endpoint endpoints n endpoint))
+ (1, empty_endpoints) colors in
+ endpoints
+
+ (* Merge the maps of tips and tails to find the pair of connected external
+ colors. *)
+
+ let links_of_endpoints endpoints =
+ IMap.merge
+ (fun _ tail tip ->
+ match tail, tip with
+ | None, None -> None
+ | Some tail, Some tip -> Some (tail, tip)
+ | Some tail, None -> invalid_arg ("no tip for tail " ^ string_of_int tail)
+ | None, Some tip -> invalid_arg ("no tail for tip " ^ string_of_int tip))
+ endpoints.tails endpoints.tips
+
+ (* Create an [Arrow.free list] that can be used by [Birdtracks]. *)
+ let arrows_of_links links =
+ IMap.fold (fun _ (tail, tip) acc -> Arrow.Infix.( tail => tip ) :: acc) links []
+
+ module LSet = Set.Make (struct type t = int * int let compare = Stdlib.compare end)
+
+ (* Find the set bidirectional links by computing the intersection of
+ the set of links with the set of reversed links.
+ We must keep both directions for [Birdtracks.multiply] to succeed. *)
+ let double_links links =
+ let links, rev_links =
+ IMap.fold
+ (fun _ (tail, tip) (links, rev_links) ->
+ (LSet.add (tail, tip) links, LSet.add (tip, tail) rev_links))
+ links (LSet.empty, LSet.empty) in
+ LSet.inter links rev_links
(*i
- let fuse nc vertex lines =
- let fused = fuse nc vertex lines in
- Printf.eprintf
- "%s >>> %s\n"
- (ThoList.to_string P.to_string lines)
- (ThoList.to_string (fun (_, p) -> P.to_string p) fused);
- fused
+ let f, g = birdtracks [N 5; N_bar 6; SUN (1,2); SUN (6, 5); SUN (2,1); Ghost]
+ let f' : Birdtracks.t =
+ Birdtracks.( relocate (~-) [ Arrows {coeff = Algebra.Laurent.unit; arrows = f } ] )
+ let _ =
+ Birdtracks.Infix.( f' *** Birdtracks.rev f' )
i*)
- module Test : Test =
- struct
- open OUnit
-
- let vertices_equal v1 v2 =
- (canonicalize v1) = (canonicalize v2)
-
- let eq v1 v2 =
- assert_equal ~printer:to_string_raw ~cmp:vertices_equal v1 v2
-
- let suite_times1 =
- "times1" >:::
-
- [ "merge two" >::
- (fun () ->
- eq
- [Arrows { coeff = L.unit; arrows = 1 ==> 2 }]
- (times1
- (Arrows { coeff = L.unit; arrows = 1 ==> -1 })
- (Arrows { coeff = L.unit; arrows = -1 ==> 2 })));
-
- "merge two exchanged" >::
- (fun () ->
- eq
- [Arrows { coeff = L.unit; arrows = 1 ==> 2 }]
- (times1
- (Arrows { coeff = L.unit; arrows = -1 ==> 2 })
- (Arrows { coeff = L.unit; arrows = 1 ==> -1 })));
-
- "ghost1" >::
- (fun () ->
- eq
- [Arrows { coeff = l_over_nc (-1); arrows = 1 ==> 2 }]
- (times1
- (Arrows { coeff = L.unit; arrows = [-1 => 2; ?? (-3)] })
- (Arrows { coeff = L.unit; arrows = [ 1 => -1; ?? (-3)] })));
-
- "ghost2" >::
- (fun () ->
- eq
- []
- (times1
- (Arrows { coeff = L.unit; arrows = [ 1 => -1; ?? (-3)] })
- (Arrows { coeff = L.unit; arrows = [-1 => 2; -3 => -4; -4 => -3] })));
-
- "ghost2 exchanged" >::
- (fun () ->
- eq
- []
- (times1
- (Arrows { coeff = L.unit; arrows = [-1 => 2; -3 => -4; -4 => -3] })
- (Arrows { coeff = L.unit; arrows = [ 1 => -1; ?? (-3)] }))) ]
-
- let suite_canonicalize =
- "canonicalize" >:::
-
- [ ]
-
- let line_option_to_string = function
- | None -> "no match"
- | Some line -> P.to_string line
-
- let test_connect_msg vertex formatter (expected, result) =
- Format.fprintf
- formatter
- "[%s]: expected %s, got %s"
- (ThoList.to_string A.free_to_string vertex)
- (line_option_to_string expected)
- (line_option_to_string result)
-
- let test_connect expected lines vertex =
- assert_equal
- ~printer:line_option_to_string
- expected (connect vertex lines)
-
- let test_connect_permutations expected lines vertex =
- List.iter
- (fun v ->
- assert_equal
- ~pp_diff:(test_connect_msg v)
- expected (connect v lines))
- (Combinatorics.permute vertex)
-
- let suite_connect =
- "connect" >:::
-
- [ "delta" >::
- (fun () ->
- test_connect_permutations
- (Some (P.I 1))
- [ P.I 1; P.W ]
- ( 1 ==> 3 ));
-
- "f: 1->3->2->1" >::
- (fun () ->
- test_connect_permutations
- (Some (P.IO (1, 3)))
- [P.IO (1, 2); P.IO (2, 3)]
- (A.cycle [1; 3; 2]));
-
- "f: 1->2->3->1" >::
- (fun () ->
- test_connect_permutations
- (Some (P.IO (1, 2)))
- [P.IO (3, 2); P.IO (1, 3)]
- (A.cycle [1; 2; 3])) ]
-
- let suite =
- "Color.Birdtracks" >:::
- [suite_times1;
- suite_canonicalize;
- suite_connect]
-
- let suite_long =
- "Color.Birdtracks long" >:::
- []
- end
-
- let vertices_equal v1 v2 =
- is_null (v1 --- v2)
-
- let assert_zero_vertex v =
- OUnit.assert_equal ~printer:to_string ~cmp:vertices_equal null v
-
- (* As an extra protection agains vacuous tests, we make
- sure that the LHS does not vanish. *)
- let eq v1 v2 =
- OUnit.assert_bool "LHS = 0" (not (is_null v1));
- OUnit.assert_equal ~printer:to_string ~cmp:vertices_equal v1 v2
-
- end
-
-(* \thocwmodulesection{$\mathrm{SU}(N_C)$}
- We're computing with a general $N_C$, but [epsilon] and [epsilonbar]
- make only sense for $N_C=3$. Also some of the terminology alludes
- to $N_C=3$: triplet, sextet, octet. *)
-
-(* Using the normalization~$\tr(T_{a}T_{b}) = \delta_{ab}$, we can
- check the selfconsistency of the completeness relation
- \begin{equation}
- T_{a}^{i_1j_1} T_{a}^{i_2j_2} =
- \left( \delta^{i_1j_2} \delta^{i_2j_1}
- - \frac{1}{N_C} \delta^{i_1j_1} \delta^{j_1j_2}\right)
- \end{equation}
- as
- \begin{multline}
- T_{a}^{i_1j_1} T_{a}^{i_2j_2}
- = \tr\left(T_{a_1}T_{a_2}\right) T_{a_1}^{i_1j_1} T_{a_2}^{i_2j_2}
- = T_{a_1}^{l_1l_2} T_{a_2}^{l_2l_1}
- T_{a_1}^{i_1j_1} T_{a_2}^{i_2j_2} \\
- = \left( \delta^{l_1j_1} \delta^{i_1l_2}
- - \frac{1}{N_C} \delta^{l_1l_2} \delta^{i_1j_1}\right)
- \left( \delta^{l_2j_2} \delta^{i_2l_1}
- - \frac{1}{N_C} \delta^{l_2l_1} \delta^{i_2j_2}\right)
- = \left( \delta^{i_1j_2} \delta^{i_2j_1}
- - \frac{1}{N_C} \delta^{i_1i_2} \delta^{j_2j_1}\right)
- \end{multline}
- With
- \begin{equation}
- \label{eq:f=tr(TTT)'}
- \ii f_{a_1a_2a_3}
- = \tr\left(T_{a_1}\left\lbrack T_{a_2},T_{a_3}\right\rbrack\right)
- = \tr\left(T_{a_1}T_{a_2}T_{a_3}\right)
- - \tr\left(T_{a_1}T_{a_3}T_{a_2}\right)
- \end{equation}
- and
- \begin{multline}
- \tr\left(T_{a_1}T_{a_2}T_{a_3}\right)
- T_{a_1}^{i_1j_1} T_{a_2}^{i_2j_2} T_{a_3}^{i_3j_3}
- = T_{a_1}^{l_1l_2} T_{a_2}^{l_2l_3} T_{a_3}^{l_3l_1}
- T_{a_1}^{i_1j_1} T_{a_2}^{i_2j_2} T_{a_3}^{i_3j_3} = \\
- \left( \delta^{l_1j_1} \delta^{i_1l_2}
- - \frac{1}{N_C} \delta^{l_1l_2} \delta^{i_1j_1}\right)
- \left( \delta^{l_2j_2} \delta^{i_2l_3}
- - \frac{1}{N_C} \delta^{l_2l_3} \delta^{i_2j_2}\right)
- \left( \delta^{l_3j_3} \delta^{i_3l_1}
- - \frac{1}{N_C} \delta^{l_3l_1} \delta^{i_3j_3}\right)
- \end{multline}
- we find the decomposition
- \begin{equation}
- \label{eq:fTTT'}
- \ii f_{a_1a_2a_3} T_{a_1}^{i_1j_1}T_{a_2}^{i_2j_2}T_{a_3}^{i_3j_3}
- = \delta^{i_1j_2}\delta^{i_2j_3}\delta^{i_3j_1}
- - \delta^{i_1j_3}\delta^{i_3j_2}\delta^{i_2j_1}\,.
- \end{equation} *)
-
-(* Indeed,
-\begin{verbatim}
-symbol nc;
-Dimension nc;
-vector i1, i2, i3, j1, j2, j3;
-index l1, l2, l3;
-
-local [TT] =
- ( j1(l1) * i1(l2) - d_(l1,l2) * i1.j1 / nc )
- * ( j2(l2) * i2(l1) - d_(l2,l1) * i2.j2 / nc );
-
-#procedure TTT(sign)
-local [TTT`sign'] =
- ( j1(l1) * i1(l2) - d_(l1,l2) * i1.j1 / nc )
- * ( j2(l2) * i2(l3) - d_(l2,l3) * i2.j2 / nc )
- * ( j3(l3) * i3(l1) - d_(l3,l1) * i3.j3 / nc )
- `sign' ( j1(l1) * i1(l2) - d_(l1,l2) * i1.j1 / nc )
- * ( j3(l2) * i3(l3) - d_(l2,l3) * i3.j3 / nc )
- * ( j2(l3) * i2(l1) - d_(l3,l1) * i2.j2 / nc );
-#endprocedure
-
-#call TTT(-)
-#call TTT(+)
-
-bracket nc;
-print;
-.sort
-.end
-\end{verbatim}
-gives
-\begin{verbatim}
- [TT] =
- + nc^-1 * ( - i1.j1*i2.j2 )
- + i1.j2*i2.j1;
-
- [TTT-] =
- + i1.j2*i2.j3*i3.j1 - i1.j3*i2.j1*i3.j2;
-
- [TTT+] =
- + nc^-2 * ( 4*i1.j1*i2.j2*i3.j3 )
- + nc^-1 * ( - 2*i1.j1*i2.j3*i3.j2
- - 2*i1.j2*i2.j1*i3.j3
- - 2*i1.j3*i2.j2*i3.j1 )
- + i1.j2*i2.j3*i3.j1 + i1.j3*i2.j1*i3.j2;
-\end{verbatim}
-*)
-
-module type SU3 =
- sig
- include Birdtracks
- val delta3 : int -> int -> t
- val delta8 : int -> int -> t
- val delta8_loop : int -> int -> t
- val gluon : int -> int -> t
- val delta6 : int -> int -> t
- val delta10 : int -> int -> t
- val t : int -> int -> int -> t
- val f : int -> int -> int -> t
- val d : int -> int -> int -> t
- val epsilon : int list -> t
- val epsilon_bar : int list -> t
- val t8 : int -> int -> int -> t
- val t6 : int -> int -> int -> t
- val t10 : int -> int -> int -> t
- val k6 : int -> int -> int -> t
- val k6bar : int -> int -> int -> t
- val delta_of_tableau : int Young.tableau -> int -> int -> t
- val t_of_tableau : int Young.tableau -> int -> int -> int -> t
- end
-
-module SU3 : SU3 =
- struct
-
- module A = Arrow
- open Arrow.Infix
-
- module B = Birdtracks
- type t = B.t
- let canonicalize = B.canonicalize
- let to_string = B.to_string
- let pp = B.pp
- let trivial = B.trivial
- let is_null = B.is_null
- let null = B.null
- let const = B.const
- let one = B.one
- let two = B.two
- let int = B.int
- let half = B.half
- let third = B.third
- let fraction = B.fraction
- let nc = B.nc
- let over_nc = B.over_nc
- let minus = B.minus
- let imag = B.imag
- let ints = B.ints
- let sum = B.sum
- let diff = B.diff
- let scale = B.scale
- let times = B.times
- let multiply = B.multiply
- let relocate = B.relocate
- let fuse = B.fuse
- let f_of_rep = B.f_of_rep
- let d_of_rep = B.d_of_rep
- module Infix = B.Infix
-
-(* \thocwmodulesubsection{Fundamental and Adjoint Representation} *)
-
- let delta3 i j =
- Birdtracks.( [ Arrows { coeff = LP.int 1; arrows = j ==> i } ] )
-
- let delta8 a b =
- Birdtracks.( [ Arrows { coeff = LP.int 1; arrows = a <=> b } ] )
-
- (* If the~$\delta_{ab}$ originates from
- a~$\tr(T_aT_b)$, like an effective~$gg\to H$
- coupling, it makes a difference in the color
- flow basis and we must write the full expression~(6.2)
- from~\cite{Kilian:2012pz} including the ghosts instead.
- Note that the sign for the terms with one ghost
- has not been spelled out in that reference. *)
-
- let delta8_loop a b =
- let open Birdtracks in
- [ Arrows { coeff = LP.int 1; arrows = a <=> b };
- Arrows { coeff = LP.int (-1); arrows = [a => a; ?? b] };
- Arrows { coeff = LP.int (-1); arrows = [?? a; b => b] };
- Arrows { coeff = LP.nc 1; arrows = [?? a; ?? b] } ]
-
- (* The following can be used for computing polarization sums
- (eventually, this could make the [Flow] module redundant).
- Note that we have $-N_C$ instead of $-1/N_C$ in the ghost
- contribution here, because
- two factors of $-1/N_C$ will be produced by [add_arrow]
- below, when contracting two ghost indices.
- Indeed, with this definition we can maintain
- [multiply [delta8 1 (-1); gluon (-1) (-2); delta8 (-2) 2]
- = delta8 1 2]. *)
-
- let ghost a b =
- Birdtracks.( [ Arrows { coeff = LP.nc (-1); arrows = [?? a; ?? b] } ] )
-
- let gluon a b =
- delta8 a b @ ghost a b
-
- (* Note that the arrow is directed from the second to the first
- index, opposite to our color flow paper~\cite{Kilian:2012pz}.
- Fortunately, this is just a matter of conventions.
-\begin{subequations}
-\begin{align}
-\parbox{28\unitlength}{%
- \fmfframe(4,4)(4,4){%
- \begin{fmfgraph*}(20,20)
- \fmfleft{f1,f2}
- \fmfright{g}
- \fmfv{label=$i$}{f2}
- \fmfv{label=$j$}{f1}
- \fmfv{label=$a$}{g}
- \fmf{fermion}{f1,v}
- \fmf{fermion}{v,f2}
- \fmf{gluon}{v,g}
- \end{fmfgraph*}}} &\Longrightarrow
-\parbox{28\unitlength}{%
- \fmfframe(4,4)(4,4){%
- \begin{fmfgraph*}(20,20)
- \fmfleft{f1,f2}
- \fmfright{g}
- \fmfv{label=$i$}{f2}
- \fmfv{label=$j$}{f1}
- \fmfv{label=$a$}{g}
- \fmf{phantom}{f1,v}
- \fmf{phantom}{v,f2}
- \fmf{phantom}{v,g}
- \fmffreeze
- \fmfi{phantom_arrow}{vpath (__v, __g) sideways -thick}
- \fmfi{phantom_arrow}{(reverse vpath (__v, __g)) sideways -thick}
- \fmfi{phantom_arrow}{vpath (__f1, __v)}
- \fmfi{phantom_arrow}{vpath (__v, __f2)}
- \fmfi{plain}{%
- (vpath (__f1, __v) join (vpath (__v, __g)) sideways -thick)}
- \fmfi{plain}{%
- ((reverse vpath (__g, __v) sideways -thick) join vpath (__v, __f2))}
- \end{fmfgraph*}}}
-\parbox{28\unitlength}{%
- \fmfframe(4,4)(4,4){%
- \begin{fmfgraph*}(20,20)
- \fmfleft{f1,f2}
- \fmfright{g}
- \fmfv{label=$i$}{f1}
- \fmfv{label=$j$}{f2}
- \fmfv{label=$a$}{g}
- \fmf{fermion}{f1,v}
- \fmf{fermion}{v,f2}
- \fmf{dots}{v,g}
- \end{fmfgraph*}}}\\
- T_a^{ij} \qquad\quad
- &\Longrightarrow \qquad\quad \delta^{ia}\delta^{aj}
- \qquad\qquad\qquad - \delta^{ij}
-\end{align}
-\end{subequations} *)
+ let birdtracks_of_arrows arrows =
+ Birdtracks.( relocate (~-) [ Arrows { coeff = Algebra.Laurent.unit; arrows } ] )
- let t a i j =
- let open Birdtracks in
- [ Arrows { coeff = LP.int 1; arrows = [j => a; a => i] };
- Arrows { coeff = LP.int (-1); arrows = [j => i; ?? a] } ]
-
-(* Note that while we expect $\tr(T_a)=T_a^{ii}=0$,
- the evaluation of the expression [t 1 (-1) (-1)] will stop
- at [ [ -1 => 1; 1 => -1 ] --- [ -1 => -1; ?? 1 ] ], because the
- summation index appears in a single term.
- However, a naive further evaluation would get stuck at
- [ [ 1 => 1 ] --- nc *** [ ?? 1 ] ].
- Fortunately, traces of single generators are never needed in our
- applications. We just have to resist the temptation to use them
- in unit tests. *)
-
-(*
-\begin{equation}
-\parbox{29\unitlength}{%
- \fmfframe(2,2)(2,2){%
- \begin{fmfgraph*}(25,25)
- \fmfleft{g1,g2}
- \fmfright{g3}
- \fmfv{label=$a$}{g1}
- \fmfv{label=$b$}{g2}
- \fmfv{label=$c$}{g3}
- \fmf{gluon}{g1,v}
- \fmf{gluon}{g2,v}
- \fmf{gluon}{g3,v}
- \end{fmfgraph*}}}
-\qquad\Longrightarrow
-\parbox{29\unitlength}{%
- \fmfframe(2,2)(2,2){%
- \begin{fmfgraph*}(25,25)
- \fmfleft{g1,g2}
- \fmfright{g3}
- \fmfv{label=$a$}{g1}
- \fmfv{label=$b$}{g2}
- \fmfv{label=$c$}{g3}
- \fmf{phantom}{g1,v}
- \fmf{phantom}{g2,v}
- \fmf{phantom}{g3,v}
- \fmffreeze
- \fmfi{plain}{(vpath(__g1,__v) join (reverse vpath(__g2,__v)))
- sideways thick}
- \fmfi{plain}{(vpath(__g2,__v) join (reverse vpath(__g3,__v)))
- sideways thick}
- \fmfi{plain}{(vpath(__g3,__v) join (reverse vpath(__g1,__v)))
- sideways thick}
- \fmfi{phantom_arrow}{vpath (__g1, __v) sideways thick}
- \fmfi{phantom_arrow}{vpath (__g2, __v) sideways thick}
- \fmfi{phantom_arrow}{vpath (__g3, __v) sideways thick}
- \fmfi{phantom_arrow}{(reverse vpath (__g1, __v)) sideways thick}
- \fmfi{phantom_arrow}{(reverse vpath (__g2, __v)) sideways thick}
- \fmfi{phantom_arrow}{(reverse vpath (__g3, __v)) sideways thick}
- \end{fmfgraph*}}}
-\qquad
-\parbox{29\unitlength}{%
- \fmfframe(2,2)(2,2){%
- \begin{fmfgraph*}(25,25)
- \fmfleft{g1,g2}
- \fmfright{g3}
- \fmfv{label=$a$}{g1}
- \fmfv{label=$b$}{g2}
- \fmfv{label=$c$}{g3}
- \fmf{phantom}{g1,v}
- \fmf{phantom}{g2,v}
- \fmf{phantom}{g3,v}
- \fmffreeze
- \fmfi{plain}{(vpath(__g1,__v) join (reverse vpath(__g3,__v)))
- sideways thick}
- \fmfi{plain}{(vpath(__g2,__v) join (reverse vpath(__g1,__v)))
- sideways thick}
- \fmfi{plain}{(vpath(__g3,__v) join (reverse vpath(__g2,__v)))
- sideways thick}
- \fmfi{phantom_arrow}{vpath (__g1, __v) sideways thick}
- \fmfi{phantom_arrow}{vpath (__g2, __v) sideways thick}
- \fmfi{phantom_arrow}{vpath (__g3, __v) sideways thick}
- \fmfi{phantom_arrow}{(reverse vpath (__g1, __v)) sideways thick}
- \fmfi{phantom_arrow}{(reverse vpath (__g2, __v)) sideways thick}
- \fmfi{phantom_arrow}{(reverse vpath (__g3, __v)) sideways thick}
- \end{fmfgraph*}}}
-\end{equation} *)
+ type flow =
+ { flows : Birdtracks.t;
+ gluons : Birdtracks.t }
+
+ let birdtracks colors =
+ let endpoints = endpoints_of_colors colors in
+ let links = links_of_endpoints endpoints in
+ let gluons = double_links links in
+ let flow =
+ ISet.fold
+ (fun ghost acc -> Arrow.Infix.( ?? ghost) :: acc)
+ endpoints.ghosts (arrows_of_links links)
+ and gluons =
+ LSet.fold (fun (tail, tip) acc -> Arrow.Infix.( tail => tip ) :: acc) gluons [] in
+ { flows = birdtracks_of_arrows flow;
+ gluons = birdtracks_of_arrows gluons }
+
+ (* $1-2/N_C^2$ *)
+ let fudge_factor =
+ Algebra.Laurent.ints [(1,0); (-2,-2)]
- let f a b c =
+ let factor_birdtracks f1 f2 =
let open Birdtracks in
- [ Arrows { coeff = LP.imag ( 1); arrows = A.cycle [a; b; c] };
- Arrows { coeff = LP.imag (-1); arrows = A.cycle [a; c; b] } ]
-
-(* The generator in the adjoint representation $T_a^{bc}=-\ii f_{abc}$: *)
- let t8 a b c =
- Birdtracks.Infix.( minus *** imag *** f a b c )
-
-(* This $d_{abc}$ is now compatible with~(6.11) in our color
- flow paper~\cite{Kilian:2012pz}. The signs had been wrong
- in earlier versions of the code to match the missing
- sign in the ghost contribution to the generator~$T_a^{ij}$
- above. *)
+ match number (Infix.( f1.flows *** rev f2.flows )) with
+ | None -> failwith "factor_new"
+ | Some result ->
+ if Algebra.Laurent.is_null result then
+ result
+ else
+ let gluons = Infix.( f1.gluons *** rev f2.gluons ) in
+ match number gluons with
+ | None -> result
+ | Some gluons ->
+ begin match Algebra.Laurent.log gluons with
+ | None -> failwith "factor_birdtracks log"
+ | Some (coeff, 0) -> result
+ | Some (coeff, n) ->
+ if not (Algebra.QC.is_unit coeff) then
+ failwith "factor_birdtracks log is_unit";
+ if n mod 2 <> 0 then
+ failwith "factor_birdtracks log is odd";
+ Algebra.Laurent.mul result (Algebra.Laurent.pow fudge_factor (n/2))
+ end
- let d a b c =
- let open Birdtracks in
- [ Arrows { coeff = LP.int 1; arrows = A.cycle [a; b; c] };
- Arrows { coeff = LP.int 1; arrows = A.cycle [a; c; b] };
- Arrows { coeff = LP.int (-2); arrows = (a <=> b) @ [?? c] };
- Arrows { coeff = LP.int (-2); arrows = (b <=> c) @ [?? a] };
- Arrows { coeff = LP.int (-2); arrows = (c <=> a) @ [?? b] };
- Arrows { coeff = LP.int 2; arrows = [a => a; ?? b; ?? c] };
- Arrows { coeff = LP.int 2; arrows = [?? a; b => b; ?? c] };
- Arrows { coeff = LP.int 2; arrows = [?? a; ?? b; c => c] };
- Arrows { coeff = LP.nc (-2); arrows = [?? a; ?? b; ?? c] } ]
-
-(* \thocwmodulesubsection{Decomposed Tensor Product Representations} *)
-
- let pass_through m n incoming outgoing =
- List.rev_map2 (fun i o -> (m, i) >=>> (n, o)) incoming outgoing
-
- let delta_of_permutations n permutations k l =
- let incoming = ThoList.range 0 (pred n)
- and normalization = List.length permutations in
- List.rev_map
- (fun (eps, outgoing) ->
- Birdtracks.( Arrows { coeff = LP.fraction (eps * normalization);
- arrows = pass_through l k incoming outgoing } ))
- permutations
+ let factor f1 f2 =
+ let f1 = cross_out f1
+ and f2 = cross_out f2 in
+ if equal_color_kind f1 f2 then
+ factor_birdtracks (birdtracks f1) (birdtracks f2)
+ else
+ Algebra.Laurent.null
- let totally_symmetric n =
+ let factor_of_laurent l =
List.map
- (fun p -> (1, p))
- (Combinatorics.permute (ThoList.range 0 (pred n)))
-
- let totally_antisymmetric n =
- (Combinatorics.permute_signed (ThoList.range 0 (pred n)))
-
- let delta_S n k l =
- delta_of_permutations n (totally_symmetric n) k l
-
- let delta_A n k l =
- delta_of_permutations n (totally_antisymmetric n) k l
-
- let delta6 = delta_S 2
- let delta10 = delta_S 3
- let delta15 = delta_S 4
-
- let delta3bar = delta_A 2
-
- (* Mixed symmetries, as in section 9.4 of the birdtracks book. *)
-
- module IM = Partial.Make (struct type t = int let compare = pcompare end)
- module P = Permutation.Default
-
-(* Map the elements of [original] to [permuted] in [all], with [all]
- a list of $n$ integers from $0$ to $n-1$ in order, and use the resulting
- list to define a permutation.
- E.\,g.~[permute_partial [1;3] [3;1] [0;1;2;3;4]] will define a
- permutation that transposes the second and fourth element in
- a 5 element list. *)
- let permute_partial original permuted all =
- P.of_list (List.map (IM.auto (IM.of_lists original permuted)) all)
-
- let apply1 (sign, indices) (eps, p) =
- (eps * sign, P.list p indices)
-
- let apply signed_permutations signed_indices =
- List.rev_map (apply1 signed_indices) signed_permutations
-
- let apply_list signed_permutations signed_indices =
- ThoList.flatmap (apply signed_permutations) signed_indices
-
- let symmetrizer_of_permutations n original signed_permutations =
- let incoming = ThoList.range 0 (pred n) in
- List.rev_map
- (fun (eps, permuted) ->
- (eps, permute_partial original permuted incoming))
- signed_permutations
-
- let symmetrizer n indices =
- symmetrizer_of_permutations
- n indices
- (List.rev_map (fun p -> (1, p)) (Combinatorics.permute indices))
-
- let anti_symmetrizer n indices =
- symmetrizer_of_permutations
- n indices
- (Combinatorics.permute_signed indices)
+ (fun (c, power) ->
+ let num, den = Algebra.Q.to_ratio (Algebra.QC.re c) in
+ { num; den; power} )
+ (Algebra.Laurent.to_list l)
- let symmetrize n elements indices =
- apply_list (symmetrizer n elements) indices
+ let factor_birdtracks f1 f2 =
+ factor_of_laurent (factor_birdtracks f1 f2)
- let anti_symmetrize n elements indices =
- apply_list (anti_symmetrizer n elements) indices
-
- let id n =
- [(1, ThoList.range 0 (pred n))]
-
- (* \begin{dubious}
- We can avoid the recursion here, if we use
- [Combinatorics.permute_tensor_signed] in
- [symmetrizer] above.
- \end{dubious} *)
- let rec apply_tableau f n tableau indices =
- match tableau with
- | [] | [_] :: _ -> indices
- | cells :: rest ->
- apply_tableau f n rest (f n cells indices)
-
-(* \begin{dubious}
- Here we should at a sanity test for [tableau]: all integers should
- be consecutive starting from 0 with no duplicates. In additions
- the rows must not grow in length.
- \end{dubious} *)
+ let factor f1 f2 =
+ factor_of_laurent (factor f1 f2)
- let delta_of_tableau tableau i j =
- let n = Young.num_cells_tableau tableau
- and num, den = Young.normalization (Young.diagram_of_tableau tableau)
- and rows = tableau
- and cols = Young.conjugate_tableau tableau in
- let permutations =
- apply_tableau symmetrize n rows (apply_tableau anti_symmetrize n cols (id n)) in
- Birdtracks.Infix.( int num *** fraction den *** delta_of_permutations n permutations i j )
-
- let incomplete tensor =
- failwith ("Color.Vertex: " ^ tensor ^ " not supported yet!")
-
- let experimental tensor =
- Printf.eprintf
- "Color.Vertex: %s support still experimental and untested!\n"
- tensor
-
- let distinct integers =
- let rec distinct' seen = function
- | [] -> true
- | i :: rest ->
- if Sets.Int.mem i seen then
- false
- else
- distinct' (Sets.Int.add i seen) rest in
- distinct' Sets.Int.empty integers
+ let factor_table cf_list =
+ let cf_array = Array.of_list (List.map cross_out cf_list) in
+ let birdtracks_array = Array.map birdtracks cf_array in
+ let ncf = Array.length cf_array in
+ let cf_table = Array.make_matrix ncf ncf zero in
+ for i = 0 to pred ncf do
+ for j = 0 to i do
+ if equal_color_kind cf_array.(i) cf_array.(j) then
+ begin
+ cf_table.(i).(j) <- factor_birdtracks birdtracks_array.(i) birdtracks_array.(j);
+ cf_table.(j).(i) <- cf_table.(i).(j)
+ end
+ done
+ done;
+ cf_table
- (* All lines start here: they point towards the vertex. *)
- let epsilon tips =
- if distinct tips then
- Birdtracks.( [ Epsilons ({ coeff = LP.int 1; arrows = [] }, [A.epsilon tips]) ] )
- else
- []
-
- (* All lines end here: they point away from the vertex. *)
- let epsilon_bar tails =
- if distinct tails then
- Birdtracks.( [ Epsilon_Bars ({ coeff = LP.int 1; arrows = [] }, [A.epsilon_bar tails]) ] )
- else
- []
-
-
-(* In order to get the correct $N_C$ dependence of
- quadratic Casimir operators, the arrows in the vertex must
- have the same permutation symmetry as the propagator. This
- is demonstrated by the unit tests involving Casimir operators
- on page \pageref{pg:casimir-tests} below. These tests also
- provide a check of our normalization.
-
- The implementation takes a propagator and uses [Arrow.tee] to
- replace one arrow by the pair of arrows corresponding to the
- insertion of a gluon. This is repeated for each arrow.
- The normalization remains unchanged from the propagator.
- A minus sign is added for antiparallel arrows, since the
- conjugate representation is~$-T^*_a$.
-
- To this, we add the diagrams with a gluon connected to one arrow.
- Since these are identical, only one diagram multiplied by the
- difference of the number of parallel and antiparallel arrows
- is added. *)
-
- let insert_gluon a k l term =
- let open Birdtracks in
- let rec insert_gluon' acc left = function
- | [] -> acc
- | arrow :: right ->
- insert_gluon'
- (Arrows { coeff = Algebra.Laurent.mul (LP.int (A.dir k l arrow)) term.B.coeff;
- arrows = List.rev_append left ((A.tee a arrow) @ right) } :: acc)
- (arrow :: left)
- right in
- insert_gluon' [] [] term.arrows
-
- let t_of_delta delta a k l =
- let open Birdtracks in
- match delta k l with
- | [] -> []
- | Arrows { arrows = arrows } :: _ as delta_kl ->
- let n =
- List.fold_left
- (fun acc arrow -> acc + A.dir k l arrow)
- 0 arrows in
- let ghosts =
- List.rev_map
- (fun term ->
- match term with
- | Arrows aterm ->
- Arrows { coeff = Algebra.Laurent.mul (LP.int (-n)) aterm.coeff;
- arrows = ?? a :: aterm.arrows }
- | Epsilons _ -> failwith "t_of_delta: unexpected epsilon"
- | Epsilon_Bars _ -> failwith "t_of_delta: unexpected epsilon_bar")
- delta_kl in
- List.fold_left
- (fun acc ->
- function
- | Arrows aterm -> insert_gluon a k l aterm @ acc
- | Epsilons _ -> failwith "t_of_delta: unexpected epsilon"
- | Epsilon_Bars _ -> failwith "t_of_delta: unexpected epsilon_bar")
- ghosts delta_kl
- | Epsilons _ :: _ -> failwith "t_of_delta: unexpected epsilon"
- | Epsilon_Bars _ :: _ -> failwith "t_of_delta: unexpected epsilon_bar"
-
- let t_of_delta delta a k l =
- canonicalize (t_of_delta delta a k l)
-
- let t_S n a k l =
- t_of_delta (delta_S n) a k l
-
- let t_A n a k l =
- t_of_delta (delta_A n) a k l
-
- let t6 = t_S 2
- let t10 = t_S 3
- let t15 = t_S 4
- let t3bar = t_A 2
-
-(* Equivalent definition: *)
- let t8' a b c =
- t_of_delta delta8 a b c
-
- let t_of_tableau tableau a k l =
- t_of_delta (delta_of_tableau tableau) a k l
-
-(* \begin{dubious}
- Check the following for a real live UFO file!
- \end{dubious} *)
-
-(* In the UFO paper, the Clebsh-Gordan is defined
- as~$K^{(6),ij}_{\hphantom{(6),ij}m}$. Therefore, keeping
- our convention for the generators~$T_{a\hphantom{(6),j}i}^{(6),j}$,
- the must arrows \emph{end} at~$m$. *)
- let k6 m i j =
- experimental "k6";
- let open Birdtracks in
- [ Arrows { coeff = LP.int 1; arrows = [i =>> (m, 0); j =>> (m, 1)] };
- Arrows { coeff = LP.int 1; arrows = [i =>> (m, 1); j =>> (m, 0)] } ]
-
-(* The arrow are reversed for~$\bar K^{(6),m}_{\hphantom{(6),m}ij}$
- and \emph{start} at~$m$. *)
- let k6bar m i j =
- experimental "k6bar";
- let open Birdtracks in
- [ Arrows { coeff = LP.int 1; arrows = [(m, 0) >=> i; (m, 1) >=> j] };
- Arrows { coeff = LP.int 1; arrows = [(m, 1) >=> i; (m, 0) >=> j] } ]
-
- (* \thocwmodulesubsection{Unit Tests} *)
-
module Test : Test =
struct
- open OUnit
- module L = Algebra.Laurent
-
- module B = Birdtracks
-
- open Birdtracks
- open Birdtracks.Infix
-
- let exorcise vertex =
- List.filter
- (function
- | Arrows aterm | Epsilons (aterm, _) | Epsilon_Bars (aterm, _) ->
- not (List.exists A.is_ghost aterm.arrows))
- vertex
-
- let eqx v1 v2 =
- eq (exorcise v1) (exorcise v2)
-
-(* \thocwmodulesubsection{Trivia} *)
-
- let suite_sum =
- "sum" >:::
-
- [ "atoms" >::
- (fun () ->
- eq
- (int 2 *** delta3 1 2)
- (delta3 1 2 +++ delta3 1 2)) ]
-
- let suite_diff =
- "diff" >:::
-
- [ "atoms" >::
- (fun () ->
- eq
- (delta3 3 4)
- (delta3 1 2 +++ delta3 3 4 --- delta3 1 2)) ]
-
-
-(* \begin{equation}
- \prod_{k=i}^j f(k)
- \end{equation} *)
- let rec product f i j =
- if i > j then
- null
- else if i = j then
- f i
- else
- f i *** product f (succ i) j
-
-(* In particular
- \begin{multline}
- \text{[product (nc_minus_n_plus n) i j]}\, \mapsto \\
- \prod_{k=i}^j (N_C-n+k)
- = \frac{(N_C-n+j)!}{(N_C-n+i-1)!}
- = (N_C-n+j)(N_C-n+j-1)\cdots(N_C-n+i)
- \end{multline} *)
- let nc_minus_n_plus n k =
- const (LP.ints [ (1, 1); (-n + k, 0) ])
-
- let contractions rank k =
- product (nc_minus_n_plus rank) 1 k
-
- let suite_times =
- "times" >:::
-
- [ "reorder components t1*t2" >:: (* trivial $T_a^{ik}T_a^{kj}=T_a^{kj}T_a^{ik}$ *)
- (fun () ->
- let t1 = t (-1) 1 (-2)
- and t2 = t (-1) (-2) 2 in
- eq (t1 *** t2) (t2 *** t1));
-
- "reorder components tr(t1*t2)" >:: (* trivial $T_a^{ij}T_a^{ji}=T_a^{ji}T_a^{ij}$ *)
- (fun () ->
- let t1 = t 1 (-1) (-2)
- and t2 = t 2 (-2) (-1) in
- eq (t1 *** t2) (t2 *** t1));
-
- "reorderings" >::
- (fun () ->
- let v1 = [Arrows { coeff = L.unit; arrows = [ 1 => -2; -2 => -1; -1 => 1] }]
- and v2 = [Arrows { coeff = L.unit; arrows = [-1 => 2; 2 => -2; -2 => -1] }]
- and v' = [Arrows { coeff = L.unit; arrows = [ 1 => 1; 2 => 2] }] in
- eq v' (v1 *** v2));
-
- "eps*epsbar" >::
- (fun () ->
- eq
- (delta3 1 2 *** delta3 3 4 --- delta3 1 4 *** delta3 3 2)
- (epsilon [1; 3] *** epsilon_bar [2; 4]));
-
- "eps*epsbar -" >::
- (fun () ->
- eq
- (delta3 1 4 *** delta3 3 2 --- delta3 1 2 *** delta3 3 4)
- (epsilon [1; 3] *** epsilon_bar [4; 2]));
-
- "eps*epsbar 1" >::
- (fun () ->
- eq (* $N_C-3+1=(N_C-2)$, for $NC=3$: $1$ *)
- (contractions 3 1 ***
- (delta3 1 2 *** delta3 3 4 --- delta3 1 4 *** delta3 3 2))
- (epsilon [-1; 1; 3] *** epsilon_bar [-1; 2; 4]));
-
- "eps*epsbar cyclic 1" >::
- (fun () ->
- eq (* $N_C-3+1=(N_C-2)$, for $NC=3$: $1$ *)
- (contractions 3 1 ***
- (delta3 1 2 *** delta3 3 4 --- delta3 1 4 *** delta3 3 2))
- (epsilon [3; -1; 1] *** epsilon_bar [-1; 2; 4]));
-
- "eps*epsbar cyclic 2" >::
- (fun () ->
- eq (* $N_C-3+1=(N_C-2)$, for $NC=3$: $1$ *)
- (contractions 3 1 ***
- (delta3 1 2 *** delta3 3 4 --- delta3 1 4 *** delta3 3 2))
- (epsilon [-1; 1; 3] *** epsilon_bar [4; -1; 2]));
-
- "eps*epsbar 2" >::
- (fun () ->
- eq (* $(N_C-3+2)(N_C-3+1)=(N_C-1)(N_C-2)$, for $NC=3$: $2$ *)
- (contractions 3 2 *** delta3 1 2)
- (epsilon [-1; -2; 1] *** epsilon_bar [-1; -2; 2]));
-
- "eps*epsbar 3" >::
- (fun () ->
- eq (* $(N_C-3+3)(N_C-3+2)(N_C-3+1)=N_C(N_C-1)(N_C-2)$, for $NC=3$: $3!$ *)
- (contractions 3 3)
- (epsilon [-1; -2; -3] *** epsilon_bar [-1; -2; -3]));
-
- "eps*epsbar big" >::
- (fun () ->
- eq (* $(N_C-5+3)(N_C-5+2)(N_C-5+1)=(N_C-2)(N_C-3)(N_C-4)$, for $NC=5$: $3!$ *)
- (contractions 5 3 ***
- (epsilon [4; 5] *** epsilon_bar [6; 7]))
- (epsilon [-1; -2; -3; 4; 5] *** epsilon_bar [-1; -2; -3; 6; 7]));
-
- "eps*epsbar big -" >::
- (fun () ->
- eq (* $(N_C-5+3)(N_C-5+2)(N_C-5+1)=(N_C-2)(N_C-3)(N_C-4)$, for $NC=5$: $3!$ *)
- (contractions 5 3 ***
- (epsilon [5; 4] *** epsilon_bar [6; 7]))
- (epsilon [-1; 4; -3; -2; 5] *** epsilon_bar [-1; -2; -3; 6; 7])) ]
-
-(* \thocwmodulesubsection{Propagators} *)
-
-(* Verify the normalization of the propagators by making sure
- that $D^{ij}D^{jk}=D^{ik}$ *)
- let projection_id rep_d =
- eq (rep_d 1 2) (rep_d 1 (-1) *** rep_d (-1) 2)
-
- let orthogonality d d' =
- assert_zero_vertex (d 1 (-1) *** d' (-1) 2)
-
-(* Pass every arrow straight through, without (anti-)symmetrization. *)
- let delta_unsymmetrized n k l =
- delta_of_permutations n [(1, ThoList.range 0 (pred n))] k l
-
- let completeness n tableaux =
- eq
- (delta_unsymmetrized n 1 2)
- (sum (List.map (fun t -> delta_of_tableau t 1 2) tableaux))
-
-(* The following names are of historical origin. From the time,
- when we didn't have full support for Young tableaux and
- implemented figure 9.1 from the birdtrack book.
- \ytableausetup{centertableaux,smalltableaux}
- \begin{equation}
- \ytableaushort{01,2}
- \end{equation} *)
-
- let delta_SAS i j =
- delta_of_tableau [[0;1];[2]] i j
-
-(* \begin{equation}
- \ytableaushort{02,1}
- \end{equation} *)
-
- let delta_ASA i j =
- delta_of_tableau [[0;2];[1]] i j
-
- let suite_propagators =
- "propagators" >:::
- [ "D*D=D" >:: (fun () -> projection_id delta3);
- "D8*D8=D8" >:: (fun () -> projection_id delta8);
- "G*G=G" >:: (fun () -> projection_id gluon);
- "D6*D6=D6" >:: (fun () -> projection_id delta6);
- "D10*D10=D10" >:: (fun () -> projection_id delta10);
- "D15*D15=D15" >:: (fun () -> projection_id delta15);
- "D3bar*D3bar=D3bar" >:: (fun () -> projection_id delta3bar);
- "D6*D3bar=0" >:: (fun () -> orthogonality delta6 delta3bar);
- "D_A3*D_A3=D_A3" >:: (fun () -> projection_id (delta_A 3));
- "D10*D_A3=0" >:: (fun () -> orthogonality delta10 (delta_A 3));
- "D_SAS*D_SAS=D_SAS" >:: (fun () -> projection_id delta_SAS);
- "D_ASA*D_ASA=D_ASA" >:: (fun () -> projection_id delta_ASA);
- "D_SAS*D_S3=0" >:: (fun () -> orthogonality delta_SAS (delta_S 3));
- "D_SAS*D_A3=0" >:: (fun () -> orthogonality delta_SAS (delta_A 3));
- "D_SAS*D_ASA=0" >:: (fun () -> orthogonality delta_SAS delta_ASA);
- "D_ASA*D_SAS=0" >:: (fun () -> orthogonality delta_ASA delta_SAS);
- "D_ASA*D_S3=0" >:: (fun () -> orthogonality delta_ASA (delta_S 3));
- "D_ASA*D_A3=0" >:: (fun () -> orthogonality delta_ASA (delta_A 3));
- "DU*DU=DU" >:: (fun () -> projection_id (delta_unsymmetrized 3));
-
- "S3=[0123]" >::
- (fun () ->
- eq (delta_S 4 1 2) (delta_of_tableau [[0;1;2;3]] 1 2));
-
- "A3=[0,1,2,3]" >::
- (fun () ->
- eq (delta_A 4 1 2) (delta_of_tableau [[0];[1];[2];[3]] 1 2));
-
- "[0123]*[012,3]=0" >::
- (fun () ->
- orthogonality
- (delta_of_tableau [[0;1;2;3]])
- (delta_of_tableau [[0;1;2];[3]]));
-
- "[0123]*[01,23]=0" >::
- (fun () ->
- orthogonality
- (delta_of_tableau [[0;1;2;3]])
- (delta_of_tableau [[0;1];[2;3]]));
-
- "[012,3]*[012,3]=[012,3]" >::
- (fun () -> projection_id (delta_of_tableau [[0;1;2];[3]]));
-
-(* \ytableausetup{centertableaux,smalltableaux}
- \begin{equation}
- \ytableaushort{01}
- + \ytableaushort{0,1}
- \end{equation} *)
-
- "completeness 2" >:: (fun () -> completeness 2 [ [[0;1]]; [[0];[1]] ]) ;
-
- "completeness 2'" >::
- (fun () ->
- eq
- (delta_unsymmetrized 2 1 2)
- (delta_S 2 1 2 +++ delta_A 2 1 2));
-
-(* The normalization factors are written for illustration. They are
- added by [delta_of_tableau] automatically.
- \ytableausetup{centertableaux,smalltableaux}
- \begin{equation}
- \ytableaushort{012}
- + \frac{4}{3}\cdot\ytableaushort{01,2}
- + \frac{4}{3}\cdot\ytableaushort{02,1}
- + \ytableaushort{0,1,2}
- \end{equation} *)
-
- "completeness 3" >::
- (fun () -> completeness 3 [ [[0;1;2]]; [[0;1];[2]]; [[0;2];[1]]; [[0];[1];[2]] ]);
-
- "completeness 3'" >::
- (fun () ->
- eq
- (delta_unsymmetrized 3 1 2)
- (delta_S 3 1 2 +++ delta_SAS 1 2 +++ delta_ASA 1 2 +++ delta_A 3 1 2));
-(* \ytableausetup{centertableaux,smalltableaux}
- \begin{equation}
- \ytableaushort{0123}
- + \frac{3}{2}\cdot\ytableaushort{012,3}
- + \frac{3}{2}\cdot\ytableaushort{013,2}
- + \frac{3}{2}\cdot\ytableaushort{023,1}
- + \frac{4}{3}\cdot\ytableaushort{01,23}
- + \frac{4}{3}\cdot\ytableaushort{02,13}
- + \frac{3}{2}\cdot\ytableaushort{01,2,3}
- + \frac{3}{2}\cdot\ytableaushort{02,1,3}
- + \frac{3}{2}\cdot\ytableaushort{03,1,2}
- + \ytableaushort{0,1,2,3}
- \end{equation} *)
-
- "completeness 4" >::
- (fun () ->
- completeness 4
- [ [[0;1;2;3]];
- [[0;1;2];[3]]; [[0;1;3];[2]]; [[0;2;3];[1]];
- [[0;1];[2;3]]; [[0;2];[1;3]];
- [[0;1];[2];[3]]; [[0;2];[1];[3]]; [[0;3];[1];[2]];
- [[0];[1];[2];[3]] ]) ]
-
-(* \thocwmodulesubsection{Normalization} *)
-
- let suite_normalization =
- "normalization" >:::
-
- [ "tr(t*t)" >:: (* $\tr(T_aT_b)=\delta_{ab} + \text{ghosts}$ *)
- (fun () ->
- eq
- (delta8_loop 1 2)
- (t 1 (-1) (-2) *** t 2 (-2) (-1)));
-
- "tr(t*t) sans ghosts" >:: (* $\tr(T_aT_b)=\delta_{ab}$ *)
- (fun () ->
- eqx
- (delta8 1 2)
- (t 1 (-1) (-2) *** t 2 (-2) (-1)));
-
-(* The additional ghostly terms were unexpected, but
- arises like~(6.2) in our color flow paper~\cite{Kilian:2012pz}. *)
- "t*t*t" >:: (* $T_aT_bT_a=-T_b/N_C + \ldots$ *)
- (fun () ->
- eq
- (minus *** over_nc *** t 1 2 3
- +++ [Arrows { coeff = LP.int 1; arrows = [1 => 1; 3 => 2] };
- Arrows { coeff = LP.nc (-1); arrows = [3 => 2; ?? 1] }])
- (t (-1) 2 (-2) *** t 1 (-2) (-3) *** t (-1) (-3) 3));
-
-(* As expected, these ghostly terms cancel in the summed squares
- \begin{equation}
- \tr(T_aT_bT_aT_cT_bT_c)
- = \tr(T_bT_b)/N_C^2
- = \delta_{bb}/N_C^2
- = (N_C^2-1) / N_C^2
- = 1 - 1 / N_C^2
- \end{equation} *)
- "sum((t*t*t)^2)" >::
- (fun () ->
- eq
- (ints [(1, 0); (-1, -2)])
- (t (-1) (-11) (-12) *** t (-2) (-12) (-13) *** t (-1) (-13) (-14)
- *** t (-3) (-14) (-15) *** t (-2) (-15) (-16) *** t (-3) (-16) (-11)));
-
- "d*d" >::
- (fun () ->
- eqx
- [ Arrows { coeff = LP.ints [(2, 1); (-8,-1)]; arrows = 1 <=> 2 };
- Arrows { coeff = LP.ints [(2, 0); ( 4,-2)]; arrows = [1=>1; 2=>2] }]
- (d 1 (-1) (-2) *** d 2 (-2) (-1))) ]
-
-
-(* As proposed in our color flow paper~\cite{Kilian:2012pz},
- we can get the correct (anti-)symmetrized generators
- by sandwiching the following unsymmetrized generators
- between the corresponding (anti-)symmetrized projectors.
- Therefore, the unsymmetrized generators work as long as
- they're used in Feynman diagrams, where they are connected
- by propagators that contain (anti-)symmetrized projectors.
- They even work in the Lie algebra relations and give the
- correct normalization there.
-
- They fail however for more general color algebra expressions
- that can appear in UFO files.
- In particular, the Casimir operators come out really wrong. *)
- let t_unsymmetrized n k l =
- t_of_delta (delta_unsymmetrized n) k l
-
-(* The following trivial vertices are \emph{not} used anymore,
- since they don't get the normalization of the Ward identities
- right. For the quadratic casimir operators, they always produce a
- result proportional to~$C_F=C_2(S_1)$. This can be understood because
- they correspond to a fundamental representation with spectators.
-
- (Anti-)symmetrizing by sandwiching with projectors almost works,
- but they must be multiplied by hand by the number of arrows to get the
- normalization right.
- They're here just for documenting what doesn't work. *)
- let t_trivial n a k l =
- let sterile =
- List.map (fun i -> (l, i) >=>> (k, i)) (ThoList.range 1 (pred n)) in
- [ Arrows { coeff = LP.int ( 1); arrows = ((l, 0) >=> a) :: (a =>> (k, 0)) :: sterile };
- Arrows { coeff = LP.int (-1); arrows = (?? a) :: ((l, 0) >=>> (k, 0)) :: sterile }]
-
- let t6_trivial = t_trivial 2
- let t10_trivial = t_trivial 3
- let t15_trivial = t_trivial 4
-
- let t_SAS = t_of_delta delta_SAS
- let t_ASA = t_of_delta delta_ASA
-
- let symmetrization ?rep_ts rep_tu rep_d =
- let rep_ts =
- match rep_ts with
- | None -> rep_tu
- | Some rep_t -> rep_t in
- eq
- (rep_ts 1 2 3)
- (gluon 1 (-1) *** rep_d 2 (-2) *** rep_tu (-1) (-2) (-3) *** rep_d (-3) 3)
-
- let suite_symmetrization =
- "symmetrization" >:::
-
- [ "t6" >:: (fun () -> symmetrization t6 delta6);
- "t10" >:: (fun () -> symmetrization t10 delta10);
- "t15" >:: (fun () -> symmetrization t15 delta15);
- "t3bar" >:: (fun () -> symmetrization t3bar delta3bar);
- "t_SAS" >:: (fun () -> symmetrization t_SAS delta_SAS);
- "t_ASA" >:: (fun () -> symmetrization t_ASA delta_ASA);
- "t6'" >:: (fun () -> symmetrization ~rep_ts:t6 (t_unsymmetrized 2) delta6);
- "t10'" >:: (fun () -> symmetrization ~rep_ts:t10 (t_unsymmetrized 3) delta10);
- "t15'" >:: (fun () -> symmetrization ~rep_ts:t15 (t_unsymmetrized 4) delta15);
+ open OUnit
- "t6''" >::
- (fun () ->
- eq
- (t6 1 2 3)
- (int 2 *** delta6 2 (-1) *** t6_trivial 1 (-1) (-2) *** delta6 (-2) 3));
+(* Here and elsewhere, we have to resist the temptation to define
+ these tests as functions with an additional argument [()] in the
+ hope to avoid having to package them into an explicit thunk
+ [fun () -> eq v1 v2] in order to delay
+ evaluation. It turns out that the runtime would then sometimes
+ evaluate the argument [v1] or [v2] even \emph{before} the test
+ is run. For pure functions, there is no difference, but the
+ compiler appears to treat explicit thunks specially.
+ \begin{dubious}
+ I haven't yet managed to construct a small demonstrator to find
+ out in which circumstances the premature evaluation happens.
+ \end{dubious} *)
- "t10''" >::
- (fun () ->
- eq
- (t10 1 2 3)
- (int 3 *** delta10 2 (-1) *** t10_trivial 1 (-1) (-2) *** delta10 (-2) 3));
+(*i
+ let suite_factor =
+ "factor" >:::
- "t15''" >::
+ [ "gg->gg interference" >::
(fun () ->
- eq
- (t15 1 2 3)
- (int 4 *** delta15 2 (-1) *** t15_trivial 1 (-1) (-2) *** delta15 (-2) 3)) ]
-
-(* \thocwmodulesubsection{Traces} *)
-
-(* Compute (anti-)commutators of generators in the representation~$r$,
- i.\,e.~$[r(t_a)r(t_b)]_{ij}\mp[r(t_b)r(t_a)]_{ij}$, using
- [isum<0] as summation index in the matrix products. *)
- let commutator rep_t i_sum a b i j =
- multiply [rep_t a i i_sum; rep_t b i_sum j]
- --- multiply [rep_t b i i_sum; rep_t a i_sum j]
-
- let anti_commutator rep_t i_sum a b i j =
- multiply [rep_t a i i_sum; rep_t b i_sum j]
- +++ multiply [rep_t b i i_sum; rep_t a i_sum j]
-
-(* Trace of the product of three generators in the representation~$r$,
- i.\,e.~$\tr_r(r(t_a)r(t_b)r(t_c))$, using $-1,-2,-3$ as summation indices
- in the matrix products. *)
- let trace3 rep_t a b c =
- rep_t a (-1) (-2) *** rep_t b (-2) (-3) *** rep_t c (-3) (-1)
-
- let loop3 a b c =
- [ Arrows { coeff = LP.int 1; arrows = A.cycle (List.rev [a; b; c]) };
- Arrows { coeff = LP.int (-1); arrows = (a <=> b) @ [?? c] };
- Arrows { coeff = LP.int (-1); arrows = (b <=> c) @ [?? a] };
- Arrows { coeff = LP.int (-1); arrows = (c <=> a) @ [?? b] };
- Arrows { coeff = LP.int 1; arrows = [a => a; ?? b; ?? c] };
- Arrows { coeff = LP.int 1; arrows = [?? a; b => b; ?? c] };
- Arrows { coeff = LP.int 1; arrows = [?? a; ?? b; c => c] };
- Arrows { coeff = LP.nc (-1); arrows = [?? a; ?? b; ?? c] } ]
-
- let suite_trace =
- "trace" >:::
-
- [ "tr(ttt)" >::
- (fun () -> eq (trace3 t 1 2 3) (loop3 1 2 3));
-
- "tr(ttt) cyclic 1" >:: (* $\tr(T_aT_bT_c)=\tr(T_bT_cT_a)$ *)
- (fun () -> eq (trace3 t 1 2 3) (trace3 t 2 3 1));
-
- "tr(ttt) cyclic 2" >:: (* $\tr(T_aT_bT_c)=\tr(T_cT_aT_b)$ *)
- (fun () -> eq (trace3 t 1 2 3) (trace3 t 3 1 2));
+ assert_equal
+ [ { num = 1; den = 1; power = 2 }; { num = -2; den = 1; power = 0 } ]
+ (factor
+ ([SUN(3,-1); SUN(4,-2)], [SUN(3,-1); SUN(4,-2)])
+ ([SUN(2,-1); SUN(1,-2)], [SUN(3,-4); SUN(4,-3)])));
-(* \begin{dubious}
- Do we expect this?
- \end{dubious} *)
- "tr(tttt)" >:: (* $\tr(T_aT_bT_cT_d)=\ldots$ *)
+ "???" >::
(fun () ->
- eqx
- [ Arrows { coeff = LP.int 1; arrows = A.cycle [4; 3; 2; 1] }]
- (t 1 (-1) (-2) *** t 2 (-2) (-3) *** t 3 (-3) (-4) *** t 4 (-4) (-1))) ]
-
- let suite_ghosts =
- "ghosts" >:::
-
- [ "H->gg" >::
- (fun () ->
- eq
- (delta8_loop 1 2)
- (t 1 (-1) (-2) *** t 2 (-2) (-1)));
-
- "H->ggg f" >::
- (fun () ->
- eq
- (imag *** f 1 2 3)
- (trace3 t 1 2 3 --- trace3 t 1 3 2));
-
- "H->ggg d" >::
- (fun () ->
- eq
- (d 1 2 3)
- (trace3 t 1 2 3 +++ trace3 t 1 3 2));
-
- "H->ggg f'" >::
- (fun () ->
- eq
- (imag *** f 1 2 3)
- (t 1 (-3) (-2) *** commutator t (-1) 2 3 (-2) (-3)));
-
- "H->ggg d'" >::
- (fun () ->
- eq
- (d 1 2 3)
- (t 1 (-3) (-2) *** anti_commutator t (-1) 2 3 (-2) (-3)));
-
- "H->ggg cyclic'" >::
- (fun () ->
- let trace a b c =
- t a (-3) (-2) *** commutator t (-1) b c (-2) (-3) in
- eq (trace 1 2 3) (trace 2 3 1)) ]
-
- let ff a1 a2 a3 a4 =
- [ Arrows { coeff = LP.int (-1); arrows = A.cycle [a1; a2; a3; a4] };
- Arrows { coeff = LP.int ( 1); arrows = A.cycle [a2; a1; a3; a4] };
- Arrows { coeff = LP.int ( 1); arrows = A.cycle [a1; a2; a4; a3] };
- Arrows { coeff = LP.int (-1); arrows = A.cycle [a2; a1; a4; a3] } ]
-
- let tf j i a b =
- [ Arrows { coeff = LP.imag ( 1); arrows = A.chain [i; a; b; j] };
- Arrows { coeff = LP.imag (-1); arrows = A.chain [i; b; a; j] } ]
-
- let suite_ff =
- "f*f" >:::
- [ "1" >:: (fun () -> eq (ff 1 2 3 4) (f (-1) 1 2 *** f (-1) 3 4));
- "2" >:: (fun () -> eq (ff 1 2 3 4) (f (-1) 1 2 *** f 3 4 (-1)));
- "3" >:: (fun () -> eq (ff 1 2 3 4) (f (-1) 1 2 *** f 4 (-1) 3)) ]
-
- let suite_tf =
- "t*f" >:::
- [ "1" >:: (fun () -> eq (tf 1 2 3 4) (t (-1) 1 2 *** f (-1) 3 4)) ]
-
-(* \thocwmodulesubsection{Completeness Relation} *)
-
-(* Check the completeness relation corresponding
- to $q\bar q$-scattering:
- \begin{equation}
- \parbox{38\unitlength}{%
- \fmfframe(4,2)(4,4){%
- \begin{fmfgraph*}(30,20)
- \setupFourAmp
- \fmflabel{$i$}{i2}
- \fmflabel{$j$}{i1}
- \fmflabel{$k$}{o1}
- \fmflabel{$l$}{o2}
- \fmf{fermion}{i1,v1,i2}
- \fmf{fermion}{o2,v2,o1}
- \fmf{gluon}{v1,v2}
- \end{fmfgraph*}}} =
- \parbox{38\unitlength}{%
- \fmfframe(4,2)(4,4){%
- \begin{fmfgraph*}(30,20)
- \setupFourAmp
- \fmflabel{$i$}{i2}
- \fmflabel{$j$}{i1}
- \fmflabel{$k$}{o1}
- \fmflabel{$l$}{o2}
- \fmfi{phantom_arrow}{vpath (__i1, __v1)}
- \fmfi{phantom_arrow}{vpath (__v1, __v2) sideways -thick}
- \fmfi{phantom_arrow}{vpath (__v2, __o1)}
- \fmfi{phantom_arrow}{vpath (__o2, __v2)}
- \fmfi{phantom_arrow}{reverse vpath (__v1, __v2) sideways -thick}
- \fmfi{phantom_arrow}{vpath (__v1, __i2)}
- \fmfi{plain}{vpath (__i1, __v1) join
- (vpath (__v1, __v2) sideways -thick) join
- vpath (__v2, __o1)}
- \fmfi{plain}{vpath (__o2, __v2) join
- (reverse vpath (__v1, __v2) sideways -thick) join
- vpath (__v1, __i2)}
- \end{fmfgraph*}}} +
- \parbox{38\unitlength}{%
- \fmfframe(4,2)(4,4){%
- \begin{fmfgraph*}(30,20)
- \setupFourAmp
- \fmflabel{$i$}{i2}
- \fmflabel{$j$}{i1}
- \fmflabel{$k$}{o1}
- \fmflabel{$l$}{o2}
- \fmfi{phantom_arrow}{vpath (__i1, __v1)}
- \fmfi{phantom_arrow}{vpath (__v2, __o1)}
- \fmfi{phantom_arrow}{vpath (__o2, __v2)}
- \fmfi{phantom_arrow}{vpath (__v1, __i2)}
- \fmfi{plain}{vpath (__i1, __v1) join
- vpath (__v1, __i2)}
- \fmfi{plain}{vpath (__o2, __v2) join
- vpath (__v2, __o1)}
- \fmfi{dots,label=$-1/N_C$}{vpath (__v1, __v2)}
- \end{fmfgraph*}}}
- \end{equation} *)
-
- (* $T_{a}^{ij} T_{a}^{kl}$ *)
- let tt i j k l =
- t (-1) i j *** t (-1) k l
-
- (* $ \delta^{il}\delta^{kj} - \delta^{ij}\delta^{kl}/N_C$ *)
- let tt_expected i j k l =
- [ Arrows { coeff = LP.int 1; arrows = [l => i; j => k] };
- Arrows { coeff = LP.over_nc (-1); arrows = [j => i; l => k] }]
-
- let suite_tt =
- "t*t" >:::
- [ "1" >:: (* $T_{a}^{ij} T_{a}^{kl} = \delta^{il}\delta^{kj} - \delta^{ij}\delta^{kl}/N_C$ *)
- (fun () -> eq (tt_expected 1 2 3 4) (tt 1 2 3 4)) ]
-
-(* \thocwmodulesubsection{Lie Algebra} *)
-
-(* Check the commutation relations $[T_a,T_b]=\ii f_{abc} T_c$
- in various representations. *)
- let lie_algebra_id rep_t =
- let lhs = imag *** f 1 2 (-1) *** t (-1) 3 4
- and rhs = commutator t (-1) 1 2 3 4 in
- eq lhs rhs
-
-(* Check the normalization of the structure consistants
- $\mathcal{N} f_{abc} = - \ii \tr(T_a[T_b,T_c])$ *)
- let f_of_rep_id norm rep_t =
- let lhs = norm *** f 1 2 3
- and rhs = f_of_rep rep_t 1 2 3 in
- eq lhs rhs
-
-(* \begin{dubious}
- Are the normalization factors for the traces of the higher dimensional
- representations correct?
- \end{dubious} *)
-(* \begin{dubious}
- The traces don't work for the symmetrized generators
- that we need elsewhere!
- \end{dubious} *)
- let suite_lie =
- "Lie algebra relations" >:::
- [ "[t,t]=ift" >:: (fun () -> lie_algebra_id t);
- "[t8,t8]=ift8" >:: (fun () -> lie_algebra_id t8);
- "[t6,t6]=ift6" >:: (fun () -> lie_algebra_id t6);
- "[t10,t10]=ift10" >:: (fun () -> lie_algebra_id t10);
- "[t15,t15]=ift15" >:: (fun () -> lie_algebra_id t15);
- "[t3bar,t3bar]=ift3bar" >:: (fun () -> lie_algebra_id t3bar);
- "[tSAS,tSAS]=iftSAS" >:: (fun () -> lie_algebra_id t_SAS);
- "[tASA,tASA]=iftASA" >:: (fun () -> lie_algebra_id t_ASA);
- "[t6,t6]=ift6'" >:: (fun () -> lie_algebra_id (t_unsymmetrized 2));
- "[t10,t10]=ift10'" >:: (fun () -> lie_algebra_id (t_unsymmetrized 3));
- "[t15,t15]=ift15'" >:: (fun () -> lie_algebra_id (t_unsymmetrized 4));
- "[t6,t6]=ift6''" >:: (fun () -> lie_algebra_id t6_trivial);
- "[t10,t10]=ift10''" >:: (fun () -> lie_algebra_id t10_trivial);
- "[t15,t15]=ift15''" >:: (fun () -> lie_algebra_id t15_trivial);
- "if = tr(t[t,t])" >:: (fun () -> f_of_rep_id one t);
- "2n*if = tr(t8[t8,t8])" >:: (fun () -> f_of_rep_id (two *** nc) t8);
- "n*if = tr(t6[t6,t6])" >:: (fun () -> f_of_rep_id nc t6_trivial);
- "n^2*if = tr(t10[t10,t10])" >:: (fun () -> f_of_rep_id (nc *** nc) t10_trivial);
- "n^3*if = tr(t15[t15,t15])" >:: (fun () -> f_of_rep_id (nc *** nc *** nc) t15_trivial) ]
-
-(* \thocwmodulesubsection{Ward Identities} *)
-
-(* Testing the color part of basic Ward identities is essentially
- the same as testing the Lie algebra equations above, but with
- generators sandwiched between propagators, as in Feynman diagrams,
- where the relative signs come from the kinematic part of the
- diagrams after applying the equations of motion.. *)
-
- (* First the diagram with the three gluon vertex
- $\ii f_{abc} D_{cd}^{\text{gluon}} D^{ik} T_d^{kl} D^{lj}$ *)
- let ward_ft rep_t rep_d a b i j =
- imag *** f a b (-11) *** gluon (-11) (-12)
- *** rep_d i (-1) *** rep_t (-12) (-1) (-2) *** rep_d (-2) j
-
- (* then one diagram with two gauge couplings
- $D^{ik} T_c^{kl} D^{lm} T_c^{mn} D^{nj}$ *)
- let ward_tt1 rep_t rep_d a b i j =
- rep_d i (-1) *** rep_t a (-1) (-2) *** rep_d (-2) (-3)
- *** rep_t b (-3) (-4) *** rep_d (-4) j
-
- (* finally the difference of exchanged orders:
- $D^{ik} T_a^{kl} D^{lm} T_b^{mn} D^{nj}
- -D^{ik} T_b^{kl} D^{lm} T_a^{mn} D^{nj}$ *)
- let ward_tt rep_t rep_d a b i j =
- ward_tt1 rep_t rep_d a b i j --- ward_tt1 rep_t rep_d b a i j
-
- (* \begin{dubious}
- The optional [~fudge] factor was used for
- debugging normalizations.
- \end{dubious} *)
- let ward_id ?(fudge=one) rep_t rep_d =
- let lhs = ward_ft rep_t rep_d 1 2 3 4
- and rhs = ward_tt rep_t rep_d 1 2 3 4 in
- eq lhs (fudge *** rhs)
-
- let suite_ward =
- "Ward identities" >:::
- [ "fund." >:: (fun () -> ward_id t delta3);
- "adj." >:: (fun () -> ward_id t8 delta8);
- "S2" >:: (fun () -> ward_id t6 delta6);
- "S3" >:: (fun () -> ward_id t10 delta10);
- "A2" >:: (fun () -> ward_id t3bar delta3bar);
- "A3" >:: (fun () -> ward_id (t_A 3) (delta_A 3));
- "SAS" >:: (fun () -> ward_id t_SAS delta_SAS);
- "ASA" >:: (fun () -> ward_id t_ASA delta_ASA);
- "S2'" >:: (fun () -> ward_id ~fudge:two t6_trivial delta6);
- "S3'" >:: (fun () -> ward_id ~fudge:(int 3) t10_trivial delta10) ]
-
- let suite_ward_long =
- "Ward identities" >:::
- [ "S4" >:: (fun () -> ward_id t15 delta15);
- "S4'" >:: (fun () -> ward_id ~fudge:(int 4) t15_trivial delta15) ]
-
-(* \thocwmodulesubsection{Jacobi Identities} *)
-
- (* $T_aT_bT_c$ *)
- let prod3 rep_t a b c i j =
- rep_t a i (-1) *** rep_t b (-1) (-2) *** rep_t c (-2) j
-
- (* $[T_a,[T_b,T_c]]$ *)
- let jacobi1 rep_t a b c i j =
- (prod3 rep_t a b c i j --- prod3 rep_t a c b i j)
- --- (prod3 rep_t b c a i j --- prod3 rep_t c b a i j)
-
- (* sum of cyclic permutations of $[T_a,[T_b,T_c]]$ *)
- let jacobi rep_t =
- sum [jacobi1 rep_t 1 2 3 4 5;
- jacobi1 rep_t 2 3 1 4 5;
- jacobi1 rep_t 3 1 2 4 5]
-
- let jacobi_id rep_t =
- assert_zero_vertex (jacobi rep_t)
-
- let suite_jacobi =
- "Jacobi identities" >:::
- [ "fund." >:: (fun () -> jacobi_id t);
- "adj." >:: (fun () -> jacobi_id f);
- "S2" >:: (fun () -> jacobi_id t6);
- "S3" >:: (fun () -> jacobi_id t10);
- "A2" >:: (fun () -> jacobi_id (t_A 2));
- "A3" >:: (fun () -> jacobi_id (t_A 3));
- "SAS" >:: (fun () -> jacobi_id t_SAS);
- "ASA" >:: (fun () -> jacobi_id t_ASA);
- "S2'" >:: (fun () -> jacobi_id t6_trivial);
- "S3'" >:: (fun () -> jacobi_id t10_trivial) ]
-
- let suite_jacobi_long =
- "Jacobi identities" >:::
- [ "S4" >:: (fun () -> jacobi_id t15);
- "S4'" >:: (fun () -> jacobi_id t15_trivial) ]
-
-(* \thocwmodulesubsection{Casimir Operators}
- \label{pg:casimir-tests} *)
-
- (* We can read of the eigenvalues of the Casimir operators for
- the adjoint, totally symmetric and totally antisymmetric
- representations of~$\mathrm{SU}(N)$ from table~II of
- \texttt{hep-ph/0611341}
- \begin{subequations}
- \begin{align}
- C_2(\text{adj}) &= 2N \\
- C_2(S_n) &= \frac{n(N-1)(N+n)}{N} \\
- C_2(A_n) &= \frac{n(N-n)(N+1)}{N}
- \end{align}
- \end{subequations}
- adjusted for our normalization.
- Also from \texttt{arxiv:1912.13302}
- \begin{equation}
- C_3(S_1) =(N^2-1)(N^2-4)/N^2=\frac{N_C^4-5N_C^2+4}{N_C^2}
- \end{equation} *)
-
- (* Building blocks $n/N_C$ and $N_C+n$ *)
- let n_over_nc n = const (LP.ints [ (n, -1) ])
- let nc_plus n = const (LP.ints [ (1, 1); (n,0) ])
-
- (* $C_2(S_n) = n/N_C(N_C-1)(N_C+n)$ *)
- let c2_S n = n_over_nc n *** nc_plus (-1) *** nc_plus n
-
- (* $C_2(A_n) = n/N_C(N_C-n)(N_C+1)$ *)
- let c2_A n = n_over_nc n *** nc_plus (-n) *** nc_plus 1
-
- let casimir_tt i j = c2_S 1 *** delta3 i j
- let casimir_t6t6 i j = c2_S 2 *** delta6 i j
- let casimir_t10t10 i j = c2_S 3 *** delta10 i j
- let casimir_t15t15 i j = c2_S 4 *** delta15 i j
- let casimir_t3bart3bar i j = c2_A 2 *** delta3bar i j
- let casimir_tA3tA3 i j = c2_A 3 *** delta_A 3 i j
-
- (* $C_2(\text{adj})=2N_C$ *)
- let ca = LP.ints [(2, 1)]
- let casimir_ff a b =
- [ Arrows { coeff = ca; arrows = 1 <=> 2 };
- Arrows { coeff = LP.int (-2); arrows = [1=>1; 2=>2] }]
-
- (* $C_3(S_1)=N_C^2-5+4/N_C^2$ *)
- let c3f = LP.ints [(1, 2); (-5, 0); (4, -2)]
- let casimir_ttt i j = const c3f *** delta3 i j
-
- let suite_casimir =
- "Casimir operators" >:::
-
- [ "t*t" >::
- (fun () ->
- eq
- (casimir_tt 1 2)
- (t (-1) 1 (-2) *** t (-1) (-2) 2));
-
- "t*t*t" >::
- (fun () ->
- eq
- (casimir_ttt 1 2)
- (d (-1) (-2) (-3) ***
- t (-1) 1 (-4) *** t (-2) (-4) (-5) *** t (-3) (-5) 2));
-
- "f*f" >::
- (fun () ->
- eq
- (casimir_ff 1 2)
- (minus *** f (-1) 1 (-2) *** f (-1) (-2) 2));
-
- "t6*t6" >::
- (fun () ->
- eq
- (casimir_t6t6 1 2)
- (t6 (-1) 1 (-2) *** t6 (-1) (-2) 2));
-
- "t3bar*t3bar" >::
- (fun () ->
- eq
- (casimir_t3bart3bar 1 2)
- (t3bar (-1) 1 (-2) *** t3bar (-1) (-2) 2));
-
- "tA3*tA3" >::
- (fun () ->
- eq
- (casimir_tA3tA3 1 2)
- (t_A 3 (-1) 1 (-2) *** t_A 3 (-1) (-2) 2));
-
- "t_SAS*t_SAS" >::
- (fun () ->
- eq
- (const (LP.ints [(3,1); (-9,-1)]) *** delta_SAS 1 2)
- (t_SAS (-1) 1 (-2) *** t_SAS (-1) (-2) 2));
-
- "t_ASA*t_ASA" >::
- (fun () ->
- eq
- (const (LP.ints [(3,1); (-9,-1)]) *** delta_ASA 1 2)
- (t_ASA (-1) 1 (-2) *** t_ASA (-1) (-2) 2));
-
- "t10*t10" >::
- (fun () ->
- eq
- (casimir_t10t10 1 2)
- (t10 (-1) 1 (-2) *** t10 (-1) (-2) 2)) ]
-
- let suite_casimir_long =
- "Casimir operators" >:::
-
- [ "t15*t15" >::
- (fun () ->
- eq
- (casimir_t15t15 1 2)
- (t15 (-1) 1 (-2) *** t15 (-1) (-2) 2)) ]
-
-(* \thocwmodulesubsection{Color Sums} *)
-
- let suite_colorsums =
- "(squared) color sums" >:::
-
- [ "gluon normalization" >::
- (fun () ->
- eq
- (delta8 1 2)
- (delta8 1 (-1) *** gluon (-1) (-2) *** delta8 (-2) 2));
-
- "f*f" >::
- (fun () ->
- let sum_ff =
- multiply [ f (-11) (-12) (-13);
- f (-21) (-22) (-23);
- gluon (-11) (-21);
- gluon (-12) (-22);
- gluon (-13) (-23) ]
- and expected = ints [(2, 3); (-2, 1)] in
- eq expected sum_ff);
-
- "d*d" >::
- (fun () ->
- let sum_dd =
- multiply [ d (-11) (-12) (-13);
- d (-21) (-22) (-23);
- gluon (-11) (-21);
- gluon (-12) (-22);
- gluon (-13) (-23) ]
- and expected = ints [(2, 3); (-10, 1); (8, -1)] in
- eq expected sum_dd);
-
- "f*d" >::
- (fun () ->
- let sum_fd =
- multiply [ f (-11) (-12) (-13);
- d (-21) (-22) (-23);
- gluon (-11) (-21);
- gluon (-12) (-22);
- gluon (-13) (-23) ] in
- assert_zero_vertex sum_fd);
-
- "Hgg" >::
- (fun () ->
- let sum_hgg =
- multiply [ delta8_loop (-11) (-12);
- delta8_loop (-21) (-22);
- gluon (-11) (-21);
- gluon (-12) (-22) ]
- and expected = ints [(1, 2); (-1, 0)] in
- eq expected sum_hgg) ]
+ assert_equal
+ [ ]
+ (factor
+ ([N_bar (-1); N 1], [Ghost])
+ ([N 1; N_bar (-1)], [Ghost]))) ]
let suite =
- "Color.SU3" >:::
- [suite_sum;
- suite_diff;
- suite_times;
- suite_normalization;
- suite_symmetrization;
- suite_ghosts;
- suite_propagators;
- suite_trace;
- suite_ff;
- suite_tf;
- suite_tt;
- suite_lie;
- suite_ward;
- suite_jacobi;
- suite_casimir;
- suite_colorsums]
+ "Color.Flow" >:::
+ [suite_factor]
+i*)
+ let suite =
+ "Color.Flow" >:::
+ []
let suite_long =
- "Color.SU3 long" >:::
- [suite_ward_long;
- suite_jacobi_long;
- suite_casimir_long]
+ "Color.Flow long" >:::
+ []
end
-
end
+(* \thocwmodulesection{$\mathrm{SU}(N_C)$} *)
+
module Vertex = SU3
Index: trunk/omega/src/omega_SM_top_anom.ml
===================================================================
--- trunk/omega/src/omega_SM_top_anom.ml (revision 8899)
+++ trunk/omega/src/omega_SM_top_anom.ml (revision 8900)
@@ -1,36 +1,27 @@
(* omega_SM_top_anom.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
Fabian Bach <fabian.bach@t-online.de> (only this file)
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.Fortran)
- (Modellib_SM.SM(Modellib_SM.SM_anomalous_top))
+module O = Omega.Mixed23(Target_Fortran.Make)(Modellib_SM.SM(Modellib_SM.SM_anomalous_top))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/color_Propagator.mli
===================================================================
--- trunk/omega/src/color_Propagator.mli (revision 0)
+++ trunk/omega/src/color_Propagator.mli (revision 8900)
@@ -0,0 +1,115 @@
+(* color_Propagator.mli --
+
+ Copyright (C) 2022-2023 by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+ with contributions from
+ Christian Speckner <cnspeckn@googlemail.com>
+
+ 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. *)
+
+(* Possible color flows for a single propagator, as currently
+ supported by WHIZARD. *)
+
+(* In a model without $\epsilon$ or $\bar\epsilon$ couplings,
+ the color flow can be represented by arrays of identifiers
+ (integers) of color flow lines. One array for incoming lines
+ and another one for outgoing lines. In addition, the propagator
+ can represent a ghost line.
+
+ If there are only fundamental, conjugate and adjoint
+ representations with $T_a$ and $f_{abc}$ couplings,
+ there will be at most of incoming and at most one outgoing
+ line. In tensor product representations, there are more than
+ one incoming or outgoing color flow line.
+
+ Things become more involved, when there are $\epsilon$ or $\bar\epsilon$
+ couplings. Fortunately, it is not possible to contract two $\epsilon$
+ or two $\bar\epsilon$, while pairs of $\epsilon$ and $\bar\epsilon$
+ can always be replaced by a sum over color flows. *)
+
+(* For typechecking, it might be beneficial to make these
+ abstract or [private] eventually. *)
+type cf_in = int
+type cf_out = int
+
+(* Note that these do not need to be not mutually recursive,
+ since $\epsilon$ can not be nested beneath $\epsilon$ (analogously
+ for $\bar\epsilon$) and a $\bar\epsilon$ beneath a $\epsilon$
+ (and vice versa) can be expanded as a sum over permuted
+ color flows. *)
+
+(* Also note that the [list]s for [eps] and [eps_bar] have
+ one element less than [s_eps] and [s_eps_bar]. The latter
+ represent fully saturated $\epsilon$ and $\bar\epsilon$,
+ while the former have one open index. *)
+
+type eps = cf_out list
+type s_eps = cf_out list
+type cf_in_or_eps =
+ | CF_in of cf_in
+ | Epsilon of eps
+
+type eps_bar = cf_in list
+type s_eps_bar = cf_in list
+type cf_out_or_eps_bar =
+ | CF_out of cf_out
+ | Epsilon_Bar of eps_bar
+
+(* These types guarantee that there is never a pair
+ of $\epsilon$ and $\bar\epsilon$ that has yet to be contracted. *)
+
+type flow = cf_in PArray.t * cf_out PArray.t
+type flow_eps = cf_in_or_eps PArray.t * cf_out PArray.t
+type flow_eps_bar = cf_in PArray.t * cf_out_or_eps_bar PArray.t
+
+(* Note that the ghosts might carry fully saturated
+ $\epsilon$ and $\bar\epsilon$ originating from deeper
+ in the DAG. *)
+
+type t =
+ | Flow of flow
+ | Flow_with_Epsilons of flow_eps * s_eps list
+ | Flow_with_Epsilon_Bars of flow_eps_bar * s_eps_bar list
+ | Ghost
+ | Ghost_with_Epsilons of s_eps list
+ | Ghost_with_Epsilon_Bars of s_eps_bar list
+
+(* Project onto [Flow], if possible. *)
+val normalize : t -> t
+
+(* Simple constructors. *)
+val white : t
+val of_lists : int list -> int list -> t
+
+(* Simple predicates. *)
+val is_white : t -> bool
+
+(* Reverse arrows. *)
+val conjugate : t -> t
+
+(* Some ordering. *)
+val compare : t -> t -> int
+val equal : t -> t -> bool
+
+(* Allowed as (a part of) an identifier in Fortran
+ and other programming languages. *)
+val to_symbol : t -> string
+
+(* Pretty printer for the toplevel. *)
+val to_string : t -> string
+val pp : Format.formatter -> t -> unit
Index: trunk/omega/src/NList.ml
===================================================================
--- trunk/omega/src/NList.ml (revision 0)
+++ trunk/omega/src/NList.ml (revision 8900)
@@ -0,0 +1,98 @@
+(* NList.ml --
+
+ Copyright (C) 2022-2023 by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+ with contributions from
+ Christian Speckner <cnspeckn@googlemail.com>
+
+ 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. *)
+
+(* The constructor [Zero] appears to be not needed,
+ but the constructor [Successor] is required. *)
+
+type z = Zero
+type 'a s = Successor
+
+type (_, _) t =
+ | Nil : (z, 'a) t
+ | Cons : 'a * ('n, 'a) t -> ('n s, 'a) t
+
+let empty = Nil
+
+let cons : type n. 'a -> (n, 'a) t -> (n s, 'a) t =
+ fun x xs ->
+ Cons (x, xs)
+
+let hd : type n. (n s, 'a) t -> 'a = function
+ | Cons (x, _) -> x
+
+let tl : type n. (n s, 'a) t -> (n, 'a) t = function
+ | Cons (_, xs) -> xs
+
+let rec fold_right : type n. ('a -> 'b -> 'b) -> (n, 'a) t -> 'b -> 'b=
+ fun f alist b ->
+ match alist with
+ | Nil -> b
+ | Cons (a, rest) -> f a (fold_right f rest b)
+
+let rec map : type n. ('a -> 'b) -> (n, 'a) t -> (n, 'b) t =
+ fun f ->
+ function
+ | Nil -> Nil
+ | Cons (x, xs) -> Cons (f x, map f xs)
+
+let rec to_list : type n. (n, 'a) t -> 'a list = function
+ | Nil -> []
+ | Cons (a, a_list) -> a :: to_list a_list
+
+let rec map2 : type n. ('a -> 'b -> 'c) -> (n, 'a) t -> (n, 'b) t -> (n, 'c) t =
+ fun f a_list b_list ->
+ match a_list, b_list with
+ | Nil, Nil -> Nil
+ | Cons (x, xs), Cons (y, ys) -> Cons (f x y, map2 f xs ys)
+
+(* This corresponds to a bubble sort. Don't use this for long lists!
+ However, we expect the lists to be very short anyway and type safe
+ reversing or concatenating two lists as required by the better performing
+ algorithms requires to much effort for our applications. *)
+
+(* Inner step: find an element that is out of order and push it past
+ the adjacent lesser elements. Report whether a transposition was made. *)
+
+let rec cycle : type n. ('a -> 'a -> int) -> (n, 'a) t -> bool * (n, 'a) t =
+ fun cmp ->
+ function
+ | Nil -> (false, Nil)
+ | Cons (_, Nil) as a -> (false, a)
+ | Cons (a1, (Cons (a2, alist2) as alist1)) ->
+ if cmp a1 a2 <= 0 then
+ let flipped, alist = cycle cmp alist1 in
+ (flipped, Cons (a1, alist))
+ else
+ let flipped, alist = cycle cmp (Cons (a1, alist2)) in
+ (true, Cons (a2, alist))
+
+(* Repeat the inner step until no more elements are out of order. *)
+
+let rec sort : type n. ('a -> 'a -> int) -> (n, 'a) t -> (n, 'a) t =
+ fun cmp alist ->
+ let flipped, cycled = cycle cmp alist in
+ if flipped then
+ sort cmp cycled
+ else
+ cycled
Index: trunk/omega/src/colorize.mli
===================================================================
--- trunk/omega/src/colorize.mli (revision 8899)
+++ trunk/omega/src/colorize.mli (revision 8900)
@@ -1,41 +1,35 @@
(* colorize.mli --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
(* \thocwmodulesection{\ldots} *)
module It (M : Model.T) :
Model.Colorized with type flavor_sans_color = M.flavor
and type constant = M.constant
+ and type coupling_order = M.coupling_order
module Gauge (M : Model.Gauge) :
Model.Colorized_Gauge with type flavor_sans_color = M.flavor
and type constant = M.constant
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
+ and type coupling_order = M.coupling_order
Index: trunk/omega/src/omega_UFO_Dirac.ml
===================================================================
--- trunk/omega/src/omega_UFO_Dirac.ml (revision 8899)
+++ trunk/omega/src/omega_UFO_Dirac.ml (revision 8900)
@@ -1,26 +1,26 @@
(* omega_UFO.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Nary(Targets.Fortran)(UFO.Model)
+module O = Omega.Nary(Target_Fortran.Make)(UFO.Model)
let _ = O.main ()
Index: trunk/omega/src/modellib_NMSSM.ml
===================================================================
--- trunk/omega/src/modellib_NMSSM.ml (revision 8899)
+++ trunk/omega/src/modellib_NMSSM.ml (revision 8900)
@@ -1,1594 +1,1598 @@
(* modellib_NMSSM.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
Felix Braam (this file only)
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
(* \thocwmodulesection{Next-to-Minimal Supersymmetric Standard Model} *)
(* This is based on the NMSSM implementation by Felix Braam. Note that for the
Higgs sector vertices the conventions of the Franke/Fraas paper have been
used. *)
module type NMSSM_flags =
sig
val ckm_present : bool
val higgs_triangle : bool
end
module NMSSM : NMSSM_flags =
struct
let ckm_present = false
let higgs_triangle = false
end
module NMSSM_CKM : NMSSM_flags =
struct
let ckm_present = true
let higgs_triangle = false
end
module NMSSM_Hgg : NMSSM_flags =
struct
let ckm_present = false
let higgs_triangle = true
end
module NMSSM_func (Flags : NMSSM_flags) =
struct
open Coupling
let default_width = ref Timelike
let use_fudged_width = ref false
let options = Options.create
[ "constant_width", Arg.Unit (fun () -> default_width := Constant),
"use constant width (also in t-channel)";
"fudged_width", Arg.Set use_fudged_width,
"use fudge factor for charge particle width";
"custom_width", Arg.String (fun f -> default_width := Custom f),
"use custom width";
"cancel_widths", Arg.Unit (fun () -> default_width := Vanishing),
"use vanishing width";
"running_width", Arg.Unit (fun () -> default_width := Running),
"use running width"]
let caveats () = []
(* Yields a list of tuples consistig of the off-diag combinations of the elements in "set". *)
let choose2 set =
List.map (function [x;y] -> (x,y) | _ -> failwith "choose2")
(Combinatorics.choose 2 set)
(* [pairs] appends the diagonal combinations to [choose2]. *)
let rec diag = function
| [] -> []
| x1 :: rest -> (x1, x1) :: diag rest
let pairs l = choose2 l @ diag l
let rec cloop set i j k =
if i > ((List.length set)-1) then []
else if j > i then cloop set (succ i) (j-i-1) (j-i-1)
else if k > j then cloop set i (succ j) (k-j-1)
else (List.nth set i, List.nth set j, List.nth set k) :: cloop set i j (succ k)
let triples set = cloop set 0 0 0
let rec two_and_one' l1 z n =
if n < 0 then []
else
((fst (List.nth (pairs l1) n)),(snd (List.nth (pairs l1) n)), z):: two_and_one' l1 z (pred n)
let two_and_one l1 l2 =
let f z = two_and_one' l1 z ((List.length (pairs l1))-1)
in
List.flatten ( List.map f l2 )
type gen =
| G of int | GG of gen*gen
let rec string_of_gen = function
| G n when n > 0 -> string_of_int n
| G n -> string_of_int (abs n) ^ "c"
| GG (g1,g2) -> string_of_gen g1 ^ "_" ^ string_of_gen g2
(* With this we distinguish the flavour. *)
type sff =
| SL | SN | SU | SD
let string_of_sff = function
| SL -> "sl" | SN -> "sn" | SU -> "su" | SD -> "sd"
(* With this we distinguish the mass eigenstates. At the moment we have to cheat
a little bit for the sneutrinos. Because we are dealing with massless
neutrinos there is only one sort of sneutrino. *)
type sfm =
| M1 | M2
- let string_of_sfm = function
+ let string_of_sfm = function
| M1 -> "1" | M2 -> "2"
(* We also introduce special types for the charginos and neutralinos. *)
type char =
| C1 | C2 | C1c | C2c
type neu =
| N1 | N2 | N3 | N4 | N5
let int_of_char = function
| C1 -> 1 | C2 -> 2 | C1c -> -1 | C2c -> -2
let string_of_char = function
| C1 -> "1" | C2 -> "2" | C1c -> "-1" | C2c -> "-2"
let conj_char = function
| C1 -> C1c | C2 -> C2c | C1c -> C1 | C2c -> C2
let string_of_neu = function
| N1 -> "1" | N2 -> "2" | N3 -> "3" | N4 -> "4" | N5 -> "5"
(* For the Higgs bosons, we follow the conventions of Franke/Fraas. *)
type shiggs =
| S1 | S2 | S3
type phiggs =
| P1 | P2
let string_of_shiggs = function
| S1 -> "1" | S2 -> "2" | S3 -> "3"
let string_of_phiggs = function
| P1 -> "1" | P2 -> "2"
type flavor =
| L of int | N of int
| U of int | D of int
| Sup of sfm*int | Sdown of sfm*int
| Ga | Wp | Wm | Z | Gl
| Slepton of sfm*int | Sneutrino of int
| Neutralino of neu | Chargino of char
| Gluino
| SHiggs of shiggs | Hp | Hm | PHiggs of phiggs
let string_of_fermion_type = function
| L _ -> "l" | U _ -> "u" | D _ -> "d" | N _ -> "n"
| _ -> failwith "Modellib_NMSSM.NMSSM.string_of_fermion_type: invalid fermion type"
let string_of_fermion_gen = function
| L g | U g | D g | N g -> string_of_int (abs (g))
| _ -> failwith "Modellib_NMSSM.NMSSM.string_of_fermion_gen: invalid fermion type"
type gauge = unit
let gauge_symbol () =
failwith "Modellib_NMSSM.NMSSM.gauge_symbol: internal error"
(* At this point we will forget graviton and -ino. *)
let family g = [ L g; N g; Slepton (M1,g);
Slepton (M2,g); Sneutrino g;
U g; D g; Sup (M1,g); Sup (M2,g);
Sdown (M1,g); Sdown (M2,g)]
let external_flavors () =
[ "1st Generation matter", ThoList.flatmap family [1; -1];
"2nd Generation matter", ThoList.flatmap family [2; -2];
"3rd Generation matter", ThoList.flatmap family [3; -3];
"Gauge Bosons", [Ga; Z; Wp; Wm; Gl];
"Charginos", [Chargino C1; Chargino C2; Chargino C1c; Chargino C2c];
"Neutralinos", [Neutralino N1; Neutralino N2; Neutralino N3;
Neutralino N4; Neutralino N5];
"Higgs Bosons", [SHiggs S1; SHiggs S2; SHiggs S3; Hp; Hm; PHiggs P1; PHiggs P2];
"Gluino", [Gluino]]
let flavors () = ThoList.flatmap snd (external_flavors ())
let spinor n m =
if n >= 0 && m >= 0 then
Spinor
else if
n <= 0 && m <=0 then
ConjSpinor
else
invalid_arg "Modellib_NMSSM.NMSSM.spinor: internal error"
let lorentz = function
| L g -> spinor g 0 | N g -> spinor g 0
| U g -> spinor g 0 | D g -> spinor g 0
| Chargino c -> spinor (int_of_char c) 0
| Ga | Gl -> Vector
| Wp | Wm | Z -> Massive_Vector
| SHiggs _ | PHiggs _ | Hp | Hm
| Sup _ | Sdown _ | Slepton _ | Sneutrino _ -> Scalar
| Neutralino _ | Gluino -> Majorana
let color = function
| U g -> Color.SUN (if g > 0 then 3 else -3)
| Sup (m,g) -> Color.SUN (if g > 0 then 3 else -3)
| D g -> Color.SUN (if g > 0 then 3 else -3)
| Sdown (m,g) -> Color.SUN (if g > 0 then 3 else -3)
| Gl | Gluino -> Color.AdjSUN 3
| _ -> Color.Singlet
let nc () = 3
let prop_spinor n m =
if n >= 0 && m >=0 then
Prop_Spinor
else if
n <=0 && m <=0 then
Prop_ConjSpinor
else
invalid_arg "Modellib_NMSSM.NMSSM.prop_spinor: internal error"
let propagator = function
| L g -> prop_spinor g 0 | N g -> prop_spinor g 0
| U g -> prop_spinor g 0 | D g -> prop_spinor g 0
| Chargino c -> prop_spinor (int_of_char c) 0
| Ga | Gl -> Prop_Feynman
| Wp | Wm | Z -> Prop_Unitarity
| SHiggs _ | PHiggs _ -> Prop_Scalar
| Hp | Hm -> Prop_Scalar
| Sup _ | Sdown _ | Slepton _ | Sneutrino _ -> Prop_Scalar
| Gluino -> Prop_Majorana
| Neutralino _ -> Prop_Majorana
(* Optionally, ask for the fudge factor treatment for the widths of
charged particles. Currently, this only applies to $W^\pm$ and top. *)
let width f =
if !use_fudged_width then
match f with
| Wp | Wm | U 3 | U (-3) -> Fudged
| _ -> !default_width
else
!default_width
let goldstone _ = None
let conjugate = function
| L g -> L (-g) | N g -> N (-g)
| U g -> U (-g) | D g -> D (-g)
| Sup (m,g) -> Sup (m,-g)
| Sdown (m,g) -> Sdown (m,-g)
| Slepton (m,g) -> Slepton (m,-g)
| Sneutrino g -> Sneutrino (-g)
| Gl -> Gl | Ga -> Ga | Z -> Z
| Wp -> Wm | Wm -> Wp
| SHiggs s -> SHiggs s
| PHiggs p -> PHiggs p
| Hp -> Hm | Hm -> Hp
| Gluino -> Gluino
| Neutralino n -> Neutralino n | Chargino c -> Chargino (conj_char c)
let fermion = function
| L g -> if g > 0 then 1 else -1
| N g -> if g > 0 then 1 else -1
| U g -> if g > 0 then 1 else -1
| D g -> if g > 0 then 1 else -1
| Gl | Ga | Z | Wp | Wm -> 0
| SHiggs _ | Hp | Hm | PHiggs _ -> 0
| Neutralino _ -> 2
| Chargino c -> if (int_of_char c) > 0 then 1 else -1
| Sup _ -> 0 | Sdown _ -> 0
| Slepton _ -> 0 | Sneutrino _ -> 0
| Gluino -> 2
module Ch = Charges.QQ
let ( // ) = Algebra.Small_Rational.make
let generation' = function
| 1 -> [ 1//1; 0//1; 0//1]
| 2 -> [ 0//1; 1//1; 0//1]
| 3 -> [ 0//1; 0//1; 1//1]
| -1 -> [-1//1; 0//1; 0//1]
| -2 -> [ 0//1; -1//1; 0//1]
| -3 -> [ 0//1; 0//1; -1//1]
| n -> invalid_arg ("NMSSM.generation': " ^ string_of_int n)
let generation f =
if Flags.ckm_present then
[]
else
match f with
| L n | N n | U n | D n | Sup (_,n)
| Sdown (_,n) | Slepton (_,n)
| Sneutrino n -> generation' n
| _ -> [0//1; 0//1; 0//1]
let charge = function
| L n -> if n > 0 then -1//1 else 1//1
| Slepton (_,n) -> if n > 0 then -1//1 else 1//1
| N n -> 0//1
| Sneutrino n -> 0//1
| U n -> if n > 0 then 2//3 else -2//3
| Sup (_,n) -> if n > 0 then 2//3 else -2//3
| D n -> if n > 0 then -1//3 else 1//3
| Sdown (_,n) -> if n > 0 then -1//3 else 1//3
| Gl | Ga | Z | Neutralino _ | Gluino -> 0//1
| Wp -> 1//1
| Wm -> -1//1
| SHiggs _ | PHiggs _ -> 0//1
| Hp -> 1//1
| Hm -> -1//1
| Chargino (C1 | C2) -> 1//1
| Chargino (C1c | C2c) -> -1//1
let lepton = function
| L n | N n -> if n > 0 then 1//1 else -1//1
| Slepton (_,n)
| Sneutrino n -> if n > 0 then 1//1 else -1//1
| _ -> 0//1
let baryon = function
| U n | D n -> if n > 0 then 1//1 else -1//1
| Sup (_,n) | Sdown (_,n) -> if n > 0 then 1//1 else -1//1
| _ -> 0//1
let charges f =
[ charge f; lepton f; baryon f] @ generation f
(* We introduce a Boolean type vc as a pseudonym for Vertex Conjugator to
distinguish between vertices containing complex mixing matrices like the
CKM--matrix or the sfermion or neutralino/chargino--mixing matrices, which
have to become complex conjugated. The true--option stands for the conjugated
vertex, the false--option for the unconjugated vertex. *)
type vc = bool
type constant =
| E | G
| Mu (*lambda*<s>*) | Lambda
| Q_lepton | Q_up | Q_down | Q_charg
| G_Z | G_CC | G_CCQ of vc*int*int
| G_NC_neutrino | G_NC_lepton | G_NC_up | G_NC_down
| I_Q_W | I_G_ZWW | G_WWWW | G_ZZWW | G_PZWW | G_PPWW
| G_SS | I_G_S | Gs
| G_NZN of neu*neu | G_CZC of char*char
| G_YUK_FFS of flavor*flavor*shiggs
| G_YUK_FFP of flavor*flavor*phiggs
| G_YUK_LCN of int
| G_YUK_UCD of int*int | G_YUK_DCU of int*int
| G_NHC of vc*neu*char
| G_YUK_C of vc*flavor*char*sff*sfm
| G_YUK_Q of vc*int*flavor*char*sff*sfm
| G_YUK_N of vc*flavor*neu*sff*sfm
| G_YUK_G of vc*flavor*sff*sfm
| G_NWC of neu*char | G_CWN of char*neu
| G_CSC of char*char*shiggs
| G_CPC of char*char*phiggs
| G_WSQ of vc*int*int*sfm*sfm
| G_SLSNW of vc*int*sfm
| G_ZSF of sff*int*sfm*sfm
| G_CICIS of neu*neu*shiggs
| G_CICIP of neu*neu*phiggs
| G_GH_WPC of phiggs | G_GH_WSC of shiggs
| G_GH_ZSP of shiggs*phiggs | G_GH_WWS of shiggs
| G_GH_ZZS of shiggs | G_GH_ZCC
| G_GH_GaCC
| G_GH4_ZZPP of phiggs*phiggs
| G_GH4_ZZSS of shiggs*shiggs
| G_GH4_ZZCC | G_GH4_GaGaCC
| G_GH4_ZGaCC | G_GH4_WWCC
| G_GH4_WWPP of phiggs*phiggs
| G_GH4_WWSS of shiggs*shiggs
| G_GH4_ZWSC of shiggs
| G_GH4_GaWSC of shiggs
| G_GH4_ZWPC of phiggs
| G_GH4_GaWPC of phiggs
| G_WWSFSF of sff*int*sfm*sfm
| G_WPSLSN of vc*int*sfm
| G_H3_SCC of shiggs
| G_H3_SSS of shiggs*shiggs*shiggs
| G_H3_SPP of shiggs*phiggs*phiggs
| G_SFSFS of shiggs*sff*int*sfm*sfm
| G_SFSFP of phiggs*sff*int*sfm*sfm
| G_HSNSL of vc*int*sfm
| G_HSUSD of vc*sfm*sfm*int*int
| G_WPSUSD of vc*sfm*sfm*int*int
| G_WZSUSD of vc*sfm*sfm*int*int
| G_WZSLSN of vc*int*sfm | G_GlGlSQSQ
| G_PPSFSF of sff
| G_ZZSFSF of sff*int*sfm*sfm | G_ZPSFSF of sff*int*sfm*sfm
| G_GlZSFSF of sff*int*sfm*sfm | G_GlPSQSQ
| G_GlWSUSD of vc*sfm*sfm*int*int
| G_GLUGLUA0 of phiggs | G_GLUGLUH0 of shiggs
(* Two integer counters for the QCD and EW order of the couplings. *)
- type orders = int * int
+ type coupling_order = QCD | EW
+ let all_coupling_orders () = [QCD; EW]
+ let coupling_order_to_string = function
+ | QCD -> "QCD"
+ | EW -> "EW"
- let orders = function
- | _ -> (0,0)
+ let coupling_orders = function
+ | _ -> failwith "Modellib_NMSSM.NMSSM_func.orders: not implemented yet!"
(* \begin{subequations}
\begin{align}
\alpha_{\text{QED}} &= \frac{1}{137.0359895} \\
\sin^2\theta_w &= 0.23124
\end{align}
\end{subequations}
Here we must perhaps allow for complex input parameters. So split them
into their modulus and their phase. At first, we leave them real; the
generalization to complex parameters is obvious. *)
let parameters () =
{ input = [];
derived = [];
derived_arrays = [] }
module F = Modeltools.Fusions (struct
type f = flavor
type c = constant
let compare = compare
let conjugate = conjugate
end)
(* For the couplings there are generally two possibilities concerning the
sign of the covariant derivative.
\begin{equation}
{\rm CD}^\pm = \partial_\mu \pm \ii g T^a A^a_\mu
\end{equation}
The particle data group defines the signs consistently to be positive.
Since the convention for that signs also influence the phase definitions
of the gaugino/higgsino fields via the off-diagonal entries in their
mass matrices it would be the best to adopt that convention. *)
(*** REVISED: Compatible with CD+. FB ***)
let electromagnetic_currents_3 g =
[ ((L (-g), Ga, L g), FBF (1, Psibar, V, Psi), Q_lepton);
((U (-g), Ga, U g), FBF (1, Psibar, V, Psi), Q_up);
((D (-g), Ga, D g), FBF (1, Psibar, V, Psi), Q_down)]
(*** REVISED: Compatible with CD+. FB***)
let electromagnetic_sfermion_currents g m =
[ ((Ga, Slepton (m,-g), Slepton (m,g)), Vector_Scalar_Scalar 1, Q_lepton);
((Ga, Sup (m,-g), Sup (m,g)), Vector_Scalar_Scalar 1, Q_up);
((Ga, Sdown (m,-g), Sdown (m,g)), Vector_Scalar_Scalar 1, Q_down)]
(*** REVISED: Compatible with CD+. FB***)
let electromagnetic_currents_2 c =
let cc = conj_char c in
[ ((Chargino cc, Ga, Chargino c), FBF (1, Psibar, V, Psi), Q_charg) ]
(*** REVISED: Compatible with CD+. FB***)
let neutral_currents g =
[ ((L (-g), Z, L g), FBF (1, Psibar, VA, Psi), G_NC_lepton);
((N (-g), Z, N g), FBF (1, Psibar, VA, Psi), G_NC_neutrino);
((U (-g), Z, U g), FBF (1, Psibar, VA, Psi), G_NC_up);
((D (-g), Z, D g), FBF (1, Psibar, VA, Psi), G_NC_down)]
(* \begin{equation}
\mathcal{L}_{\textrm{CC}} =
\mp \frac{g}{2\sqrt2} \sum_i \bar\psi_i \gamma^\mu
(1-\gamma_5)(T^+W^+_\mu+T^-W^-_\mu)\psi_i ,
\end{equation}
where the sign corresponds to $\text{CD}_\pm$, respectively. *)
(*** REVISED: Compatible with CD+. ***)
(* Remark: The definition with the other sign compared to the SM files
comes from the fact that $g_{cc} = 1/(2\sqrt{2})$ is used
overwhelmingly often in the SUSY Feynman rules, so that JR
decided to use a different definiton for [g_cc] in SM and MSSM. *)
(** FB **)
let charged_currents g =
[ ((L (-g), Wm, N g), FBF ((-1), Psibar, VL, Psi), G_CC);
((N (-g), Wp, L g), FBF ((-1), Psibar, VL, Psi), G_CC) ]
(* The quark with the inverted generation (the antiparticle) is the outgoing
one, the other the incoming. The vertex attached to the outgoing up-quark
contains the CKM matrix element {\em not} complex conjugated, while the
vertex with the outgoing down-quark has the conjugated CKM matrix
element. *)
(*** REVISED: Compatible with CD+. FB ***)
let charged_quark_currents g h =
[ ((D (-g), Wm, U h), FBF ((-1), Psibar, VL, Psi), G_CCQ (true,g,h));
((U (-g), Wp, D h), FBF ((-1), Psibar, VL, Psi), G_CCQ (false,h,g))]
(*** REVISED: Compatible with CD+.FB ***)
let charged_chargino_currents n c =
let cc = conj_char c in
[ ((Chargino cc, Wp, Neutralino n),
FBF (1, Psibar, VLR, Chi), G_CWN (c,n));
((Neutralino n, Wm, Chargino c),
FBF (1, Chibar, VLR, Psi), G_NWC (n,c)) ]
(*** REVISED: Compatible with CD+. FB***)
let charged_slepton_currents g m =
[ ((Wm, Slepton (m,-g), Sneutrino g), Vector_Scalar_Scalar (-1), G_SLSNW
(true,g,m));
((Wp, Slepton (m,g), Sneutrino (-g)), Vector_Scalar_Scalar 1, G_SLSNW
(false,g,m)) ]
(*** REVISED: Compatible with CD+. FB***)
let charged_squark_currents' g h m1 m2 =
[ ((Wm, Sup (m1,g), Sdown (m2,-h)), Vector_Scalar_Scalar (-1), G_WSQ
(true,g,h,m1,m2));
((Wp, Sup (m1,-g), Sdown (m2,h)), Vector_Scalar_Scalar 1, G_WSQ
(false,g,h,m1,m2)) ]
let charged_squark_currents g h =
List.flatten (Product.list2 (charged_squark_currents' g h) [M1;M2] [M1;M2] )
(*** REVISED: Compatible with CD+. FB ***)
let neutral_sfermion_currents' g m1 m2 =
[ ((Z, Slepton (m1,-g), Slepton (m2,g)), Vector_Scalar_Scalar (-1),
G_ZSF (SL,g,m1,m2));
((Z, Sup (m1,-g), Sup (m2,g)), Vector_Scalar_Scalar (-1),
G_ZSF(SU,g,m1,m2));
((Z, Sdown (m1,-g), Sdown (m2,g)), Vector_Scalar_Scalar (-1),
G_ZSF (SD,g,m1,m2))]
let neutral_sfermion_currents g =
List.flatten (Product.list2 (neutral_sfermion_currents'
g) [M1;M2] [M1;M2]) @
[ ((Z, Sneutrino (-g), Sneutrino g), Vector_Scalar_Scalar (-1),
G_ZSF (SN,g,M1,M1)) ]
(*** REVISED: Compatible with CD+. FB***)
let neutral_Z (n,m) =
[ ((Neutralino n, Z, Neutralino m), FBF (1, Chibar, VLR, Chi),
(G_NZN (n,m))) ]
(*** REVISED: Compatible with CD+. FB***)
let charged_Z c1 c2 =
let cc1 = conj_char c1 in
((Chargino cc1, Z, Chargino c2), FBF ((-1), Psibar, VA , Psi),
G_CZC (c1,c2))
(*** REVISED: Compatible with CD+.
Remark: This is pure octet. FB***)
let yukawa_v =
[ (Gluino, Gl, Gluino), FBF (1, Chibar, V, Chi), Gs]
(*** REVISED: Independent of the sign of CD. ***)
(*** REVISED: Felix Braam: Compact version using new COMBOS + FF-Couplings *)
let yukawa_higgs_FFS f s =
[((conjugate f, SHiggs s, f ), FBF (1, Psibar, S, Psi),
G_YUK_FFS (conjugate f, f, s))]
let yukawa_higgs_FFP f p =
[((conjugate f, PHiggs p, f), FBF (1, Psibar, P, Psi),
G_YUK_FFP (conjugate f ,f , p))]
let yukawa_higgs_NLC g =
[ ((N (-g), Hp, L g), FBF (1, Psibar, Coupling.SR, Psi), G_YUK_LCN g);
((L (-g), Hm, N g), FBF (1, Psibar, Coupling.SL, Psi), G_YUK_LCN g)]
let yukawa_higgs g =
yukawa_higgs_NLC g @
List.flatten ( Product.list2 yukawa_higgs_FFS [L g; U g; D g] [S1; S2; S3]) @
List.flatten ( Product.list2 yukawa_higgs_FFP [L g; U g; D g] [P1; P2])
(*** REVISED: Independent of the sign of CD. FB***)
let yukawa_higgs_quark (g,h) =
[ ((U (-g), Hp, D h), FBF (1, Psibar, SLR, Psi), G_YUK_UCD (g, h));
((D (-h), Hm, U g), FBF (1, Psibar, SLR, Psi), G_YUK_DCU (g, h)) ]
(*** REVISED: Compatible with CD+. ***)
(*** REVISED: Felix Braam: Compact version using new COMBOS*)
let yukawa_shiggs_2 c1 c2 s =
let cc1 = conj_char c1 in
((Chargino cc1, SHiggs s, Chargino c2), FBF (1, Psibar, SLR, Psi),
G_CSC (c1,c2,s))
let yukawa_phiggs_2 c1 c2 p =
let cc1 = conj_char c1 in
((Chargino cc1, PHiggs p, Chargino c2), FBF (1, Psibar, SLR, Psi),
G_CPC (c1,c2,p))
let yukawa_higgs_2 =
Product.list3 yukawa_shiggs_2 [C1;C2] [C1;C2] [S1;S2;S3] @
Product.list3 yukawa_phiggs_2 [C1;C2] [C1;C2] [P1;P2]
(*** REVISED: Compatible with CD+.FB ***)
let higgs_charg_neutr n c =
let cc = conj_char c in
[ ((Neutralino n, Hm, Chargino c), FBF (-1, Chibar, SLR, Psi),
G_NHC (false,n,c));
((Chargino cc, Hp, Neutralino n), FBF (-1, Psibar, SLR, Chi),
G_NHC (true,n,c)) ]
(*** REVISED: Compatible with CD+. ***)
(*** REVISED: Felix Braam: Compact version using new COMBOS*)
let shiggs_neutr (n,m,s) =
((Neutralino n, SHiggs s, Neutralino m), FBF (1, Chibar, SLR, Chi),
G_CICIS (n,m,s))
let phiggs_neutr (n,m,p) =
((Neutralino n, PHiggs p, Neutralino m), FBF (1, Chibar, SLR, Chi),
G_CICIP (n,m,p))
let higgs_neutr =
List.map shiggs_neutr (two_and_one [N1;N2;N3;N4;N5] [S1;S2;S3]) @
List.map phiggs_neutr (two_and_one [N1;N2;N3;N4;N5] [P1;P2])
(*** REVISED: Compatible with CD+. FB***)
let yukawa_n_2 n m g =
[ ((Neutralino n, Slepton (m,-g), L g), FBF (1, Chibar, SLR, Psi),
G_YUK_N (true,L g,n,SL,m));
((L (-g), Slepton (m,g), Neutralino n), FBF (1, Psibar, SLR, Chi),
G_YUK_N (false,L g,n,SL,m));
((Neutralino n, Sup (m,-g), U g), FBF (1, Chibar, SLR, Psi),
G_YUK_N (true,U g,n,SU,m));
((U (-g), Sup (m,g), Neutralino n), FBF (1, Psibar, SLR, Chi),
G_YUK_N (false,U g,n,SU,m));
((Neutralino n, Sdown (m,-g), D g), FBF (1, Chibar, SLR, Psi),
G_YUK_N (true,D g,n,SD,m));
((D (-g), Sdown (m,g), Neutralino n), FBF (1, Psibar, SLR, Chi),
G_YUK_N (false,D g,n,SD,m)) ]
let yukawa_n_3 n g =
[ ((Neutralino n, Sneutrino (-g), N g), FBF (1, Chibar, SLR, Psi),
G_YUK_N (true,N g,n,SN,M1));
((N (-g), Sneutrino g, Neutralino n), FBF (1, Psibar, SLR, Chi),
G_YUK_N (false,N g, n,SN,M1)) ]
let yukawa_n_5 g m =
[ ((U (-g), Sup (m,g), Gluino), FBF (1, Psibar, SLR, Chi),
G_YUK_G (false,U g,SU,m));
((D (-g), Sdown (m,g), Gluino), FBF (1, Psibar, SLR, Chi),
G_YUK_G (false,D g,SD,m));
((Gluino, Sup (m,-g), U g), FBF (1, Chibar, SLR, Psi),
G_YUK_G (true,U g,SU,m));
((Gluino, Sdown (m,-g), D g), FBF (1, Chibar, SLR, Psi),
G_YUK_G (true,D g,SD,m))]
let yukawa_n =
List.flatten (Product.list3 yukawa_n_2 [N1;N2;N3;N4;N5] [M1;M2] [1;2;3]) @
List.flatten (Product.list2 yukawa_n_3 [N1;N2;N3;N4;N5] [1;2;3]) @
List.flatten (Product.list2 yukawa_n_5 [1;2;3] [M1;M2])
(*** REVISED: Compatible with CD+.FB ***)
let yukawa_c_2 c g =
let cc = conj_char c in
[ ((L (-g), Sneutrino g, Chargino cc), BBB (1, Psibar, SLR,
Psibar), G_YUK_C (true,L g,c,SN,M1));
((Chargino c, Sneutrino (-g), L g), PBP (1, Psi, SLR, Psi),
G_YUK_C (false,L g,c,SN,M1)) ]
let yukawa_c_3 c m g =
let cc = conj_char c in
[ ((N (-g), Slepton (m,g), Chargino c), FBF (1, Psibar, SLR,
Psi), G_YUK_C (true,N g,c,SL,m));
((Chargino cc, Slepton (m,-g), N g), FBF (1, Psibar, SLR,
Psi), G_YUK_C (false,N g,c,SL,m)) ]
let yukawa_c c =
ThoList.flatmap (yukawa_c_2 c) [1;2;3] @
List.flatten (Product.list2 (yukawa_c_3 c) [M1;M2] [1;2;3])
(*** REVISED: Compatible with CD+. FB***)
let yukawa_cq' c (g,h) m =
let cc = conj_char c in
[ ((Chargino c, Sup (m,-g), D h), PBP (1, Psi, SLR, Psi),
G_YUK_Q (false,g,D h,c,SU,m));
((D (-h), Sup (m,g), Chargino cc), BBB (1, Psibar, SLR, Psibar),
G_YUK_Q (true,g,D h,c,SU,m));
((Chargino cc, Sdown (m,-g), U h), FBF (1, Psibar, SLR, Psi),
G_YUK_Q (true,g,U h,c,SD,m));
((U (-h), Sdown (m,g), Chargino c), FBF (1, Psibar, SLR, Psi),
G_YUK_Q (false,g,U h,c,SD,m)) ]
let yukawa_cq c =
if Flags.ckm_present then
List.flatten (Product.list2 (yukawa_cq' c) [(1,1);(1,2);(2,1);(2,2);(1,3);(2,3);(3,3);(3,2);(3,1)] [M1;M2])
else
List.flatten (Product.list2 (yukawa_cq' c) [(1,1);(2,2);(3,3)] [M1;M2])
(*** REVISED: Compatible with CD+.
Remark: Singlet and octet gluon exchange. The coupling is divided by
sqrt(2) to account for the correct normalization of the Lie algebra
generators.
**FB*)
let col_currents g =
[ ((D (-g), Gl, D g), FBF ((-1), Psibar, V, Psi), Gs);
((U (-g), Gl, U g), FBF ((-1), Psibar, V, Psi), Gs)]
(*** REVISED: Compatible with CD+.
Remark: Singlet and octet gluon exchange. The coupling is divided by
sqrt(2) to account for the correct normalization of the Lie algebra
generators.
**FB*)
let chg = function
| M1 -> M2 | M2 -> M1
let col_sfermion_currents g m =
[ ((Gl, Sup (m,-g), Sup (m,g)), Vector_Scalar_Scalar (-1), Gs);
((Gl, Sdown (m,-g), Sdown (m,g)), Vector_Scalar_Scalar (-1), Gs)]
(*** REVISED: Compatible with CD+. **FB*)
let triple_gauge =
[ ((Ga, Wm, Wp), Gauge_Gauge_Gauge 1, I_Q_W);
((Z, Wm, Wp), Gauge_Gauge_Gauge 1, I_G_ZWW);
((Gl, Gl, Gl), Gauge_Gauge_Gauge 1, I_G_S)]
(*** REVISED: Independent of the sign of CD. **FB*)
let gauge4 = Vector4 [(2, C_13_42); (-1, C_12_34); (-1, C_14_23)]
let minus_gauge4 = Vector4 [(-2, C_13_42); (1, C_12_34); (1, C_14_23)]
let quartic_gauge =
[ (Wm, Wp, Wm, Wp), gauge4, G_WWWW;
(Wm, Z, Wp, Z), minus_gauge4, G_ZZWW;
(Wm, Z, Wp, Ga), minus_gauge4, G_PZWW;
(Wm, Ga, Wp, Ga), minus_gauge4, G_PPWW;
(Gl, Gl, Gl, Gl), gauge4, G_SS]
(* The [Scalar_Vector_Vector] couplings do not depend on the choice of the
sign of the covariant derivative since they are quadratic in the
gauge couplings. *)
(** Effective Higgs-Gluon-Gluon coupling. **)
let gauge_higgs_GlGlS s=
((SHiggs s, Gl, Gl), Dim5_Scalar_Gauge2 1, G_GLUGLUH0 s)
let gauge_higgs_GlGlP p=
((PHiggs p, Gl, Gl), Dim5_Scalar_Gauge2_Skew 1, G_GLUGLUA0 p)
(*** REVISED: Compatible with CD+. FB***)
(*** Revision: 2005-03-10: first two vertices corrected. ***)
(*** REVISED: Compact version using new COMBOS*)
(*** REVISED: Couplings adjusted to FF-convention*)
let gauge_higgs_WPC p=
[ ((Wm, Hp, PHiggs p), Vector_Scalar_Scalar 1, G_GH_WPC p);
((Wp, Hm, PHiggs p), Vector_Scalar_Scalar 1, G_GH_WPC p)]
let gauge_higgs_WSC s=
[((Wm, Hp, SHiggs s),Vector_Scalar_Scalar 1, G_GH_WSC s);
((Wp, Hm, SHiggs s),Vector_Scalar_Scalar (-1), G_GH_WSC s)]
let gauge_higgs_ZSP s p =
[((Z, SHiggs s, PHiggs p),Vector_Scalar_Scalar 1, G_GH_ZSP (s,p))]
let gauge_higgs_WWS s=
((SHiggs s, Wp, Wm),Scalar_Vector_Vector 1, G_GH_WWS s)
let gauge_higgs_ZZS s=
((SHiggs s, Z, Z), Scalar_Vector_Vector 1, G_GH_ZZS s)
let gauge_higgs_ZCC =
((Z, Hp, Hm),Vector_Scalar_Scalar 1, G_GH_ZCC )
let gauge_higgs_GaCC =
((Ga, Hp, Hm),Vector_Scalar_Scalar 1, G_GH_GaCC )
let gauge_higgs =
ThoList.flatmap gauge_higgs_WPC [P1;P2] @
ThoList.flatmap gauge_higgs_WSC [S1;S2;S3] @
List.flatten (Product.list2 gauge_higgs_ZSP [S1;S2;S3] [P1;P2]) @
List.map gauge_higgs_WWS [S1;S2;S3] @
List.map gauge_higgs_ZZS [S1;S2;S3] @
[gauge_higgs_ZCC] @ [gauge_higgs_GaCC] @
(if Flags.higgs_triangle then
List.map gauge_higgs_GlGlS [S1;S2;S3] @
List.map gauge_higgs_GlGlP [P1;P2]
else
[])
(*** REVISED: Compact version using new COMBOS*)
(*** REVISED: Couplings adjusted to FF-convention*)
let gauge_higgs4_ZZPP (p1,p2) =
((PHiggs p1, PHiggs p2, Z, Z), Scalar2_Vector2 1, G_GH4_ZZPP (p1,p2))
let gauge_higgs4_ZZSS (s1,s2) =
((SHiggs s1, SHiggs s2 , Z, Z), Scalar2_Vector2 1, G_GH4_ZZSS (s1,s2))
let gauge_higgs4_ZZCC =
((Hp, Hm, Z, Z), Scalar2_Vector2 1, G_GH4_ZZCC)
let gauge_higgs4_GaGaCC =
((Hp, Hm, Ga, Ga), Scalar2_Vector2 1, G_GH4_GaGaCC)
let gauge_higgs4_ZGaCC =
((Hp, Hm, Ga, Z), Scalar2_Vector2 1, G_GH4_ZGaCC )
let gauge_higgs4_WWCC =
((Hp, Hm, Wp, Wm), Scalar2_Vector2 1, G_GH4_WWCC )
let gauge_higgs4_WWPP (p1,p2) =
((PHiggs p1, PHiggs p2, Wp, Wm), Scalar2_Vector2 1, G_GH4_WWPP (p1,p2))
let gauge_higgs4_WWSS (s1,s2) =
((SHiggs s1, SHiggs s2, Wp, Wm), Scalar2_Vector2 1, G_GH4_WWSS (s1,s2))
let gauge_higgs4_ZWSC s =
[ ((Hp, SHiggs s, Wm, Z), Scalar2_Vector2 1, G_GH4_ZWSC s);
((Hm, SHiggs s, Wp, Z), Scalar2_Vector2 1, G_GH4_ZWSC s)]
let gauge_higgs4_GaWSC s =
[ ((Hp, SHiggs s, Wm, Ga), Scalar2_Vector2 1, G_GH4_GaWSC s);
((Hm, SHiggs s, Wp, Ga), Scalar2_Vector2 1, G_GH4_GaWSC s) ]
let gauge_higgs4_ZWPC p =
[ ((Hp, PHiggs p, Wm, Z), Scalar2_Vector2 1, G_GH4_ZWPC p);
((Hm, PHiggs p, Wp, Z), Scalar2_Vector2 (-1), G_GH4_ZWPC p)]
let gauge_higgs4_GaWPC p =
[ ((Hp, PHiggs p, Wm, Ga), Scalar2_Vector2 1, G_GH4_GaWPC p);
((Hm, PHiggs p, Wp, Ga), Scalar2_Vector2 (-1), G_GH4_GaWPC p) ]
let gauge_higgs4 =
List.map gauge_higgs4_ZZPP (pairs [P1;P2]) @
List.map gauge_higgs4_ZZSS (pairs [S1;S2;S3]) @
[gauge_higgs4_ZZCC] @ [gauge_higgs4_GaGaCC] @
[gauge_higgs4_ZGaCC] @ [gauge_higgs4_WWCC] @
List.map gauge_higgs4_WWPP (pairs [P1;P2]) @
List.map gauge_higgs4_WWSS (pairs [S1;S2;S3]) @
ThoList.flatmap gauge_higgs4_ZWSC [S1;S2;S3] @
ThoList.flatmap gauge_higgs4_GaWSC [S1;S2;S3] @
ThoList.flatmap gauge_higgs4_ZWPC [P1;P2] @
ThoList.flatmap gauge_higgs4_GaWPC [P1;P2]
(**********************************************FB****)
let gauge_sfermion4' g m1 m2 =
[ ((Wp, Wm, Slepton (m1,g), Slepton (m2,-g)), Scalar2_Vector2 1,
G_WWSFSF (SL,g,m1,m2));
((Z, Ga, Slepton (m1,g), Slepton (m2,-g)), Scalar2_Vector2 1,
G_ZPSFSF (SL,g,m1,m2));
((Z, Z, Slepton (m1,g), Slepton (m2,-g)), Scalar2_Vector2 1,
G_ZZSFSF(SL,g,m1,m2));
((Wp, Wm, Sup (m1,g), Sup (m2,-g)), Scalar2_Vector2 1, G_WWSFSF
(SU,g,m1,m2));
((Wp, Wm, Sdown (m1,g), Sdown (m2,-g)), Scalar2_Vector2 1,
G_WWSFSF(SD,g,m1,m2));
((Z, Z, Sup (m1,g), Sup (m2,-g)), Scalar2_Vector2 1, G_ZZSFSF
(SU,g,m1,m2));
((Z, Z, Sdown (m1,g), Sdown (m2,-g)), Scalar2_Vector2 1, G_ZZSFSF
(SD,g,m1,m2));
((Z, Ga, Sup (m1,g), Sup (m2,-g)), Scalar2_Vector2 1, G_ZPSFSF
(SU,g,m1,m2));
((Z, Ga, Sdown (m1,g), Sdown (m2,-g)), Scalar2_Vector2 1, G_ZPSFSF
(SD,g,m1,m2)) ]
let gauge_sfermion4'' g m =
[ ((Wp, Ga, Slepton (m,g), Sneutrino (-g)), Scalar2_Vector2 1,
G_WPSLSN (false,g,m));
((Wm, Ga, Slepton (m,-g), Sneutrino g), Scalar2_Vector2 1,
G_WPSLSN (true,g,m));
((Wp, Z, Slepton (m,g), Sneutrino (-g)), Scalar2_Vector2 1,
G_WZSLSN(false,g,m));
((Wm, Z, Slepton (m,-g), Sneutrino g), Scalar2_Vector2 1,
G_WZSLSN (true,g,m));
((Ga, Ga, Slepton (m,g), Slepton (m,-g)), Scalar2_Vector2 1,
G_PPSFSF SL);
((Ga, Ga, Sup (m,g), Sup (m,-g)), Scalar2_Vector2 1, G_PPSFSF SU);
((Ga, Ga, Sdown (m,g), Sdown (m,-g)), Scalar2_Vector2 1, G_PPSFSF SD)]
let gauge_sfermion4 g =
List.flatten (Product.list2 (gauge_sfermion4' g) [M1;M2] [M1;M2]) @
ThoList.flatmap (gauge_sfermion4'' g) [M1;M2] @
[ ((Wp, Wm, Sneutrino g, Sneutrino (-g)), Scalar2_Vector2 1, G_WWSFSF
(SN,g,M1,M1));
((Z, Z, Sneutrino g, Sneutrino (-g)), Scalar2_Vector2 1, G_ZZSFSF
(SN,g,M1,M1)) ]
(*** Added by Felix Braam. ***)
let gauge_squark4'' g h m1 m2 =
[ ((Wp, Ga, Sup (m1,-g), Sdown (m2,h)), Scalar2_Vector2 1, G_WPSUSD
(false,m1,m2,g,h));
((Wm, Ga, Sup (m1,g), Sdown (m2,-h)), Scalar2_Vector2 1, G_WPSUSD
(true,m1,m2,g,h));
((Wp, Z, Sup (m1,-g), Sdown (m2,h)), Scalar2_Vector2 1, G_WZSUSD
(false,m1,m2,g,h));
((Wm, Z, Sup (m1,g), Sdown (m2,-h)), Scalar2_Vector2 1, G_WZSUSD
(true,m1,m2,g,h)) ]
let gauge_squark4' g h = List.flatten (Product.list2 (gauge_squark4'' g h)
[M1;M2] [M1;M2])
let gauge_squark4 =
if Flags.ckm_present then
List.flatten (Product.list2 gauge_squark4' [1;2;3] [1;2;3])
else
ThoList.flatmap (fun g -> gauge_squark4' g g) [1;2;3]
(**********************************FB*********************)
let gluon_w_squark'' g h m1 m2 =
[ ((Gl, Wp, Sup (m1,-g), Sdown (m2,h)),
Scalar2_Vector2 1, G_GlWSUSD (false,m1,m2,g,h));
((Gl, Wm, Sup (m1,g), Sdown (m2,-h)),
Scalar2_Vector2 1, G_GlWSUSD (true,m1,m2,g,h)) ]
let gluon_w_squark' g h =
List.flatten (Product.list2 (gluon_w_squark'' g h) [M1;M2] [M1;M2])
let gluon_w_squark =
if Flags.ckm_present then
List.flatten (Product.list2 gluon_w_squark' [1;2;3] [1;2;3])
else
ThoList.flatmap (fun g -> gluon_w_squark' g g) [1;2;3]
(***********************************FB********************)
let gluon_gauge_squark' g m1 m2 =
[ ((Gl, Z, Sup (m1,g), Sup (m2,-g)),
Scalar2_Vector2 2, G_GlZSFSF (SU,g,m1,m2));
((Gl, Z, Sdown (m1,g), Sdown (m2,-g)),
Scalar2_Vector2 2, G_GlZSFSF (SD,g,m1,m2)) ]
let gluon_gauge_squark'' g m =
[ ((Gl, Ga, Sup (m,g), Sup (m,-g)), Scalar2_Vector2 2, G_GlPSQSQ);
((Gl, Ga, Sdown (m,g), Sdown (m,-g)), Scalar2_Vector2 (-1), G_GlPSQSQ) ]
let gluon_gauge_squark g =
List.flatten (Product.list2 (gluon_gauge_squark' g) [M1;M2] [M1;M2]) @
ThoList.flatmap (gluon_gauge_squark'' g) [M1;M2]
(*************************************FB******************)
let gluon2_squark2' g m =
[ ((Gl, Gl, Sup (m,g), Sup (m,-g)), Scalar2_Vector2 2, G_GlGlSQSQ);
((Gl, Gl, Sdown (m,g), Sdown (m,-g)), Scalar2_Vector2 2, G_GlGlSQSQ) ]
let gluon2_squark2 g =
ThoList.flatmap (gluon2_squark2' g) [M1;M2]
(*** REVISED: Independent of the sign of CD. *FB**)
(*** REVISED: Compact version using new COMBOS*)
(*** REVISED: Couplings adjusted to FF-convention*)
let higgs_SCC s =
((Hp, Hm, SHiggs s), Scalar_Scalar_Scalar 1, G_H3_SCC s )
let higgs_SSS (s1,s2,s3)=
((SHiggs s1, SHiggs s2, SHiggs s3), Scalar_Scalar_Scalar 1,
G_H3_SSS (s1,s2,s3))
let higgs_SPP (p1,p2,s) =
((SHiggs s, PHiggs p1, PHiggs p2), Scalar_Scalar_Scalar 1,
G_H3_SPP (s,p1,p2))
let higgs =
List.map higgs_SCC [S1;S2;S3]@
List.map higgs_SSS (triples [S1;S2;S3])@
List.map higgs_SPP (two_and_one [P1;P2] [S1;S2;S3])
let higgs4 = []
(* The vertices of the type Higgs - Sfermion - Sfermion are independent of
the choice of the CD sign since they are quadratic in the gauge
coupling. *)
(*** REVISED: Independent of the sign of CD. ***)
let higgs_sneutrino' s g =
((SHiggs s, Sneutrino g, Sneutrino (-g)), Scalar_Scalar_Scalar 1,
G_SFSFS (s,SN,g,M1,M1))
let higgs_sneutrino'' g m =
[((Hp, Sneutrino (-g), Slepton (m,g)), Scalar_Scalar_Scalar 1,
G_HSNSL (false,g,m));
((Hm, Sneutrino g, Slepton (m,-g)), Scalar_Scalar_Scalar 1,
G_HSNSL (true,g,m))]
let higgs_sneutrino =
Product.list2 higgs_sneutrino' [S1;S2;S3] [1;2;3] @
List.flatten ( Product.list2 higgs_sneutrino'' [1;2;3] [M1;M2] )
(* Under the assumption that there is no mixing between the left- and
right-handed sfermions for the first two generations there is only a
coupling of the form Higgs - sfermion1 - sfermion2 for the third
generation. All the others are suppressed by $m_f/M_W$. *)
(*** REVISED: Independent of the sign of CD. ***)
let higgs_sfermion_S s g m1 m2 =
[ ((SHiggs s, Slepton (m1,g), Slepton (m2,-g)), Scalar_Scalar_Scalar 1,
G_SFSFS (s,SL,g,m1,m2));
((SHiggs s, Sup (m1,g), Sup (m2,-g)), Scalar_Scalar_Scalar 1,
G_SFSFS (s,SU,g,m1,m2));
((SHiggs s, Sdown (m1,g), Sdown (m2,-g)), Scalar_Scalar_Scalar 1,
G_SFSFS (s,SD,g,m1,m2))]
let higgs_sfermion' g m1 m2 =
(higgs_sfermion_S S1 g m1 m2) @ (higgs_sfermion_S S2 g m1 m2) @ (higgs_sfermion_S S3 g m1 m2)
let higgs_sfermion_P p g m1 m2 =
[ ((PHiggs p, Slepton (m1,g), Slepton (m2,-g)), Scalar_Scalar_Scalar 1,
G_SFSFP (p,SL,g,m1,m2));
((PHiggs p, Sup (m1,g), Sup (m2,-g)), Scalar_Scalar_Scalar 1,
G_SFSFP (p,SU,g,m1,m2));
((PHiggs p, Sdown (m1,g), Sdown (m2,-g)), Scalar_Scalar_Scalar 1,
G_SFSFP (p,SD,g,m1,m2)) ]
let higgs_sfermion'' g m1 m2 =
(higgs_sfermion_P P1 g m1 m2) @ (higgs_sfermion_P P2 g m1 m2)
let higgs_sfermion = List.flatten (Product.list3 higgs_sfermion' [1;2;3] [M1;M2] [M1;M2]) @
List.flatten (Product.list3 higgs_sfermion'' [1;2;3] [M1;M2] [M1;M2])
(*** REVISED: Independent of the sign of CD. ***)
let higgs_squark' g h m1 m2 =
[ ((Hp, Sup (m1,-g), Sdown (m2,h)), Scalar_Scalar_Scalar 1,
G_HSUSD (false,m1,m2,g,h));
((Hm, Sup (m1,g), Sdown (m2,-h)), Scalar_Scalar_Scalar 1,
G_HSUSD (true,m1,m2,g,h)) ]
let higgs_squark_a g h = higgs_squark' g h M1 M1
let higgs_squark_b (g,h) = List.flatten (Product.list2 (higgs_squark' g h)
[M1;M2] [M1;M2])
let higgs_squark =
if Flags.ckm_present then
List.flatten (Product.list2 higgs_squark_a [1;2] [1;2]) @
ThoList.flatmap higgs_squark_b [(1,3);(2,3);(3,3);(3,1);(3,2)]
else
higgs_squark_a 1 1 @ higgs_squark_a 2 2 @ higgs_squark_b (3,3)
let vertices3 =
(ThoList.flatmap electromagnetic_currents_3 [1;2;3] @
ThoList.flatmap electromagnetic_currents_2 [C1;C2] @
List.flatten (Product.list2 electromagnetic_sfermion_currents [1;2;3]
[M1;M2]) @
ThoList.flatmap neutral_currents [1;2;3] @
ThoList.flatmap neutral_sfermion_currents [1;2;3] @
ThoList.flatmap charged_currents [1;2;3] @
List.flatten (Product.list2 charged_slepton_currents [1;2;3]
[M1;M2]) @
(if Flags.ckm_present then
List.flatten (Product.list2 charged_quark_currents [1;2;3]
[1;2;3]) @
List.flatten (Product.list2 charged_squark_currents [1;2;3]
[1;2;3]) @
ThoList.flatmap yukawa_higgs_quark [(1,3);(2,3);(3,3);(3,1);(3,2)]
else
charged_quark_currents 1 1 @
charged_quark_currents 2 2 @
charged_quark_currents 3 3 @
charged_squark_currents 1 1 @
charged_squark_currents 2 2 @
charged_squark_currents 3 3 @
ThoList.flatmap yukawa_higgs_quark [(3,3)]) @
(*i ThoList.flatmap yukawa_higgs [1;2;3] @ i*)
yukawa_higgs 3 @ yukawa_n @
ThoList.flatmap yukawa_c [C1;C2] @
ThoList.flatmap yukawa_cq [C1;C2] @
List.flatten (Product.list2 charged_chargino_currents [N1;N2;N3;N4;N5]
[C1;C2]) @ triple_gauge @
ThoList.flatmap neutral_Z (pairs [N1;N2;N3;N4;N5]) @
Product.list2 charged_Z [C1;C2] [C1;C2] @
gauge_higgs @ higgs @ yukawa_higgs_2 @
(*i List.flatten (Product.list2 yukawa_higgs_quark [1;2;3] [1;2;3]) @ i*)
List.flatten (Product.list2 higgs_charg_neutr [N1;N2;N3;N4;N5] [C1;C2]) @
higgs_neutr @ higgs_sneutrino @ higgs_sfermion @
higgs_squark @ yukawa_v @
ThoList.flatmap col_currents [1;2;3] @
List.flatten (Product.list2 col_sfermion_currents [1;2;3] [M1;M2]))
let vertices4 =
(quartic_gauge @ higgs4 @ gauge_higgs4 @
ThoList.flatmap gauge_sfermion4 [1;2;3] @
gauge_squark4 @ gluon_w_squark @
ThoList.flatmap gluon2_squark2 [1;2;3] @
ThoList.flatmap gluon_gauge_squark [1;2;3])
let vertices () = (vertices3, vertices4, [])
let table = F.of_vertices (vertices ())
let fuse2 = F.fuse2 table
let fuse3 = F.fuse3 table
let fuse = F.fuse table
let max_degree () = 4
(* SLHA2-Nomenclature for neutral Higgses *)
let flavor_of_string s =
match s with
| "e-" -> L 1 | "e+" -> L (-1)
| "mu-" -> L 2 | "mu+" -> L (-2)
| "tau-" -> L 3 | "tau+" -> L (-3)
| "nue" -> N 1 | "nuebar" -> N (-1)
| "numu" -> N 2 | "numubar" -> N (-2)
| "nutau" -> N 3 | "nutaubar" -> N (-3)
| "se1-" -> Slepton (M1,1) | "se1+" -> Slepton (M1,-1)
| "smu1-" -> Slepton (M1,2) | "smu1+" -> Slepton (M1,-2)
| "stau1-" -> Slepton (M1,3) | "stau1+" -> Slepton (M1,-3)
| "se2-" -> Slepton (M2,1) | "se2+" -> Slepton (M2,-1)
| "smu2-" -> Slepton (M2,2) | "smu2+" -> Slepton (M2,-2)
| "stau2-" -> Slepton (M2,3) | "stau2+" -> Slepton (M2,-3)
| "snue" -> Sneutrino 1 | "snue*" -> Sneutrino (-1)
| "snumu" -> Sneutrino 2 | "snumu*" -> Sneutrino (-2)
| "snutau" -> Sneutrino 3 | "snutau*" -> Sneutrino (-3)
| "u" -> U 1 | "ubar" -> U (-1)
| "c" -> U 2 | "cbar" -> U (-2)
| "t" -> U 3 | "tbar" -> U (-3)
| "d" -> D 1 | "dbar" -> D (-1)
| "s" -> D 2 | "sbar" -> D (-2)
| "b" -> D 3 | "bbar" -> D (-3)
| "A" -> Ga | "Z" | "Z0" -> Z
| "W+" -> Wp | "W-" -> Wm
| "gl" | "g" -> Gl
| "h01" -> SHiggs S1 | "h02" -> SHiggs S2 | "h03" -> SHiggs S3
| "A01" -> PHiggs P1 | "A02" -> PHiggs P2
| "H+" -> Hp | "H-" -> Hm
| "su1" -> Sup (M1,1) | "su1c" -> Sup (M1,-1)
| "sc1" -> Sup (M1,2) | "sc1c" -> Sup (M1,-2)
| "st1" -> Sup (M1,3) | "st1c" -> Sup (M1,-3)
| "su2" -> Sup (M2,1) | "su2c" -> Sup (M2,-1)
| "sc2" -> Sup (M2,2) | "sc2c" -> Sup (M2,-2)
| "st2" -> Sup (M2,3) | "st2c" -> Sup (M2,-3)
| "sgl" | "sg" -> Gluino
| "sd1" -> Sdown (M1,1) | "sd1c" -> Sdown (M1,-1)
| "ss1" -> Sdown (M1,2) | "ss1c" -> Sdown (M1,-2)
| "sb1" -> Sdown (M1,3) | "sb1c" -> Sdown (M1,-3)
| "sd2" -> Sdown (M2,1) | "sd2c" -> Sdown (M2,-1)
| "ss2" -> Sdown (M2,2) | "ss2c" -> Sdown (M2,-2)
| "sb2" -> Sdown (M2,3) | "sb2c" -> Sdown (M2,-3)
| "neu1" -> Neutralino N1 | "neu2" -> Neutralino N2
| "neu3" -> Neutralino N3 | "neu4" -> Neutralino N4
| "neu5" -> Neutralino N5
| "ch1+" -> Chargino C1 | "ch2+" -> Chargino C2
| "ch1-" -> Chargino C1c | "ch2-" -> Chargino C2c
| s -> invalid_arg ("Fatal error: %s Modellib_NMSSM.NMSSM.flavor_of_string:" ^ s)
let flavor_to_string = function
| L 1 -> "e-" | L (-1) -> "e+"
| L 2 -> "mu-" | L (-2) -> "mu+"
| L 3 -> "tau-" | L (-3) -> "tau+"
| N 1 -> "nue" | N (-1) -> "nuebar"
| N 2 -> "numu" | N (-2) -> "numubar"
| N 3 -> "nutau" | N (-3) -> "nutaubar"
| U 1 -> "u" | U (-1) -> "ubar"
| U 2 -> "c" | U (-2) -> "cbar"
| U 3 -> "t" | U (-3) -> "tbar"
| U _ -> invalid_arg
"Modellib_NMSSM.NMSSM.flavor_to_string: invalid up type quark"
| D 1 -> "d" | D (-1) -> "dbar"
| D 2 -> "s" | D (-2) -> "sbar"
| D 3 -> "b" | D (-3) -> "bbar"
| D _ -> invalid_arg
"Modellib_NMSSM.NMSSM.flavor_to_string: invalid down type quark"
| Gl -> "gl" | Gluino -> "sgl"
| Ga -> "A" | Z -> "Z"
| Wp -> "W+" | Wm -> "W-"
| SHiggs S1 -> "h01" | SHiggs S2 -> "h02" | SHiggs S3 -> "h03"
| PHiggs P1 -> "A01" | PHiggs P2 -> "A02"
| Hp -> "H+" | Hm -> "H-"
| Slepton (M1,1) -> "se1-" | Slepton (M1,-1) -> "se1+"
| Slepton (M1,2) -> "smu1-" | Slepton (M1,-2) -> "smu1+"
| Slepton (M1,3) -> "stau1-" | Slepton (M1,-3) -> "stau1+"
| Slepton (M2,1) -> "se2-" | Slepton (M2,-1) -> "se2+"
| Slepton (M2,2) -> "smu2-" | Slepton (M2,-2) -> "smu2+"
| Slepton (M2,3) -> "stau2-" | Slepton (M2,-3) -> "stau2+"
| Sneutrino 1 -> "snue" | Sneutrino (-1) -> "snue*"
| Sneutrino 2 -> "snumu" | Sneutrino (-2) -> "snumu*"
| Sneutrino 3 -> "snutau" | Sneutrino (-3) -> "snutau*"
| Sup (M1,1) -> "su1" | Sup (M1,-1) -> "su1c"
| Sup (M1,2) -> "sc1" | Sup (M1,-2) -> "sc1c"
| Sup (M1,3) -> "st1" | Sup (M1,-3) -> "st1c"
| Sup (M2,1) -> "su2" | Sup (M2,-1) -> "su2c"
| Sup (M2,2) -> "sc2" | Sup (M2,-2) -> "sc2c"
| Sup (M2,3) -> "st2" | Sup (M2,-3) -> "st2c"
| Sdown (M1,1) -> "sd1" | Sdown (M1,-1) -> "sd1c"
| Sdown (M1,2) -> "ss1" | Sdown (M1,-2) -> "ss1c"
| Sdown (M1,3) -> "sb1" | Sdown (M1,-3) -> "sb1c"
| Sdown (M2,1) -> "sd2" | Sdown (M2,-1) -> "sd2c"
| Sdown (M2,2) -> "ss2" | Sdown (M2,-2) -> "ss2c"
| Sdown (M2,3) -> "sb2" | Sdown (M2,-3) -> "sb2c"
| Neutralino N1 -> "neu1"
| Neutralino N2 -> "neu2"
| Neutralino N3 -> "neu3"
| Neutralino N4 -> "neu4"
| Neutralino N5 -> "neu5"
| Chargino C1 -> "ch1+" | Chargino C1c -> "ch1-"
| Chargino C2 -> "ch2+" | Chargino C2c -> "ch2-"
| _ -> invalid_arg "Modellib_NMSSM.NMSSM.flavor_to_string"
let flavor_to_TeX = function
| L 1 -> "e^-" | L (-1) -> "e^+"
| L 2 -> "\\mu^-" | L (-2) -> "\\mu^+"
| L 3 -> "\\tau^-" | L (-3) -> "\\tau^+"
| N 1 -> "\\nu_e" | N (-1) -> "\\bar{\\nu}_e"
| N 2 -> "\\nu_\\mu" | N (-2) -> "\\bar{\\nu}_\\mu"
| N 3 -> "\\nu_\\tau" | N (-3) -> "\\bar{\\nu}_\\tau"
| U 1 -> "u" | U (-1) -> "\\bar{u}"
| U 2 -> "c" | U (-2) -> "\\bar{c}"
| U 3 -> "t" | U (-3) -> "\\bar{t}"
| D 1 -> "d" | D (-1) -> "\\bar{d}"
| D 2 -> "s" | D (-2) -> "\\bar{s}"
| D 3 -> "b" | D (-3) -> "\\bar{b}"
| L _ -> invalid_arg
"Modellib_NMSSM.NMSSM.flavor_to_TeX: invalid lepton"
| N _ -> invalid_arg
"Modellib_NMSSM.NMSSM.flavor_to_TeX: invalid neutrino"
| U _ -> invalid_arg
"Modellib_NMSSM.NMSSM.flavor_to_TeX: invalid up type quark"
| D _ -> invalid_arg
"Modellib_NMSSM.NMSSM.flavor_to_TeX: invalid down type quark"
| Gl -> "g" | Gluino -> "\\widetilde{g}"
| Ga -> "\\gamma" | Z -> "Z" | Wp -> "W^+" | Wm -> "W^-"
| SHiggs S1 -> "S_1" | SHiggs S2 -> "S_2" | SHiggs S3 -> "S_3"
| PHiggs P1 -> "P_1" | PHiggs P2 -> "P_2"
| Hp -> "H^+" | Hm -> "H^-"
| Slepton (M1,1) -> "\\widetilde{e}_1^-"
| Slepton (M1,-1) -> "\\widetilde{e}_1^+"
| Slepton (M1,2) -> "\\widetilde{\\mu}_1^-"
| Slepton (M1,-2) -> "\\widetilde{\\mu}_1^+"
| Slepton (M1,3) -> "\\widetilde{\\tau}_1^-"
| Slepton (M1,-3) -> "\\widetilde{\\tau}_1^+"
| Slepton (M2,1) -> "\\widetilde{e}_2^-"
| Slepton (M2,-1) -> "\\widetilde{e}_2^+"
| Slepton (M2,2) -> "\\widetilde{\\mu}_2^-"
| Slepton (M2,-2) -> "\\widetilde{\\mu}_2^+"
| Slepton (M2,3) -> "\\widetilde{\\tau}_2^-"
| Slepton (M2,-3) -> "\\widetilde{\\tau}_2^+"
| Sneutrino 1 -> "\\widetilde{\\nu}_e"
| Sneutrino (-1) -> "\\widetilde{\\nu}_e^*"
| Sneutrino 2 -> "\\widetilde{\\nu}_\\mu"
| Sneutrino (-2) -> "\\widetilde{\\nu}_\\mu^*"
| Sneutrino 3 -> "\\widetilde{\\nu}_\\tau"
| Sneutrino (-3) -> "\\widetilde{\\nu}_\\tau^*"
| Sup (M1,1) -> "\\widetilde{u}_1"
| Sup (M1,-1) -> "\\widetilde{u}_1^*"
| Sup (M1,2) -> "\\widetilde{c}_1"
| Sup (M1,-2) -> "\\widetilde{c}_1^*"
| Sup (M1,3) -> "\\widetilde{t}_1"
| Sup (M1,-3) -> "\\widetilde{t}_1^*"
| Sup (M2,1) -> "\\widetilde{u}_2"
| Sup (M2,-1) -> "\\widetilde{u}_2^*"
| Sup (M2,2) -> "\\widetilde{c}_2"
| Sup (M2,-2) -> "\\widetilde{c}_2^*"
| Sup (M2,3) -> "\\widetilde{t}_2"
| Sup (M2,-3) -> "\\widetilde{t}_2^*"
| Sdown (M1,1) -> "\\widetilde{d}_1"
| Sdown (M1,-1) -> "\\widetilde{d}_1^*"
| Sdown (M1,2) -> "\\widetilde{s}_1"
| Sdown (M1,-2) -> "\\widetilde{s}_1^*"
| Sdown (M1,3) -> "\\widetilde{b}_1"
| Sdown (M1,-3) -> "\\widetilde{b}_1^*"
| Sdown (M2,1) -> "\\widetilde{d}_2"
| Sdown (M2,-1) -> "\\widetilde{d}_2^*"
| Sdown (M2,2) -> "\\widetilde{s}_2"
| Sdown (M2,-2) -> "\\widetilde{s}_2^*"
| Sdown (M2,3) -> "\\widetilde{b}_2"
| Sdown (M2,-3) -> "\\widetilde{b}_2^*"
| Neutralino N1 -> "\\widetilde{\\chi}^0_1"
| Neutralino N2 -> "\\widetilde{\\chi}^0_2"
| Neutralino N3 -> "\\widetilde{\\chi}^0_3"
| Neutralino N4 -> "\\widetilde{\\chi}^0_4"
| Neutralino N5 -> "\\widetilde{\\chi}^0_5"
| Slepton _ -> invalid_arg
"Modellib_NMSSM.NMSSM.flavor_to_TeX: invalid slepton"
| Sneutrino _ -> invalid_arg
"Modellib_NMSSM.NMSSM.flavor_to_TeX: invalid sneutrino"
| Sup _ -> invalid_arg
"Modellib_NMSSM.NMSSM.flavor_to_TeX: invalid up type squark"
| Sdown _ -> invalid_arg
"Modellib_NMSSM.NMSSM.flavor_to_TeX: invalid down type squark"
| Chargino C1 -> "\\widetilde{\\chi}_1^+"
| Chargino C1c -> "\\widetilde{\\chi}_1^-"
| Chargino C2 -> "\\widetilde{\\chi}_2^+"
| Chargino C2c -> "\\widetilde{\\chi}_2^-"
let flavor_symbol = function
| L g when g > 0 -> "l" ^ string_of_int g
| L g -> "l" ^ string_of_int (abs g) ^ "b"
| N g when g > 0 -> "n" ^ string_of_int g
| N g -> "n" ^ string_of_int (abs g) ^ "b"
| U g when g > 0 -> "u" ^ string_of_int g
| U g -> "u" ^ string_of_int (abs g) ^ "b"
| D g when g > 0 -> "d" ^ string_of_int g
| D g -> "d" ^ string_of_int (abs g) ^ "b"
| Gl -> "gl"
| Ga -> "a" | Z -> "z"
| Wp -> "wp" | Wm -> "wm"
| Slepton (M1,g) when g > 0 -> "sl1" ^ string_of_int g
| Slepton (M1,g) -> "sl1c" ^ string_of_int (abs g)
| Slepton (M2,g) when g > 0 -> "sl2" ^ string_of_int g
| Slepton (M2,g) -> "sl2c" ^ string_of_int (abs g)
| Sneutrino g when g > 0 -> "sn" ^ string_of_int g
| Sneutrino g -> "snc" ^ string_of_int (abs g)
| Sup (M1,g) when g > 0 -> "su1" ^ string_of_int g
| Sup (M1,g) -> "su1c" ^ string_of_int (abs g)
| Sup (M2,g) when g > 0 -> "su2" ^ string_of_int g
| Sup (M2,g) -> "su2c" ^ string_of_int (abs g)
| Sdown (M1,g) when g > 0 -> "sd1" ^ string_of_int g
| Sdown (M1,g) -> "sd1c" ^ string_of_int (abs g)
| Sdown (M2,g) when g > 0 -> "sd2" ^ string_of_int g
| Sdown (M2,g) -> "sd2c" ^ string_of_int (abs g)
| Neutralino n -> "neu" ^ (string_of_neu n)
| Chargino c when (int_of_char c) > 0 -> "cp" ^ string_of_char c
| Chargino c -> "cm" ^ string_of_int (abs (int_of_char c))
| Gluino -> "sgl"
| SHiggs s -> "h0" ^ (string_of_shiggs s)
| PHiggs p -> "A0" ^ (string_of_phiggs p)
| Hp -> "hp" | Hm -> "hm"
let pdg = function
| L g when g > 0 -> 9 + 2*g
| L g -> - 9 + 2*g
| N g when g > 0 -> 10 + 2*g
| N g -> - 10 + 2*g
| U g when g > 0 -> 2*g
| U g -> 2*g
| D g when g > 0 -> - 1 + 2*g
| D g -> 1 + 2*g
| Gl -> 21
| Ga -> 22 | Z -> 23
| Wp -> 24 | Wm -> (-24)
| SHiggs S1 -> 25 | SHiggs S2 -> 35 | SHiggs S3 -> 45
| PHiggs P1 -> 36 | PHiggs P2 -> 46
| Hp -> 37 | Hm -> (-37)
| Slepton (M1,g) when g > 0 -> 1000009 + 2*g
| Slepton (M1,g) -> - 1000009 + 2*g
| Slepton (M2,g) when g > 0 -> 2000009 + 2*g
| Slepton (M2,g) -> - 2000009 + 2*g
| Sneutrino g when g > 0 -> 1000010 + 2*g
| Sneutrino g -> - 1000010 + 2*g
| Sup (M1,g) when g > 0 -> 1000000 + 2*g
| Sup (M1,g) -> - 1000000 + 2*g
| Sup (M2,g) when g > 0 -> 2000000 + 2*g
| Sup (M2,g) -> - 2000000 + 2*g
| Sdown (M1,g) when g > 0 -> 999999 + 2*g
| Sdown (M1,g) -> - 999999 + 2*g
| Sdown (M2,g) when g > 0 -> 1999999 + 2*g
| Sdown (M2,g) -> - 1999999 + 2*g
| Gluino -> 1000021
| Chargino C1 -> 1000024 | Chargino C1c -> (-1000024)
| Chargino C2 -> 1000037 | Chargino C2c -> (-1000037)
| Neutralino N1 -> 1000022 | Neutralino N2 -> 1000023
| Neutralino N3 -> 1000025 | Neutralino N4 -> 1000035
| Neutralino N5 -> 1000045
(* We must take care of the pdg numbers for the two different kinds of
sfermions in the MSSM. The particle data group in its Monte Carlo particle
numbering scheme takes only into account mixtures of the third generation
squarks and the stau. For the other sfermions we will use the number of the
lefthanded field for the lighter mixed state and the one for the righthanded
for the heavier. Below are the official pdg numbers from the Particle
Data Group. In order not to produce arrays with some million entries in
the Fortran code for the masses and the widths we introduce our private
pdg numbering scheme which only extends not too far beyond 42.
Our private scheme then has the following pdf numbers (for the sparticles
the subscripts $L/R$ and $1/2$ are taken synonymously):
\begin{center}
\renewcommand{\arraystretch}{1.2}
\begin{tabular}{|r|l|l|}\hline
$d$ & down-quark & 1 \\\hline
$u$ & up-quark & 2 \\\hline
$s$ & strange-quark & 3 \\\hline
$c$ & charm-quark & 4 \\\hline
$b$ & bottom-quark & 5 \\\hline
$t$ & top-quark & 6 \\\hline\hline
$e^-$ & electron & 11 \\\hline
$\nu_e$ & electron-neutrino & 12 \\\hline
$\mu^-$ & muon & 13 \\\hline
$\nu_\mu$ & muon-neutrino & 14 \\\hline
$\tau^-$ & tau & 15 \\\hline
$\nu_\tau$ & tau-neutrino & 16 \\\hline\hline
$g$ & gluon & (9) 21 \\\hline
$\gamma$ & photon & 22 \\\hline
$Z^0$ & Z-boson & 23 \\\hline
$W^+$ & W-boson & 24 \\\hline\hline
$h^0$ & light Higgs boson & 25 \\\hline
$H^0$ & heavy Higgs boson & 35 \\\hline
$A^0$ & pseudoscalar Higgs & 36 \\\hline
$H^+$ & charged Higgs & 37 \\\hline\hline
$\tilde{d}_L$ & down-squark 1 & 41 \\\hline
$\tilde{u}_L$ & up-squark 1 & 42 \\\hline
$\tilde{s}_L$ & strange-squark 1 & 43 \\\hline
$\tilde{c}_L$ & charm-squark 1 & 44 \\\hline
$\tilde{b}_L$ & bottom-squark 1 & 45 \\\hline
$\tilde{t}_L$ & top-squark 1 & 46 \\\hline
$\tilde{d}_R$ & down-squark 2 & 47 \\\hline
$\tilde{u}_R$ & up-squark 2 & 48 \\\hline
$\tilde{s}_R$ & strange-squark 2 & 49 \\\hline
$\tilde{c}_R$ & charm-squark 2 & 50 \\\hline
$\tilde{b}_R$ & bottom-squark 2 & 51 \\\hline
$\tilde{t}_R$ & top-squark 2 & 52 \\\hline\hline
$\tilde{e}_L$ & selectron 1 & 53 \\\hline
$\tilde{\nu}_{e,L}$ & electron-sneutrino & 54 \\\hline
$\tilde{\mu}_L$ & smuon 1 & 55 \\\hline
$\tilde{\nu}_{\mu,L}$ & muon-sneutrino & 56 \\\hline
$\tilde{\tau}_L$ & stau 1 & 57 \\\hline
$\tilde{\nu}_{\tau,L}$ & tau-sneutrino & 58 \\\hline
$\tilde{e}_R$ & selectron 2 & 59 \\\hline
$\tilde{\mu}_R$ & smuon 2 & 61 \\\hline
$\tilde{\tau}_R$ & stau 2 & 63 \\\hline\hline
$\tilde{g}$ & gluino & 64 \\\hline
$\tilde{\chi}^0_1$ & neutralino 1 & 65 \\\hline
$\tilde{\chi}^0_2$ & neutralino 2 & 66 \\\hline
$\tilde{\chi}^0_3$ & neutralino 3 & 67 \\\hline
$\tilde{\chi}^0_4$ & neutralino 4 & 68 \\\hline
$\tilde{\chi}^0_5$ & neutralino 5 & 69 \\\hline
$\tilde{\chi4}^+_1$ & chargino 1 & 70 \\\hline
$\tilde{\chi}^+_2$ & chargino 2 & 71 \\\hline\hline
$a$ & pseudoscalar & 72 \\\hline
$s$ & scalar singlet & 73 \\\hline
$\tilde{G}$ & gravitino & -- \\\hline\hline
\end{tabular}
\end{center} *)
let pdg_mw = function
| L g when g > 0 -> 9 + 2*g
| L g -> - 9 + 2*g
| N g when g > 0 -> 10 + 2*g
| N g -> - 10 + 2*g
| U g when g > 0 -> 2*g
| U g -> 2*g
| D g when g > 0 -> - 1 + 2*g
| D g -> 1 + 2*g
| Gl -> 21
| Ga -> 22 | Z -> 23
| Wp -> 24 | Wm -> (-24)
| SHiggs S1 -> 25 | SHiggs S2 -> 35 | PHiggs P1 -> 36
| Hp -> 37 | Hm -> (-37)
| Sup (M1,g) when g > 0 -> 40 + 2*g
| Sup (M1,g) -> - 40 + 2*g
| Sup (M2,g) when g > 0 -> 46 + 2*g
| Sup (M2,g) -> - 46 + 2*g
| Sdown (M1,g) when g > 0 -> 39 + 2*g
| Sdown (M1,g) -> - 39 + 2*g
| Sdown (M2,g) when g > 0 -> 45 + 2*g
| Sdown (M2,g) -> - 45 + 2*g
| Slepton (M1,g) when g > 0 -> 51 + 2*g
| Slepton (M1,g) -> - 51 + 2*g
| Slepton (M2,g) when g > 0 -> 57 + 2*g
| Slepton (M2,g) -> - 57 + 2*g
| Sneutrino g when g > 0 -> 52 + 2*g
| Sneutrino g -> - 52 + 2*g
| Gluino -> 64
| Chargino C1 -> 70 | Chargino C1c -> (-70)
| Chargino C2 -> 71 | Chargino C2c -> (-71)
| Neutralino N1 -> 65 | Neutralino N2 -> 66
| Neutralino N3 -> 67 | Neutralino N4 -> 68
| Neutralino N5 -> 69
| PHiggs P2 -> 72 | SHiggs S3 -> 73
let mass_symbol f =
"mass(" ^ string_of_int (abs (pdg_mw f)) ^ ")"
let width_symbol f =
"width(" ^ string_of_int (abs (pdg_mw f)) ^ ")"
let conj_symbol = function
| false, str -> str
| true, str -> str ^ "_c"
let constant_symbol = function
| E -> "e" | G -> "g"
| Mu -> "mu" | Lambda -> "lambda" | G_Z -> "gz"
| Q_lepton -> "qlep" | Q_up -> "qup" | Q_down -> "qdwn"
| Q_charg -> "qchar"
| G_NC_lepton -> "gnclep" | G_NC_neutrino -> "gncneu"
| G_NC_up -> "gncup" | G_NC_down -> "gncdwn"
| G_CC -> "gcc"
| G_CCQ (vc,g1,g2) -> conj_symbol (vc, "g_ccq" ) ^ "(" ^
string_of_int g1 ^ "," ^ string_of_int g2 ^ ")"
| I_Q_W -> "iqw" | I_G_ZWW -> "igzww"
| G_WWWW -> "gw4" | G_ZZWW -> "gzzww"
| G_PZWW -> "gpzww" | G_PPWW -> "gppww"
| G_GH4_ZZPP (p1,p2) -> "g_ZZA0A0(" ^ string_of_phiggs p1 ^ ","
^ string_of_phiggs p2 ^ ")"
| G_GH4_ZZSS (s1,s2) -> "g_ZZh0h0(" ^ string_of_shiggs s1 ^ ","
^ string_of_shiggs s2 ^ ")"
| G_GH4_ZZCC -> "g_zzhphm"
| G_GH4_GaGaCC -> "g_AAhphm"
| G_GH4_ZGaCC -> "g_zAhphm"
| G_GH4_WWCC -> "g_wwhphm"
| G_GH4_WWPP (p1,p2) -> "g_WWA0A0(" ^ string_of_phiggs p1 ^ "," ^
string_of_phiggs p2 ^ ")"
| G_GH4_WWSS (s1,s2) -> "g_WWh0h0(" ^ string_of_shiggs s1 ^ "," ^
string_of_shiggs s2 ^ ")"
| G_GH4_ZWSC s -> "g_ZWhph0(" ^ string_of_shiggs s ^")"
| G_GH4_GaWSC s -> "g_AWhph0(" ^ string_of_shiggs s ^")"
| G_GH4_ZWPC p -> "g_ZWhpA0(" ^ string_of_phiggs p ^")"
| G_GH4_GaWPC p -> "g_AWhpA0(" ^ string_of_phiggs p ^")"
| G_CICIS (n1,n2,s) -> "g_neuneuh0(" ^ string_of_neu n1 ^ "," ^
string_of_neu n2 ^ "," ^ string_of_shiggs s ^ ")"
| G_CICIP (n1,n2,p) -> "g_neuneuA0(" ^ string_of_neu n1 ^ "," ^
string_of_neu n2 ^ "," ^ string_of_phiggs p ^ ")"
| G_H3_SCC s -> "g_h0hphm(" ^ string_of_shiggs s ^ ")"
| G_H3_SPP (s,p1,p2) -> "g_h0A0A0(" ^ string_of_shiggs s ^ "," ^
string_of_phiggs p1 ^ "," ^ string_of_phiggs p2 ^ ")"
| G_H3_SSS (s1,s2,s3) -> "g_h0h0h0(" ^ string_of_shiggs s1 ^ "," ^
string_of_shiggs s2 ^ "," ^ string_of_shiggs s3 ^ ")"
| G_CSC (c1,c2,s) -> "g_chchh0(" ^ string_of_char c1 ^ "," ^
string_of_char c2 ^ "," ^ string_of_shiggs s ^")"
| G_CPC (c1,c2,p) -> "g_chchA0(" ^ string_of_char c1 ^ "," ^
string_of_char c2 ^ "," ^ string_of_phiggs p ^")"
| G_YUK_FFS (f1,f2,s) -> "g_yuk_h0_" ^ string_of_fermion_type f1 ^
string_of_fermion_type f2 ^ "(" ^ string_of_shiggs s ^ "," ^
string_of_fermion_gen f1 ^ ")"
| G_YUK_FFP (f1,f2,p) -> "g_yuk_A0_" ^ string_of_fermion_type f1 ^
string_of_fermion_type f2 ^ "(" ^ string_of_phiggs p ^ "," ^
string_of_fermion_gen f1 ^ ")"
| G_YUK_LCN g -> "g_yuk_hp_ln(" ^ string_of_int g ^ ")"
| G_NWC (n,c) -> "g_nwc(" ^ string_of_char c ^ "," ^ string_of_neu n
^ ")"
| G_CWN (c,n) -> "g_cwn(" ^ string_of_char c ^ "," ^ string_of_neu n
^ ")"
| G_SLSNW (vc,g,m) -> conj_symbol (vc, "g_wslsn") ^ "(" ^
string_of_int g ^ "," ^ string_of_sfm m ^ ")"
| G_NZN (n1,n2) -> "g_zneuneu(" ^ string_of_neu n1 ^ ","
^ string_of_neu n2 ^ ")"
| G_CZC (c1,c2) -> "g_zchch(" ^ string_of_char c1 ^ "," ^
string_of_char c2 ^ ")"
| Gs -> "gs"
| G_YUK_UCD (n,m) -> "g_yuk_hp_ud(" ^ string_of_int n ^ "," ^
string_of_int m ^ ")"
| G_YUK_DCU (n,m) -> "g_yuk_hm_du(" ^ string_of_int n ^ "," ^
string_of_int m ^ ")"
| G_YUK_N (vc,f,n,sf,m) -> conj_symbol (vc, "g_yuk_neu_" ^
string_of_fermion_type f ^ string_of_sff sf) ^ "(" ^
string_of_fermion_gen f ^ "," ^ string_of_neu n ^ "," ^
string_of_sfm m ^ ")"
| G_YUK_G (vc,f,sf,m) -> conj_symbol (vc, "g_yuk_gluino_" ^
string_of_fermion_type f ^ string_of_sff sf) ^ "(" ^
string_of_fermion_gen f ^ "," ^ string_of_sfm m ^ ")"
| G_YUK_C (vc,f,c,sf,m) -> conj_symbol (vc, "g_yuk_char_" ^
string_of_fermion_type f ^ string_of_sff sf) ^ "(" ^
string_of_fermion_gen f ^ "," ^ string_of_char c ^ "," ^
string_of_sfm m ^ ")"
| G_YUK_Q (vc,g1,f,c,sf,m) -> conj_symbol (vc, "g_yuk_char_" ^
string_of_fermion_type f ^ string_of_sff sf) ^ "(" ^ string_of_int
g1 ^ "," ^ string_of_fermion_gen f ^ "," ^ string_of_char c ^ ","
^ string_of_sfm m ^ ")"
| G_WPSUSD (vc,m1,m2,g1,g2) -> conj_symbol (vc, "g_wA_susd") ^ "(" ^
string_of_int g1 ^ "," ^ string_of_int g2 ^ "," ^ string_of_sfm m1 ^
"," ^ string_of_sfm m2 ^ ")"
| G_WZSUSD (vc,m1,m2,g1,g2) -> conj_symbol (vc, "g_wz_susd") ^ "(" ^
string_of_int g1 ^ "," ^ string_of_int g2 ^ "," ^ string_of_sfm m1 ^
"," ^ string_of_sfm m2 ^ ")"
| G_GH_ZSP (s,p) -> "g_zh0a0(" ^ string_of_shiggs s ^ "," ^
string_of_phiggs p ^ ")"
| G_GH_WSC s -> "g_Whph0(" ^ string_of_shiggs s ^ ")"
| G_GH_WPC p -> "g_WhpA0(" ^ string_of_phiggs p ^ ")"
| G_GH_ZZS s -> "g_ZZh0(" ^ string_of_shiggs s ^ ")"
| G_GH_WWS s -> "g_WWh0(" ^ string_of_shiggs s ^ ")"
| G_GLUGLUH0 s -> "g_glugluh0(" ^ string_of_shiggs s ^ ")"
| G_GLUGLUA0 p -> "g_gluglua0(" ^ string_of_phiggs p ^ ")"
| G_GH_ZCC -> "g_Zhmhp"
| G_GH_GaCC -> "g_Ahmhp"
| G_ZSF (f,g,m1,m2) -> "g_z" ^ string_of_sff f ^ string_of_sff f ^ "(" ^
string_of_int g ^ "," ^ string_of_sfm m1 ^ "," ^ string_of_sfm m2
^ ")"
| G_HSNSL (vc,g,m) -> conj_symbol (vc, "g_hp_sl" ^ string_of_sfm m ^
"sn1") ^ "(" ^ string_of_int g ^ ")"
| G_GlGlSQSQ -> "g_gg_sqsq"
| G_PPSFSF f -> "g_AA_" ^ string_of_sff f ^ string_of_sff f
| G_ZZSFSF (f,g,m1,m2) -> "g_zz_" ^ string_of_sff f ^ string_of_sff f ^
"(" ^ string_of_int g ^","^ string_of_sfm m1
^ "," ^ string_of_sfm m2 ^ ")"
| G_ZPSFSF (f,g,m1,m2) -> "g_zA_" ^ string_of_sff f ^ string_of_sff f ^
"(" ^ string_of_int g ^","^ string_of_sfm m1
^ "," ^ string_of_sfm m2 ^ ")"
| G_GlPSQSQ -> "g_gA_sqsq"
| G_GlZSFSF (f,g,m1,m2) -> "g_gz_" ^ string_of_sff f ^ string_of_sff f ^
"(" ^ string_of_int g ^ "," ^ string_of_sfm m1 ^ "," ^ string_of_sfm
m2 ^ ")"
| G_GlWSUSD (vc,m1,m2,g1,g2) -> conj_symbol (vc, "g_gw_susd") ^ "(" ^
string_of_int g1 ^ "," ^ string_of_int g2 ^ "," ^ string_of_sfm m1 ^
"," ^ string_of_sfm m2 ^ ")"
| G_SS -> "gs**2"
| I_G_S -> "igs"
| G_NHC (vc,n,c) -> conj_symbol(vc,"g_neuhmchar") ^ "(" ^
string_of_neu n ^ "," ^ string_of_char c ^")"
| G_WWSFSF (f,g,m1,m2) -> "g_ww_" ^ string_of_sff f
^ string_of_sff f ^"(" ^ string_of_int g ^ "," ^ string_of_sfm m1 ^
"," ^ string_of_sfm m2 ^ ")"
| G_WPSLSN (vc,g,m) -> conj_symbol (vc, "g_wA_slsn") ^ "(" ^
string_of_int g ^ "," ^ string_of_sfm m ^ ")"
| G_WZSLSN (vc,g,m) -> conj_symbol (vc, "g_wz_slsn") ^"("^ string_of_int
g ^ "," ^ string_of_sfm m ^ ")"
| G_SFSFS (s,f,g,m1,m2) -> "g_h0_"^ string_of_sff f ^ string_of_sfm m1
^ string_of_sff f ^ string_of_sfm m2 ^ "(" ^ string_of_shiggs s ^ ","
^ string_of_int g ^ ")"
| G_SFSFP (p,f,g,m1,m2) -> "g_A0_"^ string_of_sff f ^ string_of_sfm m1
^ string_of_sff f ^ string_of_sfm m2 ^ "(" ^ string_of_phiggs p ^ ","
^ string_of_int g ^ ")"
| G_HSUSD (vc,m1,m2,g1,g2) -> conj_symbol (vc, "g_hp_su" ^ string_of_sfm
m1 ^ "sd" ^ string_of_sfm m2 )^ "(" ^ string_of_int g1 ^ ","
^ string_of_int g2 ^")"
| G_WSQ (vc,g1,g2,m1,m2) -> conj_symbol (vc, "g_wsusd") ^ "("
^ string_of_int g1 ^ "," ^ string_of_int g2 ^ "," ^ string_of_sfm m1
^ "," ^ string_of_sfm m2 ^ ")"
end
Index: trunk/omega/src/options.mli
===================================================================
--- trunk/omega/src/options.mli (revision 8899)
+++ trunk/omega/src/options.mli (revision 8900)
@@ -1,49 +1,43 @@
(* options.mli --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
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. *)
type t
val empty : t
val create : (string * Arg.spec * string) list -> t
+val exclude : (string -> bool) -> t -> t
val extend : t -> (string * Arg.spec * string) list -> t
(*i val merge : t -> t -> t i*)
val cmdline : string -> t -> (string * Arg.spec * string) list
(*i val list : t -> (string * string) list i*)
(*i val parse : t -> string * string -> unit i*)
(*i exception Invalid of string * string i*)
(* This is a clone of [Arg.parse] with a delayed usage string. *)
-val parse : (string * Arg.spec * string) list ->
+val parse : ?current:int ref -> ?argv:string array ->
+ (string * Arg.spec * string) list ->
(string -> unit) -> (unit -> string) -> unit
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/permutation.ml
===================================================================
--- trunk/omega/src/permutation.ml (revision 8899)
+++ trunk/omega/src/permutation.ml (revision 8900)
@@ -1,407 +1,378 @@
(* permutation.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
cf. main AUTHORS file
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
module type T =
sig
type t
val of_list : int list -> t
val of_array : int array -> t
val of_lists : 'a list -> 'a list -> t
val inverse : t -> t
val compose : t -> t -> t
val compose_inv : t -> t -> t
val list : t -> 'a list -> 'a list
val array : t -> 'a array -> 'a array
val all : int -> t list
val even : int -> t list
val odd : int -> t list
val cyclic : int -> t list
val signed : int -> (int * t) list
val to_string : t -> string
end
let same_elements l1 l2 =
List.sort compare l1 = List.sort compare l2
module PM = Pmap.Tree
let offset_map l =
let _, offsets =
List.fold_left
(fun (i, map) a -> (succ i, PM.add compare a i map))
(0, PM.empty) l in
offsets
(* TODO: this algorithm fails if the lists contain duplicate elements. *)
let of_lists_list l l' =
if same_elements l l' then
let offsets' = offset_map l' in
let _, p_rev =
List.fold_left
(fun (i, acc) a -> (succ i, PM.find compare a offsets' :: acc))
(0, []) l in
List.rev p_rev
else
invalid_arg "Permutation.of_lists: incompatible lists"
module Using_Lists : T =
struct
type t = int list
let of_list p =
if List.sort compare p <> (ThoList.range 0 (List.length p - 1)) then
invalid_arg "Permutation.of_list"
else
p
let of_array p =
try
of_list (Array.to_list p)
with
| Invalid_argument s ->
if s = "Permutation.of_list" then
invalid_arg "Permutation.of_array"
else
failwith ("Permutation.of_array: unexpected Invalid_argument(" ^
s ^ ")")
let of_lists = of_lists_list
let inverse p = snd (ThoList.ariadne_sort p)
let list p l =
List.map snd
(List.sort (fun (i, _) (j, _) -> compare i j)
(try
List.rev_map2 (fun i x -> (i, x)) p l
with
| Invalid_argument s ->
if s = "List.rev_map2" then
invalid_arg "Permutation.list: length mismatch"
else
failwith ("Permutation.list: unexpected Invalid_argument(" ^
s ^ ")")))
let array p a =
try
Array.of_list (list p (Array.to_list a))
with
| Invalid_argument s ->
if s = "Permutation.list: length mismatch" then
invalid_arg "Permutation.array: length mismatch"
else
failwith ("Permutation.array: unexpected Invalid_argument(" ^ s ^ ")")
let compose_inv p q =
list q p
(* Probably not optimal (or really inefficient), but correct by
associativity. *)
let compose p q =
list (inverse q) p
let all n =
List.map of_list (Combinatorics.permute (ThoList.range 0 (pred n)))
let even n =
List.map of_list (Combinatorics.permute_even (ThoList.range 0 (pred n)))
let odd n =
List.map of_list (Combinatorics.permute_odd (ThoList.range 0 (pred n)))
let cyclic n =
List.map of_list (Combinatorics.permute_cyclic (ThoList.range 0 (pred n)))
let signed n =
List.map
(fun (eps, l) -> (eps, of_list l))
(Combinatorics.permute_signed (ThoList.range 0 (pred n)))
let to_string p =
String.concat "" (List.map string_of_int p)
end
module Using_Arrays : T =
struct
type t = int array
let of_list p =
if List.sort compare p <> (ThoList.range 0 (List.length p - 1)) then
invalid_arg "Permutation.of_list"
else
Array.of_list p
let of_array p =
try
of_list (Array.to_list p)
with
| Invalid_argument s ->
if s = "Permutation.of_list" then
invalid_arg "Permutation.of_array"
else
failwith ("Permutation.of_array: unexpected Invalid_argument(" ^
s ^ ")")
let of_lists l l' =
Array.of_list (of_lists_list l l')
let inverse p =
let len_p = Array.length p in
let p' = Array.make len_p p.(0) in
for i = 0 to pred len_p do
p'.(p.(i)) <- i
done;
p'
let array p a =
let len_a = Array.length a
and len_p = Array.length p in
if len_a <> len_p then
invalid_arg "Permutation.array: length mismatch";
let a' = Array.make len_a a.(0) in
for i = 0 to pred len_a do
a'.(p.(i)) <- a.(i)
done;
a'
let list p l =
try
Array.to_list (array p (Array.of_list l))
with
| Invalid_argument s ->
if s = "Permutation.array: length mismatch" then
invalid_arg "Permutation.list: length mismatch"
else
failwith ("Permutation.list: unexpected Invalid_argument(" ^ s ^ ")")
let compose_inv p q =
array q p
let compose p q =
array (inverse q) p
let all n =
List.map of_list (Combinatorics.permute (ThoList.range 0 (pred n)))
let even n =
List.map of_list (Combinatorics.permute_even (ThoList.range 0 (pred n)))
let odd n =
List.map of_list (Combinatorics.permute_odd (ThoList.range 0 (pred n)))
let cyclic n =
List.map of_list (Combinatorics.permute_cyclic (ThoList.range 0 (pred n)))
let signed n =
List.map
(fun (eps, l) -> (eps, of_list l))
(Combinatorics.permute_signed (ThoList.range 0 (pred n)))
let to_string p =
String.concat "" (List.map string_of_int (Array.to_list p))
end
module Default = Using_Arrays
-(*
- This is the Fisher-Yates shuffle, cf. D. Knuth, {\em Seminumerical
- algorithms. The Art of Computer Programming. 2}. Reading, MA:
- Addison–Wesley. pp. 139-140.
- *)
-
-(*i
- To shuffle an array a of n elements (indices 0..n-1):
-
- for i from n − 1 downto 1 do
- j ← random integer with 0 ≤ j ≤ i
- exchange a[j] and a[i]
-
- To initialize an array a of n elements to a randomly shuffled copy
- of source, both 0-based:
-
- a[0] ← source[0]
- for i from 1 to n − 1 do
- j ← random integer with 0 ≤ j ≤ i
- a[i] ← a[j]
- a[j] ← source[i]
-i*)
-
let shuffle l =
let a = Array.of_list l in
- for n = Array.length a - 1 downto 1 do
- let k = Random.int (succ n) in
- if k <> n then
- let tmp = Array.get a n in
- Array.set a n (Array.get a k);
- Array.set a k tmp
- done;
+ ThoArray.shuffle a;
Array.to_list a
let time f x =
let start = Sys.time () in
let f_x = f x in
let stop = Sys.time () in
(f_x, stop -. start)
let print_time msg f x =
let f_x, seconds = time f x in
Printf.printf "%s took %10.2f ms\n" msg (seconds *. 1000.);
f_x
let random_int_list imax n =
let imax_plus = succ imax in
Array.to_list (Array.init n (fun _ -> Random.int imax_plus))
module Test (P : T) : sig val suite : OUnit.test val time : unit -> unit end =
struct
open OUnit
open P
let of_list_overlap =
"overlap" >::
(fun () ->
assert_raises (Invalid_argument "Permutation.of_list")
(fun () ->
of_list [0;1;2;2]))
let of_list_gap =
"gap" >::
(fun () ->
assert_raises (Invalid_argument "Permutation.of_list")
(fun () ->
of_list [0;1;2;4;5]))
let of_list_ok =
"ok" >::
(fun () ->
let l = ThoList.range 0 10 in
assert_equal (of_list l) (of_list l))
let suite_of_list =
"of_list" >:::
[of_list_overlap;
of_list_gap;
of_list_ok]
let suite_of_lists =
"of_lists" >:::
[ "ok" >::
(fun () ->
for i = 1 to 10 do
let l = random_int_list 1000000 100 in
let l' = shuffle l in
assert_equal
~printer:(ThoList.to_string string_of_int)
l' (list (of_lists l l') l)
done) ]
let apply_invalid_lengths =
"invalid/lengths" >::
(fun () ->
assert_raises
(Invalid_argument "Permutation.list: length mismatch")
(fun () ->
list (of_list [0;1;2;3;4]) [0;1;2;3]))
let apply_ok =
"ok" >::
(fun () ->
assert_equal [2;0;1;3;5;4]
(list (of_list [1;2;0;3;5;4]) [0;1;2;3;4;5]))
let suite_apply =
"apply" >:::
[apply_invalid_lengths;
apply_ok]
let inverse_ok =
"ok" >::
(fun () ->
let l = shuffle (ThoList.range 0 1000) in
let p = of_list (shuffle l) in
assert_equal l (list (inverse p) (list p l)))
let suite_inverse =
"inverse" >:::
[inverse_ok]
let compose_ok =
"ok" >::
(fun () ->
let id = ThoList.range 0 1000 in
let p = of_list (shuffle id)
and q = of_list (shuffle id)
and l = id in
assert_equal (list p (list q l)) (list (compose p q) l))
let compose_inverse_ok =
"inverse/ok" >::
(fun () ->
let id = ThoList.range 0 1000 in
let p = of_list (shuffle id)
and q = of_list (shuffle id) in
assert_equal
(compose (inverse p) (inverse q))
(inverse (compose q p)))
let suite_compose =
"compose" >:::
[compose_ok;
compose_inverse_ok]
let suite =
"Permutations" >:::
[suite_of_list;
suite_of_lists;
suite_apply;
suite_inverse;
suite_compose]
let repeat repetitions size =
let id = ThoList.range 0 size in
let p = of_list (shuffle id)
and l = shuffle (List.map string_of_int id) in
print_time (Printf.sprintf "reps=%d, len=%d" repetitions size)
(fun () ->
for i = 1 to repetitions do
ignore (P.list p l)
done)
()
let time () =
repeat 100000 10;
repeat 10000 100;
repeat 1000 1000;
repeat 100 10000;
repeat 10 100000;
()
end
Index: trunk/omega/src/target_Fortran.ml
===================================================================
--- trunk/omega/src/target_Fortran.ml (revision 0)
+++ trunk/omega/src/target_Fortran.ml (revision 8900)
@@ -0,0 +1,2521 @@
+(* target_Fortran.ml --
+
+ Copyright (C) 1999-2023 by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+ with contributions from
+ Christian Speckner <cnspeckn@googlemail.com>
+ Fabian Bach <fabian.bach@t-online.de> (only parts of this file)
+ Marco Sekulla <marco.sekulla@kit.edu> (only parts of this file)
+ Bijan Chokoufe Nejad <bijan.chokoufe@desy.de> (only parts of this file)
+ So Young Shim <soyoung.shim@desy.de>
+
+ WHIZARD is free software; you can redistribute it and/or modify it
+ under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ WHIZARD is distributed in the hope that it will be useful, but
+ WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
+
+module Make_Fortran (Names : Target_Fortran_Names.T)
+ (Vintage_Fermions : Targets_vintage.Fermion_Maker)
+ (Fusion_Maker : Fusion.Maker) (P : Momentum.T) (M : Model.T) =
+ struct
+
+ let require_library =
+ Names.require_library @
+ [ "omega_vectors_2010_01_A"; "omega_polarizations_2010_01_A";
+ "omega_couplings_2010_01_A"; "omega_color_2010_01_A";
+ "omega_utils_2010_01_A" ]
+
+ module Fermions = Vintage_Fermions(Names)
+
+ module CM = Colorize.It(M)
+ module SCM = Orders.Slice(Colorize.It(M))
+ module F = Fusion_Maker(P)(M)
+
+ module CF = Fusion.Multi(Fusion_Maker)(P)(M)
+ type amplitudes = CF.amplitudes
+
+ open Coupling
+ open Format
+
+ type output_mode =
+ | Single_Function
+ | Single_Module of int
+ | Single_File of int
+ | Multi_File of int
+
+ let line_length = ref 80
+ let continuation_lines = ref (-1) (* 255 *)
+ let kind = ref "default"
+ let fortran95 = ref true
+ let module_name = ref "omega_amplitude"
+ let output_mode = ref (Single_Module 10)
+ let use_modules = ref []
+ let whizard = ref false
+ let amp_triv = ref false
+ let parameter_module = ref ""
+ let md5sum = ref None
+ let no_write = ref false
+ let km_write = ref false
+ let km_pure = ref false
+ let km_2_write = ref false
+ let km_2_pure = ref false
+ let openmp = ref false
+ let pure_unless_openmp = false
+
+ let options = Options.create
+ [ "90", Arg.Clear fortran95, " use only Fortran90 features";
+ "kind", Arg.String (fun s -> kind := s),
+ "kind real and complex kind (default: '" ^ !kind ^ "')";
+ "width", Arg.Int (fun w -> line_length := w), "n maximum line length";
+ "continuation", Arg.Int (fun l -> continuation_lines := l),
+ "n maximum # of continuation lines";
+ "module", Arg.String (fun s -> module_name := s), "name module name";
+ "single_function", Arg.Unit (fun () -> output_mode := Single_Function),
+ " compute the matrix element in one function";
+ "split_function", Arg.Int (fun n -> output_mode := Single_Module n),
+ "size split the matrix element into small functions";
+ "split_module", Arg.Int (fun n -> output_mode := Single_File n),
+ "size split the matrix element into small modules";
+ "split_file", Arg.Int (fun n -> output_mode := Multi_File n),
+ "size split the matrix element into small files";
+ "use", Arg.String (fun s -> use_modules := s :: !use_modules),
+ "name use module";
+ "parameter_module", Arg.String (fun s -> parameter_module := s),
+ "name parameter_module";
+ "md5sum", Arg.String (fun s -> md5sum := Some s),
+ "sum transfer MD5 checksum";
+ "whizard", Arg.Set whizard, " include WHIZARD interface";
+ "amp_triv", Arg.Set amp_triv, " only print trivial amplitude";
+ "no_write", Arg.Set no_write, " no 'write' statements";
+ "kmatrix_write", Arg.Set km_2_write, " write K matrix functions";
+ "kmatrix_2_write", Arg.Set km_write, " write K matrix 2 functions";
+ "kmatrix_write_pure", Arg.Set km_pure, " write K matrix pure functions";
+ "kmatrix_2_write_pure", Arg.Set km_2_pure, " write Kmatrix2pure functions";
+ "openmp", Arg.Set openmp, " activate OpenMP support in generated code"]
+
+(* Fortran style line continuation: *)
+ let nl = Format_Fortran.newline
+
+ let print_list = function
+ | [] -> ()
+ | a :: rest ->
+ print_string a;
+ List.iter (fun s -> printf ",@ %s" s) rest
+
+(* \thocwmodulesubsection{Variables and Declarations} *)
+
+ (* ["NC"] is already used up in the module ["constants"]: *)
+ let nc_parameter = "N_"
+ let omega_color_factor_abbrev = "OCF"
+ let openmp_tld_type = "thread_local_data"
+ let openmp_tld = "tld"
+
+ let flavors_symbol ?(decl = false) ?orders flavors =
+ let flavors_all_orders = List.map SCM.flavor_all_orders flavors in
+ let orders_tag =
+ match orders with
+ | None -> ""
+ | Some orders -> SCM.orders_symbol orders in
+ (if !openmp && not decl then openmp_tld ^ "%" else "" ) ^
+ "oks_" ^ String.concat "_" (List.map CM.flavor_symbol flavors_all_orders) ^ orders_tag
+
+ let p2s p =
+ if p >= 0 && p <= 9 then
+ string_of_int p
+ else if p <= 36 then
+ String.make 1 (Char.chr (Char.code 'A' + p - 10))
+ else
+ "_"
+
+ (* \begin{dubious}
+ There many similar functions for formatting momenta.
+ This is grown historically and should be cleaned up!
+ \end{dubious} *)
+
+ (* Prefix with a ["p"] to make a variable name holding a four momentum. *)
+ let format_momentum : int list -> string =
+ fun p ->
+ "p" ^ String.concat "" (List.map p2s p)
+
+ (* No prefix, to be used as part of a variable name holding a wavefunction. *)
+ let format_p : F.wf -> string =
+ fun wf ->
+ String.concat "" (List.map p2s (F.momentum_list wf))
+
+ let ext_momentum wf =
+ match F.momentum_list wf with
+ | [n] -> n
+ | _ -> invalid_arg "Targets.Fortran.ext_momentum"
+
+ module PSet = Set.Make (struct type t = int list let compare = compare end)
+ module WFSet = Set.Make (struct type t = F.wf let compare = compare end)
+
+ let variable ?(decl = false) wf =
+ (if !openmp && not decl then openmp_tld ^ "%" else "")
+ ^ "owf_" ^ SCM.flavor_symbol (F.flavor wf) ^ "_p" ^ format_p wf
+
+ let momentum wf = "p" ^ format_p wf
+ let spin wf = "s(" ^ string_of_int (ext_momentum wf) ^ ")"
+
+ let format_multiple_variable ?(decl = false) wf i =
+ variable ~decl wf ^ "_X" ^ string_of_int i
+
+ let multiple_variable ?(decl = false) amplitude dictionary wf =
+ try
+ format_multiple_variable ~decl wf (dictionary amplitude wf)
+ with
+ | Not_found -> variable wf
+
+ let multiple_variables ?(decl = false) multiplicity wf =
+ try
+ List.map
+ (format_multiple_variable ~decl wf)
+ (ThoList.range 1 (multiplicity wf))
+ with
+ | Not_found -> [variable ~decl wf]
+
+ let declaration_chunk_size = 64
+
+ let declare_list_chunk multiplicity t = function
+ | [] -> ()
+ | wfs ->
+ printf " @[<2>%s :: " t;
+ print_list (ThoList.flatmap (multiple_variables ~decl:true multiplicity) wfs); nl ()
+
+ let declare_list multiplicity t = function
+ | [] -> ()
+ | wfs ->
+ List.iter
+ (declare_list_chunk multiplicity t)
+ (ThoList.chopn declaration_chunk_size wfs)
+
+ type declarations =
+ { scalars : F.wf list;
+ spinors : F.wf list;
+ conjspinors : F.wf list;
+ realspinors : F.wf list;
+ ghostspinors : F.wf list;
+ vectorspinors : F.wf list;
+ vectors : F.wf list;
+ ward_vectors : F.wf list;
+ massive_vectors : F.wf list;
+ tensors_1 : F.wf list;
+ tensors_2 : F.wf list;
+ brs_scalars : F.wf list;
+ brs_spinors : F.wf list;
+ brs_conjspinors : F.wf list;
+ brs_realspinors : F.wf list;
+ brs_vectorspinors : F.wf list;
+ brs_vectors : F.wf list;
+ brs_massive_vectors : F.wf list }
+
+ let rec classify_wfs' acc = function
+ | [] -> acc
+ | wf :: rest ->
+ classify_wfs'
+ (match SCM.lorentz (F.flavor wf) with
+ | Scalar -> {acc with scalars = wf :: acc.scalars}
+ | Spinor -> {acc with spinors = wf :: acc.spinors}
+ | ConjSpinor -> {acc with conjspinors = wf :: acc.conjspinors}
+ | Majorana -> {acc with realspinors = wf :: acc.realspinors}
+ | Maj_Ghost -> {acc with ghostspinors = wf :: acc.ghostspinors}
+ | Vectorspinor ->
+ {acc with vectorspinors = wf :: acc.vectorspinors}
+ | Vector -> {acc with vectors = wf :: acc.vectors}
+(*i | Ward_Vector -> {acc with ward_vectors = wf :: acc.ward_vectors}
+i*)
+ | Massive_Vector ->
+ {acc with massive_vectors = wf :: acc.massive_vectors}
+ | Tensor_1 -> {acc with tensors_1 = wf :: acc.tensors_1}
+ | Tensor_2 -> {acc with tensors_2 = wf :: acc.tensors_2}
+ | BRS Scalar -> {acc with brs_scalars = wf :: acc.brs_scalars}
+ | BRS Spinor -> {acc with brs_spinors = wf :: acc.brs_spinors}
+ | BRS ConjSpinor -> {acc with brs_conjspinors =
+ wf :: acc.brs_conjspinors}
+ | BRS Majorana -> {acc with brs_realspinors =
+ wf :: acc.brs_realspinors}
+ | BRS Vectorspinor -> {acc with brs_vectorspinors =
+ wf :: acc.brs_vectorspinors}
+ | BRS Vector -> {acc with brs_vectors = wf :: acc.brs_vectors}
+ | BRS Massive_Vector -> {acc with brs_massive_vectors =
+ wf :: acc.brs_massive_vectors}
+ | BRS _ -> invalid_arg "Targets.wfs_classify': not needed here")
+ rest
+
+ let classify_wfs wfs = classify_wfs'
+ { scalars = []; spinors = []; conjspinors = []; realspinors = [];
+ ghostspinors = []; vectorspinors = []; vectors = [];
+ ward_vectors = [];
+ massive_vectors = []; tensors_1 = []; tensors_2 = [];
+ brs_scalars = [] ; brs_spinors = []; brs_conjspinors = [];
+ brs_realspinors = []; brs_vectorspinors = [];
+ brs_vectors = []; brs_massive_vectors = []}
+ wfs
+
+(* \thocwmodulesubsection{Parameters} *)
+
+ type 'a parameters =
+ { real_singles : 'a list;
+ real_arrays : ('a * int) list;
+ complex_singles : 'a list;
+ complex_arrays : ('a * int) list }
+
+ let rec classify_singles acc = function
+ | [] -> acc
+ | Real p :: rest -> classify_singles
+ { acc with real_singles = p :: acc.real_singles } rest
+ | Complex p :: rest -> classify_singles
+ { acc with complex_singles = p :: acc.complex_singles } rest
+
+ let rec classify_arrays acc = function
+ | [] -> acc
+ | (Real_Array p, rhs) :: rest -> classify_arrays
+ { acc with real_arrays =
+ (p, List.length rhs) :: acc.real_arrays } rest
+ | (Complex_Array p, rhs) :: rest -> classify_arrays
+ { acc with complex_arrays =
+ (p, List.length rhs) :: acc.complex_arrays } rest
+
+ let classify_parameters params =
+ classify_arrays
+ (classify_singles
+ { real_singles = [];
+ real_arrays = [];
+ complex_singles = [];
+ complex_arrays = [] }
+ (List.map fst params.derived)) params.derived_arrays
+
+ let schisma = ThoList.chopn
+
+ let schisma_num i n l =
+ ThoList.enumerate i (schisma n l)
+
+ let declare_parameters' t = function
+ | [] -> ()
+ | plist ->
+ printf " @[<2>%s(kind=%s), public, save :: " t !kind;
+ print_list (List.map SCM.constant_symbol plist); nl ()
+
+ let declare_parameters t plist =
+ List.iter (declare_parameters' t) plist
+
+ let declare_parameter_array t (p, n) =
+ printf " @[<2>%s(kind=%s), dimension(%d), public, save :: %s"
+ t !kind n (SCM.constant_symbol p); nl ()
+
+ (* NB: we use [string_of_float] to make sure that a decimal
+ point is included to make Fortran compilers happy. *)
+ let default_parameter (x, v) =
+ printf "@ %s = %s_%s" (SCM.constant_symbol x) (string_of_float v) !kind
+
+ let declare_default_parameters t = function
+ | [] -> ()
+ | p :: plist ->
+ printf " @[<2>%s(kind=%s), public, save ::" t !kind;
+ default_parameter p;
+ List.iter (fun p' -> printf ","; default_parameter p') plist;
+ nl ()
+
+ let format_constant = function
+ | I -> "(0,1)"
+ | Integer c ->
+ if c < 0 then
+ sprintf "(%d.0_%s)" c !kind
+ else
+ sprintf "%d.0_%s" c !kind
+ | Float x ->
+ if x < 0. then
+ "(" ^ string_of_float x ^ "_" ^ !kind ^ ")"
+ else
+ string_of_float x ^ "_" ^ !kind
+ | _ -> invalid_arg "format_constant"
+
+ let rec eval_parameter' = function
+ | (I | Integer _ | Float _) as c ->
+ printf "%s" (format_constant c)
+ | Atom x -> printf "%s" (SCM.constant_symbol x)
+ | Sum [] -> printf "0.0_%s" !kind
+ | Sum [x] -> eval_parameter' x
+ | Sum (x :: xs) ->
+ printf "@,("; eval_parameter' x;
+ List.iter (fun x -> printf "@, + "; eval_parameter' x) xs;
+ printf ")"
+ | Diff (x, y) ->
+ printf "@,("; eval_parameter' x;
+ printf " - "; eval_parameter' y; printf ")"
+ | Neg x -> printf "@,( - "; eval_parameter' x; printf ")"
+ | Prod [] -> printf "1.0_%s" !kind
+ | Prod [x] -> eval_parameter' x
+ | Prod (x :: xs) ->
+ printf "@,("; eval_parameter' x;
+ List.iter (fun x -> printf " * "; eval_parameter' x) xs;
+ printf ")"
+ | Quot (x, y) ->
+ printf "@,("; eval_parameter' x;
+ printf " / "; eval_parameter' y; printf ")"
+ | Rec x ->
+ printf "@, (1.0_%s / " !kind; eval_parameter' x; printf ")"
+ | Pow (x, n) ->
+ printf "@,("; eval_parameter' x;
+ if n < 0 then
+ printf "**(%d)" n
+ else
+ printf "**%d" n;
+ printf ")"
+ | PowX (x, y) ->
+ printf "@,("; eval_parameter' x;
+ printf "**"; eval_parameter' y; printf ")"
+ | Sqrt x -> printf "@,sqrt ("; eval_parameter' x; printf ")"
+ | Sin x -> printf "@,sin ("; eval_parameter' x; printf ")"
+ | Cos x -> printf "@,cos ("; eval_parameter' x; printf ")"
+ | Tan x -> printf "@,tan ("; eval_parameter' x; printf ")"
+ | Cot x -> printf "@,cot ("; eval_parameter' x; printf ")"
+ | Asin x -> printf "@,asin ("; eval_parameter' x; printf ")"
+ | Acos x -> printf "@,acos ("; eval_parameter' x; printf ")"
+ | Atan x -> printf "@,atan ("; eval_parameter' x; printf ")"
+ | Atan2 (y, x) -> printf "@,atan2 ("; eval_parameter' y;
+ printf ",@ "; eval_parameter' x; printf ")"
+ | Sinh x -> printf "@,sinh ("; eval_parameter' x; printf ")"
+ | Cosh x -> printf "@,cosh ("; eval_parameter' x; printf ")"
+ | Tanh x -> printf "@,tanh ("; eval_parameter' x; printf ")"
+ | Exp x -> printf "@,exp ("; eval_parameter' x; printf ")"
+ | Log x -> printf "@,log ("; eval_parameter' x; printf ")"
+ | Log10 x -> printf "@,log10 ("; eval_parameter' x; printf ")"
+ | Conj (Integer _ | Float _ as x) -> eval_parameter' x
+ | Conj x -> printf "@,cconjg ("; eval_parameter' x; printf ")"
+ | Abs x -> printf "@,abs ("; eval_parameter' x; printf ")"
+
+ let strip_single_tag = function
+ | Real x -> x
+ | Complex x -> x
+
+ let strip_array_tag = function
+ | Real_Array x -> x
+ | Complex_Array x -> x
+
+ let eval_parameter (lhs, rhs) =
+ let x = SCM.constant_symbol (strip_single_tag lhs) in
+ printf " @[<2>%s = " x; eval_parameter' rhs; nl ()
+
+ let eval_para_list n l =
+ printf " subroutine setup_parameters_%03d ()" n; nl ();
+ List.iter eval_parameter l;
+ printf " end subroutine setup_parameters_%03d" n; nl ()
+
+ let eval_parameter_pair (lhs, rhs) =
+ let x = SCM.constant_symbol (strip_array_tag lhs) in
+ let _ = List.fold_left (fun i rhs' ->
+ printf " @[<2>%s(%d) = " x i; eval_parameter' rhs'; nl ();
+ succ i) 1 rhs in
+ ()
+
+ let eval_para_pair_list n l =
+ printf " subroutine setup_parameters_%03d ()" n; nl ();
+ List.iter eval_parameter_pair l;
+ printf " end subroutine setup_parameters_%03d" n; nl ()
+
+ let print_echo fmt p =
+ let s = CM.constant_symbol p in
+ printf " write (unit = *, fmt = fmt_%s) \"%s\", %s"
+ fmt s s; nl ()
+
+ let print_echo_array fmt (p, n) =
+ let s = CM.constant_symbol p in
+ for i = 1 to n do
+ printf " write (unit = *, fmt = fmt_%s_array) " fmt ;
+ printf "\"%s\", %d, %s(%d)" s i s i; nl ()
+ done
+
+ let contains params couplings =
+ List.exists
+ (fun (name, _) -> List.mem (SCM.constant_symbol name) params)
+ couplings.input
+
+ let rec depends_on params = function
+ | I | Integer _ | Float _ -> false
+ | Atom name -> List.mem (SCM.constant_symbol name) params
+ | Sum es | Prod es ->
+ List.exists (depends_on params) es
+ | Diff (e1, e2) | Quot (e1, e2) | PowX (e1, e2) ->
+ depends_on params e1 || depends_on params e2
+ | Neg e | Rec e | Pow (e, _) ->
+ depends_on params e
+ | Sqrt e | Exp e | Log e | Log10 e
+ | Sin e | Cos e | Tan e | Cot e
+ | Asin e | Acos e | Atan e
+ | Sinh e | Cosh e | Tanh e
+ | Conj e | Abs e ->
+ depends_on params e
+ | Atan2 (e1, e2) ->
+ depends_on params e1 || depends_on params e2
+
+ let dependencies params couplings =
+ if contains params couplings then
+ List.rev
+ (fst (List.fold_left
+ (fun (deps, plist) (param, v) ->
+ match param with
+ | Real name | Complex name ->
+ if depends_on plist v then
+ ((param, v) :: deps, CM.constant_symbol name :: plist)
+ else
+ (deps, plist))
+ ([], params) couplings.derived))
+ else
+ []
+
+ let dependencies_arrays params couplings =
+ if contains params couplings then
+ List.rev
+ (fst (List.fold_left
+ (fun (deps, plist) (param, vlist) ->
+ match param with
+ | Real_Array name | Complex_Array name ->
+ if List.exists (depends_on plist) vlist then
+ ((param, vlist) :: deps,
+ CM.constant_symbol name :: plist)
+ else
+ (deps, plist))
+ ([], params) couplings.derived_arrays))
+ else
+ []
+
+ let parameters_to_fortran oc params =
+ Format_Fortran.set_formatter_out_channel ~width:!line_length oc;
+ let declarations = classify_parameters params in
+ printf "module %s" !parameter_module; nl ();
+ printf " use kinds"; nl ();
+ printf " use constants"; nl ();
+ printf " implicit none"; nl ();
+ printf " private"; nl ();
+ printf " @[<2>public :: setup_parameters";
+ printf ",@ import_from_whizard";
+ printf ",@ model_update_alpha_s";
+ if !no_write then begin
+ printf "! No print_parameters";
+ end else begin
+ printf ",@ print_parameters";
+ end; nl ();
+ declare_default_parameters "real" params.input;
+ declare_parameters "real" (schisma 69 declarations.real_singles);
+ List.iter (declare_parameter_array "real") declarations.real_arrays;
+ declare_parameters "complex" (schisma 69 declarations.complex_singles);
+ List.iter (declare_parameter_array "complex") declarations.complex_arrays;
+ printf " interface cconjg"; nl ();
+ printf " module procedure cconjg_real, cconjg_complex"; nl ();
+ printf " end interface"; nl ();
+ printf " private :: cconjg_real, cconjg_complex"; nl ();
+ printf "contains"; nl ();
+ printf " function cconjg_real (x) result (xc)"; nl ();
+ printf " real(kind=default), intent(in) :: x"; nl ();
+ printf " real(kind=default) :: xc"; nl ();
+ printf " xc = x"; nl ();
+ printf " end function cconjg_real"; nl ();
+ printf " function cconjg_complex (z) result (zc)"; nl ();
+ printf " complex(kind=default), intent(in) :: z"; nl ();
+ printf " complex(kind=default) :: zc"; nl ();
+ printf " zc = conjg (z)"; nl ();
+ printf " end function cconjg_complex"; nl ();
+ printf " ! derived parameters:"; nl ();
+ let shredded = schisma_num 1 120 params.derived in
+ let shredded_arrays = schisma_num 1 120 params.derived_arrays in
+ let num_sub = List.length shredded in
+ let num_sub_arrays = List.length shredded_arrays in
+ List.iter (fun (i,l) -> eval_para_list i l) shredded;
+ List.iter (fun (i,l) -> eval_para_pair_list (num_sub + i) l)
+ shredded_arrays;
+ printf " subroutine setup_parameters ()"; nl ();
+ for i = 1 to num_sub + num_sub_arrays do
+ printf " call setup_parameters_%03d ()" i; nl ();
+ done;
+ printf " end subroutine setup_parameters"; nl ();
+ printf " subroutine import_from_whizard (par_array, scheme)"; nl ();
+ printf
+ " real(%s), dimension(%d), intent(in) :: par_array"
+ !kind (List.length params.input); nl ();
+ printf " integer, intent(in) :: scheme"; nl ();
+ let i = ref 1 in
+ List.iter
+ (fun (p, _) ->
+ printf " %s = par_array(%d)" (SCM.constant_symbol p) !i; nl ();
+ incr i)
+ params.input;
+ printf " call setup_parameters ()"; nl ();
+ printf " end subroutine import_from_whizard"; nl ();
+ printf " subroutine model_update_alpha_s (alpha_s)"; nl ();
+ printf " real(%s), intent(in) :: alpha_s" !kind; nl ();
+ begin match (dependencies ["aS"] params,
+ dependencies_arrays ["aS"] params) with
+ | [], [] ->
+ printf " ! 'aS' not among the input parameters"; nl ();
+ | deps, deps_arrays ->
+ printf " aS = alpha_s"; nl ();
+ List.iter eval_parameter deps;
+ List.iter eval_parameter_pair deps_arrays
+ end;
+ printf " end subroutine model_update_alpha_s"; nl ();
+ if !no_write then begin
+ printf "! No print_parameters"; nl ();
+ end else begin
+ printf " subroutine print_parameters ()"; nl ();
+ printf " @[<2>character(len=*), parameter ::";
+ printf "@ fmt_real = \"(A12,4X,' = ',E25.18)\",";
+ printf "@ fmt_complex = \"(A12,4X,' = ',E25.18,' + i*',E25.18)\",";
+ printf "@ fmt_real_array = \"(A12,'(',I2.2,')',' = ',E25.18)\",";
+ printf "@ fmt_complex_array = ";
+ printf "\"(A12,'(',I2.2,')',' = ',E25.18,' + i*',E25.18)\""; nl ();
+ printf " @[<2>write (unit = *, fmt = \"(A)\") @,";
+ printf "\"default values for the input parameters:\""; nl ();
+ List.iter (fun (p, _) -> print_echo "real" p) params.input;
+ printf " @[<2>write (unit = *, fmt = \"(A)\") @,";
+ printf "\"derived parameters:\""; nl ();
+ List.iter (print_echo "real") declarations.real_singles;
+ List.iter (print_echo "complex") declarations.complex_singles;
+ List.iter (print_echo_array "real") declarations.real_arrays;
+ List.iter (print_echo_array "complex") declarations.complex_arrays;
+ printf " end subroutine print_parameters"; nl ();
+ end;
+ printf "end module %s" !parameter_module; nl ()
+
+(* \thocwmodulesubsection{Run-Time Diagnostics} *)
+
+ type diagnostic = All | Arguments | Momenta | Gauge
+
+ type diagnostic_mode = Off | Warn | Panic
+
+ let warn mode =
+ match !mode with
+ | Off -> false
+ | Warn -> true
+ | Panic -> true
+
+ let panic mode =
+ match !mode with
+ | Off -> false
+ | Warn -> false
+ | Panic -> true
+
+ let suffix mode =
+ if panic mode then
+ "panic"
+ else
+ "warn"
+
+ let diagnose_arguments = ref Off
+ let diagnose_momenta = ref Off
+ let diagnose_gauge = ref Off
+
+ let rec parse_diagnostic = function
+ | All, panic ->
+ parse_diagnostic (Arguments, panic);
+ parse_diagnostic (Momenta, panic);
+ parse_diagnostic (Gauge, panic)
+ | Arguments, panic ->
+ diagnose_arguments := if panic then Panic else Warn
+ | Momenta, panic ->
+ diagnose_momenta := if panic then Panic else Warn
+ | Gauge, panic ->
+ diagnose_gauge := if panic then Panic else Warn
+
+(* If diagnostics are required, we have to switch off
+ Fortran95 features like pure functions. *)
+
+ let parse_diagnostics = function
+ | [] -> ()
+ | diagnostics ->
+ fortran95 := false;
+ List.iter parse_diagnostic diagnostics
+
+(* \thocwmodulesubsection{Amplitude} *)
+
+ let declare_momenta_chunk = function
+ | [] -> ()
+ | momenta ->
+ printf " @[<2>type(momentum) :: ";
+ print_list (List.map format_momentum momenta); nl ()
+
+ let declare_momenta = function
+ | [] -> ()
+ | momenta ->
+ List.iter
+ declare_momenta_chunk
+ (ThoList.chopn declaration_chunk_size momenta)
+
+ let declare_wavefunctions multiplicity wfs =
+ let wfs' = classify_wfs wfs in
+ declare_list multiplicity ("complex(kind=" ^ !kind ^ ")")
+ (wfs'.scalars @ wfs'.brs_scalars);
+ declare_list multiplicity ("type(" ^ Names.psi_type ^ ")")
+ (wfs'.spinors @ wfs'.brs_spinors);
+ declare_list multiplicity ("type(" ^ Names.psibar_type ^ ")")
+ (wfs'.conjspinors @ wfs'.brs_conjspinors);
+ declare_list multiplicity ("type(" ^ Names.chi_type ^ ")")
+ (wfs'.realspinors @ wfs'.brs_realspinors @ wfs'.ghostspinors);
+ declare_list multiplicity ("type(" ^ Names.grav_type ^ ")") wfs'.vectorspinors;
+ declare_list multiplicity "type(vector)" (wfs'.vectors @ wfs'.massive_vectors @
+ wfs'.brs_vectors @ wfs'.brs_massive_vectors @ wfs'.ward_vectors);
+ declare_list multiplicity "type(tensor2odd)" wfs'.tensors_1;
+ declare_list multiplicity "type(tensor)" wfs'.tensors_2
+
+ let flavors a = F.incoming a @ F.outgoing a
+
+ let declare_brakets_chunk = function
+ | [] -> ()
+ | amplitudes ->
+ printf " @[<2>complex(kind=%s) :: " !kind;
+ print_list (List.map (fun a -> flavors_symbol ~decl:true (flavors a)) amplitudes); nl ()
+
+ let declare_brakets = function
+ | [] -> ()
+ | amplitudes ->
+ List.iter
+ declare_brakets_chunk
+ (ThoList.chopn declaration_chunk_size amplitudes)
+
+ let print_variable_declarations amplitudes =
+ let multiplicity = CF.multiplicity amplitudes
+ and processes = CF.processes amplitudes in
+ if not !amp_triv then begin
+ declare_momenta
+ (PSet.elements
+ (List.fold_left
+ (fun set a ->
+ PSet.union set (List.fold_right
+ (fun wf -> PSet.add (F.momentum_list wf))
+ (F.externals a) PSet.empty))
+ PSet.empty processes));
+ declare_momenta
+ (PSet.elements
+ (List.fold_left
+ (fun set a ->
+ PSet.union set (List.fold_right
+ (fun wf -> PSet.add (F.momentum_list wf))
+ (F.variables a) PSet.empty))
+ PSet.empty processes));
+ if !openmp then begin
+ printf " type %s@[<2>" openmp_tld_type;
+ nl ();
+ end ;
+ declare_wavefunctions multiplicity
+ (WFSet.elements
+ (List.fold_left
+ (fun set a ->
+ WFSet.union set (List.fold_right WFSet.add (F.externals a) WFSet.empty))
+ WFSet.empty processes));
+ declare_wavefunctions multiplicity
+ (WFSet.elements
+ (List.fold_left
+ (fun set a ->
+ WFSet.union set (List.fold_right WFSet.add (F.variables a) WFSet.empty))
+ WFSet.empty processes));
+ declare_brakets processes;
+ if !openmp then begin
+ printf "@] end type %s\n" openmp_tld_type;
+ printf " type(%s) :: %s" openmp_tld_type openmp_tld;
+ nl ();
+ end;
+ end
+
+(* [print_current] is the most important function that has to match the functions
+ in \verb+omega95+ (see appendix~\ref{sec:fortran}). It offers plentiful
+ opportunities for making mistakes, in particular those related to signs.
+ We start with a few auxiliary functions: *)
+
+ let children2 rhs =
+ match F.children rhs with
+ | [wf1; wf2] -> (wf1, wf2)
+ | _ -> failwith "Targets.children2: can't happen"
+
+ let children3 rhs =
+ match F.children rhs with
+ | [wf1; wf2; wf3] -> (wf1, wf2, wf3)
+ | _ -> invalid_arg "Targets.children3: can't happen"
+
+ let print_current amplitude dictionary rhs =
+ let module Vintage = Targets_vintage.Make_Fortran(Names)(Vintage_Fermions)(Fusion_Maker)(P)(M) in
+ match F.coupling rhs with
+ | V3 (vertex, fusion, constant) ->
+ Vintage.print_current_V3 multiple_variable momentum amplitude dictionary rhs vertex fusion constant
+ | V4 (vertex, fusion, constant) ->
+ Vintage.print_current_V4 multiple_variable momentum amplitude dictionary rhs vertex fusion constant
+
+ (* \begin{dubious}
+ This reproduces the hack on page~\pageref{hack:sign(V4)}
+ and gives the correct results up to quartic vertices.
+ Make sure that it is also correct in light
+ of~\eqref{eq:factors-of-i}, i.\,e.
+ \begin{equation*}
+ \ii T = \ii^{\#\text{vertices}}\ii^{\#\text{propagators}} \cdots
+ = \ii^{n-2}\ii^{n-3} \cdots
+ = -\ii(-1)^n \cdots
+ \end{equation*}
+ \end{dubious} *)
+ | Vn (UFO (c, v, s, fl, color), fusion, constant) ->
+ if Birdtracks.is_unit color then
+ let g = CM.constant_symbol constant
+ and chn = F.children rhs in
+ let wfs = List.map (multiple_variable amplitude dictionary) chn
+ and ps = List.map momentum chn in
+ let n = List.length fusion in
+ let eps = if n mod 2 = 0 then -1 else 1 in
+ printf "@, %s " (if (eps * F.sign rhs) < 0 then "-" else "+");
+ UFO.Targets.Fortran.fuse c v s fl g wfs ps fusion
+ else
+ failwith "print_current: nontrivial color structure"
+
+ let print_propagator f p m gamma =
+ let minus_third = "(-1.0_" ^ !kind ^ "/3.0_" ^ !kind ^ ")" in
+ let w =
+ begin match SCM.width f with
+ | Vanishing | Fudged -> "0.0_" ^ !kind
+ | Constant | Complex_Mass -> gamma
+ | Timelike -> "wd_tl(" ^ p ^ "," ^ gamma ^ ")"
+ | Running -> "wd_run(" ^ p ^ "," ^ m ^ "," ^ gamma ^ ")"
+ | Custom f -> f ^ "(" ^ p ^ "," ^ gamma ^ ")"
+ end in
+ let cms =
+ begin match SCM.width f with
+ | Complex_Mass -> ".true."
+ | _ -> ".false."
+ end in
+ match SCM.propagator f with
+ | Prop_Scalar ->
+ printf "pr_phi(%s,%s,%s," p m w
+ | Prop_Col_Scalar ->
+ printf "%s * pr_phi(%s,%s,%s," minus_third p m w
+ | Prop_Ghost -> printf "(0,1) * pr_phi(%s, %s, %s," p m w
+ | Prop_Spinor ->
+ printf "%s(%s,%s,%s,%s," Names.psi_propagator p m w cms
+ | Prop_ConjSpinor ->
+ printf "%s(%s,%s,%s,%s," Names.psibar_propagator p m w cms
+ | Prop_Majorana ->
+ printf "%s(%s,%s,%s,%s," Names.chi_propagator p m w cms
+ | Prop_Col_Majorana ->
+ printf "%s * %s(%s,%s,%s,%s," minus_third Names.chi_propagator p m w cms
+ | Prop_Unitarity ->
+ printf "pr_unitarity(%s,%s,%s,%s," p m w cms
+ | Prop_Col_Unitarity ->
+ printf "%s * pr_unitarity(%s,%s,%s,%s," minus_third p m w cms
+ | Prop_Feynman ->
+ printf "pr_feynman(%s," p
+ | Prop_Col_Feynman ->
+ printf "%s * pr_feynman(%s," minus_third p
+ | Prop_Gauge xi ->
+ printf "pr_gauge(%s,%s," p (SCM.gauge_symbol xi)
+ | Prop_Rxi xi ->
+ printf "pr_rxi(%s,%s,%s,%s," p m w (SCM.gauge_symbol xi)
+ | Prop_Tensor_2 ->
+ printf "pr_tensor(%s,%s,%s," p m w
+ | Prop_Tensor_pure ->
+ printf "pr_tensor_pure(%s,%s,%s," p m w
+ | Prop_Vector_pure ->
+ printf "pr_vector_pure(%s,%s,%s," p m w
+ | Prop_Vectorspinor ->
+ printf "pr_grav(%s,%s,%s," p m w
+ | Aux_Scalar | Aux_Spinor | Aux_ConjSpinor | Aux_Majorana
+ | Aux_Vector | Aux_Tensor_1 -> printf "("
+ | Aux_Col_Scalar | Aux_Col_Vector | Aux_Col_Tensor_1 -> printf "%s * (" minus_third
+ | Only_Insertion -> printf "("
+ | Prop_UFO name ->
+ printf "pr_U_%s(%s,%s,%s," name p m w
+
+ let print_projector f p m gamma =
+ let minus_third = "(-1.0_" ^ !kind ^ "/3.0_" ^ !kind ^ ")" in
+ match SCM.propagator f with
+ | Prop_Scalar ->
+ printf "pj_phi(%s,%s," m gamma
+ | Prop_Col_Scalar ->
+ printf "%s * pj_phi(%s,%s," minus_third m gamma
+ | Prop_Ghost ->
+ printf "(0,1) * pj_phi(%s,%s," m gamma
+ | Prop_Spinor ->
+ printf "%s(%s,%s,%s," Names.psi_projector p m gamma
+ | Prop_ConjSpinor ->
+ printf "%s(%s,%s,%s," Names.psibar_projector p m gamma
+ | Prop_Majorana ->
+ printf "%s(%s,%s,%s," Names.chi_projector p m gamma
+ | Prop_Col_Majorana ->
+ printf "%s * %s(%s,%s,%s," minus_third Names.chi_projector p m gamma
+ | Prop_Unitarity ->
+ printf "pj_unitarity(%s,%s,%s," p m gamma
+ | Prop_Col_Unitarity ->
+ printf "%s * pj_unitarity(%s,%s,%s," minus_third p m gamma
+ | Prop_Feynman | Prop_Col_Feynman ->
+ invalid_arg "no on-shell Feynman propagator!"
+ | Prop_Gauge _ ->
+ invalid_arg "no on-shell massless gauge propagator!"
+ | Prop_Rxi _ ->
+ invalid_arg "no on-shell Rxi propagator!"
+ | Prop_Vectorspinor ->
+ printf "pj_grav(%s,%s,%s," p m gamma
+ | Prop_Tensor_2 ->
+ printf "pj_tensor(%s,%s,%s," p m gamma
+ | Prop_Tensor_pure ->
+ invalid_arg "no on-shell pure Tensor propagator!"
+ | Prop_Vector_pure ->
+ invalid_arg "no on-shell pure Vector propagator!"
+ | Aux_Scalar | Aux_Spinor | Aux_ConjSpinor | Aux_Majorana
+ | Aux_Vector | Aux_Tensor_1 -> printf "("
+ | Aux_Col_Scalar | Aux_Col_Vector | Aux_Col_Tensor_1 -> printf "%s * (" minus_third
+ | Only_Insertion -> printf "("
+ | Prop_UFO name ->
+ invalid_arg "no on shell UFO propagator"
+
+ let print_gauss f p m gamma =
+ let minus_third = "(-1.0_" ^ !kind ^ "/3.0_" ^ !kind ^ ")" in
+ match SCM.propagator f with
+ | Prop_Scalar ->
+ printf "pg_phi(%s,%s,%s," p m gamma
+ | Prop_Ghost ->
+ printf "(0,1) * pg_phi(%s,%s,%s," p m gamma
+ | Prop_Spinor ->
+ printf "%s(%s,%s,%s," Names.psi_projector p m gamma
+ | Prop_ConjSpinor ->
+ printf "%s(%s,%s,%s," Names.psibar_projector p m gamma
+ | Prop_Majorana ->
+ printf "%s(%s,%s,%s," Names.chi_projector p m gamma
+ | Prop_Col_Majorana ->
+ printf "%s * %s(%s,%s,%s," minus_third Names.chi_projector p m gamma
+ | Prop_Unitarity ->
+ printf "pg_unitarity(%s,%s,%s," p m gamma
+ | Prop_Feynman | Prop_Col_Feynman ->
+ invalid_arg "no on-shell Feynman propagator!"
+ | Prop_Gauge _ ->
+ invalid_arg "no on-shell massless gauge propagator!"
+ | Prop_Rxi _ ->
+ invalid_arg "no on-shell Rxi propagator!"
+ | Prop_Tensor_2 ->
+ printf "pg_tensor(%s,%s,%s," p m gamma
+ | Prop_Tensor_pure ->
+ invalid_arg "no pure tensor propagator!"
+ | Prop_Vector_pure ->
+ invalid_arg "no pure vector propagator!"
+ | Aux_Scalar | Aux_Spinor | Aux_ConjSpinor | Aux_Majorana
+ | Aux_Vector | Aux_Tensor_1 -> printf "("
+ | Only_Insertion -> printf "("
+ | Prop_UFO name ->
+ invalid_arg "no UFO gauss insertion"
+ | _ -> invalid_arg "targets:print_gauss: not available"
+
+ let print_fusion_diagnostics amplitude dictionary fusion =
+ if warn diagnose_gauge then begin
+ let lhs = F.lhs fusion in
+ let f = F.flavor lhs
+ and v = variable lhs
+ and p = momentum lhs in
+ let mass = SCM.mass_symbol f in
+ match SCM.propagator f with
+ | Prop_Gauge _ | Prop_Feynman
+ | Prop_Rxi _ | Prop_Unitarity ->
+ printf " @[<2>%s =" v;
+ List.iter (print_current amplitude dictionary) (F.rhs fusion); nl ();
+ begin match SCM.goldstone f with
+ | None ->
+ printf " call omega_ward_%s(\"%s\",%s,%s,%s)"
+ (suffix diagnose_gauge) v mass p v; nl ()
+ | Some (g, phase) ->
+ let gv = SCM.flavor_symbol g ^ "_" ^ format_p lhs in
+ printf " call omega_slavnov_%s"
+ (suffix diagnose_gauge);
+ printf "(@[\"%s\",%s,%s,%s,@,%s*%s)"
+ v mass p v (format_constant phase) gv; nl ()
+ end
+ | _ -> ()
+ end
+
+ let print_fusion amplitude dictionary fusion =
+ let lhs = F.lhs fusion in
+ let f = F.flavor lhs in
+ printf " @[<2>%s =@, " (multiple_variable amplitude dictionary lhs);
+ if F.on_shell amplitude lhs then
+ print_projector f (momentum lhs)
+ (SCM.mass_symbol f) (SCM.width_symbol f)
+ else
+ if F.is_gauss amplitude lhs then
+ print_gauss f (momentum lhs)
+ (SCM.mass_symbol f) (SCM.width_symbol f)
+ else
+ print_propagator f (momentum lhs)
+ (SCM.mass_symbol f) (SCM.width_symbol f);
+ List.iter (print_current amplitude dictionary) (F.rhs fusion);
+ printf ")"; nl ()
+
+ let print_momenta seen_momenta amplitude =
+ List.fold_left (fun seen f ->
+ let wf = F.lhs f in
+ let p = F.momentum_list wf in
+ if not (PSet.mem p seen) then begin
+ let rhs1 = List.hd (F.rhs f) in
+ printf " %s = %s" (momentum wf)
+ (String.concat " + "
+ (List.map momentum (F.children rhs1))); nl ()
+ end;
+ PSet.add p seen)
+ seen_momenta (F.fusions amplitude)
+
+ let print_fusions dictionary fusions =
+ List.iter
+ (fun (f, amplitude) ->
+ print_fusion_diagnostics amplitude dictionary f;
+ print_fusion amplitude dictionary f)
+ fusions
+
+(* \begin{dubious}
+ The following will need a bit more work, because
+ the decision when to [reverse_braket] for UFO models
+ with Majorana fermions needs collaboration
+ from [UFO.Targets.Fortran.fuse] which is called by
+ [print_current]. See the function
+ [UFO_targets.Fortran.jrr_print_majorana_current_transposing]
+ for illustration (the function is never used and only for
+ documentation).
+ \end{dubious} *)
+
+ let spins_of_rhs rhs =
+ List.map (fun wf -> SCM.lorentz (F.flavor wf)) (F.children rhs)
+
+ let spins_of_ket ket =
+ match ThoList.uniq (List.map spins_of_rhs ket) with
+ | [spins] -> spins
+ | [] -> failwith "Targets.Fortran.spins_of_ket: empty"
+ | _ -> [] (* HACK! *)
+
+ let print_braket amplitude dictionary name braket =
+ let bra = F.bra braket
+ and ket = F.ket braket in
+ let spin_bra = SCM.lorentz (F.flavor bra)
+ and spins_ket = spins_of_ket ket in
+ let vintage = true (* [F.vintage] *) in
+ printf " @[<2>%s =@ %s@, + " name name;
+ if Fermions.reverse_braket vintage spin_bra spins_ket then
+ begin
+ printf "@,(";
+ List.iter (print_current amplitude dictionary) ket;
+ printf ")*%s" (multiple_variable amplitude dictionary bra)
+ end
+ else
+ begin
+ printf "%s*@,(" (multiple_variable amplitude dictionary bra);
+ List.iter (print_current amplitude dictionary) ket;
+ printf ")"
+ end;
+ nl ()
+
+(* \begin{equation}
+ \label{eq:factors-of-i}
+ \ii T = \ii^{\#\text{vertices}}\ii^{\#\text{propagators}} \cdots
+ = \ii^{n-2}\ii^{n-3} \cdots
+ = -\ii(-1)^n \cdots
+ \end{equation} *)
+
+(* \begin{dubious}
+ [tho:] we write some brakets twice using different names. Is it useful
+ to cache them?
+ \end{dubious} *)
+
+ let print_braket_slice ?orders dictionary amplitude brakets =
+ let name = flavors_symbol ?orders (flavors amplitude) in
+ printf " %s = 0" name; nl ();
+ List.iter (print_braket amplitude dictionary name) brakets;
+ let n = List.length (F.externals amplitude) in
+ if n mod 2 = 0 then begin
+ printf " @[<2>%s =@, - %s ! %d vertices, %d propagators"
+ name name (n - 2) (n - 3); nl ()
+ end else begin
+ printf " ! %s = %s ! %d vertices, %d propagators"
+ name name (n - 2) (n - 3); nl ()
+ end;
+ let s = F.symmetry amplitude in
+ if s > 1 then
+ printf " @[<2>%s =@, %s@, / sqrt(%d.0_%s) ! symmetry factor" name name s !kind
+ else
+ printf " ! unit symmetry factor";
+ nl ()
+
+ let print_brakets dictionary amplitude =
+ match F.brakets amplitude with
+ |[([], brakets)] -> print_braket_slice dictionary amplitude brakets
+ |[(orders, brakets)] ->
+ Printf.eprintf "omega: implementation of coupling order slices not complete yet!\n";
+ print_braket_slice ~orders dictionary amplitude brakets
+ | slices ->
+ Printf.eprintf "omega: implementation of coupling order slices not complete yet!\n";
+ List.iter
+ (fun (orders, brakets) -> print_braket_slice ~orders dictionary amplitude brakets)
+ slices
+
+ let print_incoming wf =
+ let p = momentum wf
+ and s = spin wf
+ and f = F.flavor wf in
+ let m = SCM.mass_symbol f in
+ match SCM.lorentz f with
+ | Scalar -> printf "1"
+ | BRS Scalar -> printf "(0,-1) * (%s * %s - %s**2)" p p m
+ | Spinor ->
+ printf "%s (%s, - %s, %s)" Names.psi_incoming m p s
+ | BRS Spinor ->
+ printf "%s (%s, - %s, %s)" Names.brs_psi_incoming m p s
+ | ConjSpinor ->
+ printf "%s (%s, - %s, %s)" Names.psibar_incoming m p s
+ | BRS ConjSpinor ->
+ printf "%s (%s, - %s, %s)" Names.brs_psibar_incoming m p s
+ | Majorana ->
+ printf "%s (%s, - %s, %s)" Names.chi_incoming m p s
+ | Maj_Ghost -> printf "ghost (%s, - %s, %s)" m p s
+ | BRS Majorana ->
+ printf "%s (%s, - %s, %s)" Names.brs_chi_incoming m p s
+ | Vector | Massive_Vector ->
+ printf "eps (%s, - %s, %s)" m p s
+(*i | Ward_Vector -> printf "%s" p i*)
+ | BRS Vector | BRS Massive_Vector -> printf
+ "(0,1) * (%s * %s - %s**2) * eps (%s, -%s, %s)" p p m m p s
+ | Vectorspinor | BRS Vectorspinor ->
+ printf "%s (%s, - %s, %s)" Names.grav_incoming m p s
+ | Tensor_1 -> invalid_arg "Tensor_1 only internal"
+ | Tensor_2 -> printf "eps2 (%s, - %s, %s)" m p s
+ | _ -> invalid_arg "no such BRST transformations"
+
+ let print_outgoing wf =
+ let p = momentum wf
+ and s = spin wf
+ and f = F.flavor wf in
+ let m = SCM.mass_symbol f in
+ match SCM.lorentz f with
+ | Scalar -> printf "1"
+ | BRS Scalar -> printf "(0,-1) * (%s * %s - %s**2)" p p m
+ | Spinor ->
+ printf "%s (%s, %s, %s)" Names.psi_outgoing m p s
+ | BRS Spinor ->
+ printf "%s (%s, %s, %s)" Names.brs_psi_outgoing m p s
+ | ConjSpinor ->
+ printf "%s (%s, %s, %s)" Names.psibar_outgoing m p s
+ | BRS ConjSpinor ->
+ printf "%s (%s, %s, %s)" Names.brs_psibar_outgoing m p s
+ | Majorana ->
+ printf "%s (%s, %s, %s)" Names.chi_outgoing m p s
+ | BRS Majorana ->
+ printf "%s (%s, %s, %s)" Names.brs_chi_outgoing m p s
+ | Maj_Ghost -> printf "ghost (%s, %s, %s)" m p s
+ | Vector | Massive_Vector ->
+ printf "conjg (eps (%s, %s, %s))" m p s
+(*i | Ward_Vector -> printf "%s" p i*)
+ | BRS Vector | BRS Massive_Vector -> printf
+ "(0,1) * (%s*%s-%s**2) * (conjg (eps (%s, %s, %s)))" p p m m p s
+ | Vectorspinor | BRS Vectorspinor ->
+ printf "%s (%s, %s, %s)" Names.grav_incoming m p s
+ | Tensor_1 -> invalid_arg "Tensor_1 only internal"
+ | Tensor_2 -> printf "conjg (eps2 (%s, %s, %s))" m p s
+ | BRS _ -> invalid_arg "no such BRST transformations"
+
+ let print_external_momenta amplitude =
+ let externals =
+ List.combine
+ (F.externals amplitude)
+ (List.map (fun _ -> true) (F.incoming amplitude) @
+ List.map (fun _ -> false) (F.outgoing amplitude)) in
+ List.iter (fun (wf, incoming) ->
+ if incoming then
+ printf " %s = - k(:,%d) ! incoming"
+ (momentum wf) (ext_momentum wf)
+ else
+ printf " %s = k(:,%d) ! outgoing"
+ (momentum wf) (ext_momentum wf); nl ()) externals
+
+ let print_externals seen_wfs amplitude =
+ let externals =
+ List.combine
+ (F.externals amplitude)
+ (List.map (fun _ -> true) (F.incoming amplitude) @
+ List.map (fun _ -> false) (F.outgoing amplitude)) in
+ List.fold_left (fun seen (wf, incoming) ->
+ if not (WFSet.mem wf seen) then begin
+ printf " @[<2>%s =@, " (variable wf);
+ (if incoming then print_incoming else print_outgoing) wf; nl ()
+ end;
+ WFSet.add wf seen) seen_wfs externals
+
+ let flavors_to_string flavors =
+ String.concat " " (List.map (fun f -> CM.flavor_to_string (SCM.flavor_all_orders f)) flavors)
+
+ let process_to_string amplitude =
+ flavors_to_string (F.incoming amplitude) ^ " -> " ^
+ flavors_to_string (F.outgoing amplitude)
+
+ let flavors_sans_color_to_string flavors =
+ String.concat " " (List.map M.flavor_to_string flavors)
+
+ let process_sans_color_to_string (fin, fout) =
+ flavors_sans_color_to_string fin ^ " -> " ^
+ flavors_sans_color_to_string fout
+
+ let print_fudge_factor amplitude =
+ let name = flavors_symbol (flavors amplitude) in
+ List.iter (fun wf ->
+ let p = momentum wf
+ and f = F.flavor wf in
+ match SCM.width f with
+ | Fudged ->
+ let m = SCM.mass_symbol f
+ and w = SCM.width_symbol f in
+ printf " if (%s > 0.0_%s) then" w !kind; nl ();
+ printf " @[<2>%s = %s@ * (%s*%s - %s**2)"
+ name name p p m;
+ printf "@ / cmplx (%s*%s - %s**2, %s*%s, kind=%s)"
+ p p m m w !kind; nl ();
+ printf " end if"; nl ()
+ | _ -> ()) (F.s_channel amplitude)
+
+ let num_helicities amplitudes =
+ List.length (CF.helicities amplitudes)
+
+ let num_coupling_orders amplitudes =
+ match CF.coupling_orders amplitudes with
+ | None -> 0
+ | Some (co_list, _) -> List.length co_list
+
+ let num_coupling_order_powers amplitudes =
+ match CF.coupling_orders amplitudes with
+ | None -> 0
+ | Some (_, powers) -> List.length powers
+
+(* \thocwmodulesubsection{Spin, Flavor \&\ Color Tables} *)
+
+(* The following abomination is required to keep the number of continuation
+ lines as low as possible. FORTRAN77-style \texttt{DATA} statements
+ are actually a bit nicer here, but they are not available for
+ \emph{constant} arrays. *)
+
+(* \begin{dubious}
+ We used to have a more elegant design with a sentinel~0 added to each
+ initializer, but some revisions of the Compaq/Digital Compiler have a
+ bug that causes them to reject this variant.
+ \end{dubious} *)
+
+(* \begin{dubious}
+ The actual table writing code using \texttt{reshape} should be factored,
+ since it's the same algorithm every time.
+ \end{dubious} *)
+
+ let print_integer_parameter name value =
+ printf " @[<2>integer, parameter :: %s = %d" name value; nl ()
+
+ let print_real_parameter name value =
+ printf " @[<2>real(kind=%s), parameter :: %s = %d"
+ !kind name value; nl ()
+
+ let print_logical_parameter name value =
+ printf " @[<2>logical, parameter :: %s = .%s."
+ name (if value then "true" else "false"); nl ()
+
+ let num_particles_in amplitudes =
+ match CF.flavors amplitudes with
+ | [] -> 0
+ | (fin, _) :: _ -> List.length fin
+
+ let num_particles_out amplitudes =
+ match CF.flavors amplitudes with
+ | [] -> 0
+ | (_, fout) :: _ -> List.length fout
+
+ let num_particles amplitudes =
+ match CF.flavors amplitudes with
+ | [] -> 0
+ | (fin, fout) :: _ -> List.length fin + List.length fout
+
+ module CFlow = Color.Flow
+
+ let num_color_flows amplitudes =
+ if !amp_triv then
+ 1
+ else
+ List.length (CF.color_flows amplitudes)
+
+ let num_color_indices_default = 2 (* Standard model *)
+
+ let num_color_indices amplitudes =
+ try CFlow.rank (List.hd (CF.color_flows amplitudes)) with _ -> num_color_indices_default
+
+ let color_to_string c =
+ "(" ^ (String.concat "," (List.map (Printf.sprintf "%3d") c)) ^ ")"
+
+ let cflow_to_string cflow =
+ String.concat " " (List.map color_to_string (CFlow.in_to_lists cflow)) ^ " -> " ^
+ String.concat " " (List.map color_to_string (CFlow.out_to_lists cflow))
+
+ let protected = ", protected" (* Fortran 2003! *)
+
+ let print_coupling_orders_table amplitudes =
+ printf " @[<2>integer, dimension(n_co,n_cop), save%s :: table_coupling_orders" protected; nl ();
+ begin match CF.coupling_orders amplitudes with
+ | None | Some (_, []) -> ()
+ | Some (_, powers) ->
+ List.iteri
+ (fun i powers ->
+ printf " @[<2>data table_coupling_orders(:,%4d) / %s /" (succ i)
+ (String.concat ", " (List.map (Printf.sprintf "%2d") powers));
+ nl ())
+ powers
+ end;
+ nl ()
+
+ let print_spin_table name tuples =
+ printf " @[<2>integer, dimension(n_prt,n_hel), save%s :: table_spin_%s"
+ protected name; nl ();
+ match tuples with
+ | [] -> ()
+ | _ ->
+ List.iteri
+ (fun i (tuple1, tuple2) ->
+ printf " @[<2>data table_spin_%s(:,%4d) / %s /" name (succ i)
+ (String.concat ", " (List.map (Printf.sprintf "%2d") (tuple1 @ tuple2)));
+ nl ())
+ tuples
+
+ let print_spin_tables amplitudes =
+ print_spin_table "states" (CF.helicities amplitudes);
+ nl ()
+
+ let print_flavor_table name tuples =
+ printf " @[<2>integer, dimension(n_prt,n_flv), save%s :: table_flavor_%s"
+ protected name; nl ();
+ match tuples with
+ | [] -> ()
+ | _ ->
+ List.iteri
+ (fun i tuple ->
+ printf " @[<2>data table_flavor_%s(:,%4d) / %s / ! %s" name (succ i)
+ (String.concat ", "
+ (List.map (fun f -> Printf.sprintf "%3d" (M.pdg f)) tuple))
+ (String.concat " " (List.map M.flavor_to_string tuple));
+ nl ())
+ tuples
+
+ let print_flavor_tables amplitudes =
+ print_flavor_table "states"
+ (List.map (fun (fin, fout) -> fin @ fout) (CF.flavors amplitudes));
+ nl ()
+
+ let num_flavors amplitudes =
+ List.length (CF.flavors amplitudes)
+
+ let print_color_flows_table tuples =
+ if !amp_triv then begin
+ printf
+ " @[<2>integer, dimension(n_cindex,n_prt,n_cflow), save%s :: table_color_flows = 0"
+ protected; nl ();
+ end
+ else begin
+ printf
+ " @[<2>integer, dimension(n_cindex,n_prt,n_cflow), save%s :: table_color_flows"
+ protected; nl ();
+ end;
+ if not !amp_triv then begin
+ match tuples with
+ | [] -> ()
+ | _ :: _ as tuples ->
+ List.iteri
+ (fun i tuple ->
+ begin match CFlow.to_lists tuple with
+ | [] -> ()
+ | cf1 :: cfn ->
+ printf " @[<2>data table_color_flows(:,:,%4d) /" (succ i);
+ printf "@ %s" (String.concat "," (List.map string_of_int cf1));
+ List.iter (fun cf -> printf ",@ %s" (String.concat "," (List.map string_of_int cf))) cfn;
+ printf "@ /"; nl ()
+ end)
+ tuples
+ end
+
+ let print_ghost_flags_table tuples =
+ if !amp_triv then begin
+ printf
+ " @[<2>logical, dimension(n_prt,n_cflow), save%s :: table_ghost_flags = F"
+ protected; nl ();
+ end
+ else begin
+ printf
+ " @[<2>logical, dimension(n_prt,n_cflow), save%s :: table_ghost_flags"
+ protected; nl ();
+ match tuples with
+ | [] -> ()
+ | _ ->
+ List.iteri
+ (fun i tuple ->
+ begin match CFlow.ghost_flags tuple with
+ | [] -> ()
+ | gf1 :: gfn ->
+ printf " @[<2>data table_ghost_flags(:,%4d) /" (succ i);
+ printf "@ %s" (if gf1 then "T" else "F");
+ List.iter (fun gf -> printf ",@ %s" (if gf then "T" else "F")) gfn;
+ printf " /";
+ nl ()
+ end)
+ tuples
+ end
+
+ let format_power_of x
+ { Color.Flow.num = num; Color.Flow.den = den; Color.Flow.power = pwr } =
+ match num, den, pwr with
+ | _, 0, _ -> invalid_arg "format_power_of: zero denominator"
+ | 0, _, _ -> "+zero"
+ | 1, 1, 0 | -1, -1, 0 -> "+one"
+ | -1, 1, 0 | 1, -1, 0 -> "-one"
+ | 1, 1, 1 | -1, -1, 1 -> "+" ^ x
+ | -1, 1, 1 | 1, -1, 1 -> "-" ^ x
+ | 1, 1, -1 | -1, -1, -1 -> "+1/" ^ x
+ | -1, 1, -1 | 1, -1, -1 -> "-1/" ^ x
+ | 1, 1, p | -1, -1, p ->
+ "+" ^ (if p > 0 then "" else "1/") ^ x ^ "**" ^ string_of_int (abs p)
+ | -1, 1, p | 1, -1, p ->
+ "-" ^ (if p > 0 then "" else "1/") ^ x ^ "**" ^ string_of_int (abs p)
+ | n, 1, 0 ->
+ (if n < 0 then "-" else "+") ^ string_of_int (abs n) ^ ".0_" ^ !kind
+ | n, d, 0 ->
+ (if n * d < 0 then "-" else "+") ^
+ string_of_int (abs n) ^ ".0_" ^ !kind ^ "/" ^
+ string_of_int (abs d)
+ | n, 1, 1 ->
+ (if n < 0 then "-" else "+") ^ string_of_int (abs n) ^ "*" ^ x
+ | n, 1, -1 ->
+ (if n < 0 then "-" else "+") ^ string_of_int (abs n) ^ "/" ^ x
+ | n, d, 1 ->
+ (if n * d < 0 then "-" else "+") ^
+ string_of_int (abs n) ^ ".0_" ^ !kind ^ "/" ^
+ string_of_int (abs d) ^ "*" ^ x
+ | n, d, -1 ->
+ (if n * d < 0 then "-" else "+") ^
+ string_of_int (abs n) ^ ".0_" ^ !kind ^ "/" ^
+ string_of_int (abs d) ^ "/" ^ x
+ | n, 1, p ->
+ (if n < 0 then "-" else "+") ^ string_of_int (abs n) ^
+ (if p > 0 then "*" else "/") ^ x ^ "**" ^ string_of_int (abs p)
+ | n, d, p ->
+ (if n * d < 0 then "-" else "+") ^
+ string_of_int (abs n) ^ ".0_" ^ !kind ^ "/" ^
+ string_of_int (abs d) ^
+ (if p > 0 then "*" else "/") ^ x ^ "**" ^ string_of_int (abs p)
+
+ let format_powers_of x = function
+ | [] -> "zero"
+ | powers -> String.concat "" (List.map (format_power_of x) powers)
+
+ (*i unused value
+ let print_color_factor_table_old table =
+ let n_cflow = Array.length table in
+ let n_cfactors = ref 0 in
+ for c1 = 0 to pred n_cflow do
+ for c2 = 0 to pred n_cflow do
+ match table.(c1).(c2) with
+ | [] -> ()
+ | _ -> incr n_cfactors
+ done
+ done;
+ print_integer_parameter "n_cfactors" !n_cfactors;
+ if n_cflow <= 0 then begin
+ printf " @[<2>type(%s), dimension(n_cfactors) ::"
+ omega_color_factor_abbrev;
+ printf "@ table_color_factors"; nl ()
+ end else begin
+ printf
+ " @[<2>type(%s), dimension(n_cfactors), parameter ::"
+ omega_color_factor_abbrev;
+ printf "@ table_color_factors = (/@ ";
+ let comma = ref "" in
+ for c1 = 0 to pred n_cflow do
+ for c2 = 0 to pred n_cflow do
+ match table.(c1).(c2) with
+ | [] -> ()
+ | cf ->
+ printf "%s@ %s(%d,%d,%s)" !comma omega_color_factor_abbrev
+ (succ c1) (succ c2) (format_powers_of nc_parameter cf);
+ comma := ","
+ done
+ done;
+ printf "@ /)"; nl ()
+ end
+ i*)
+
+(* \begin{dubious}
+ We can optimize the following slightly by reusing common color factor [parameter]s.
+ \end{dubious} *)
+
+ let print_color_factor_table table =
+ let n_cflow = Array.length table in
+ let n_cfactors = ref 0 in
+ for c1 = 0 to pred n_cflow do
+ for c2 = 0 to pred n_cflow do
+ match table.(c1).(c2) with
+ | [] -> ()
+ | _ -> incr n_cfactors
+ done
+ done;
+ print_integer_parameter "n_cfactors" !n_cfactors;
+ printf " @[<2>type(%s), dimension(n_cfactors), save%s ::"
+ omega_color_factor_abbrev protected;
+ printf "@ table_color_factors"; nl ();
+ if not !amp_triv then begin
+ let i = ref 1 in
+ if n_cflow > 0 then begin
+ for c1 = 0 to pred n_cflow do
+ for c2 = 0 to pred n_cflow do
+ match table.(c1).(c2) with
+ | [] -> ()
+ | cf ->
+ printf " @[<2>real(kind=%s), parameter, private :: color_factor_%06d = %s"
+ !kind !i (format_powers_of nc_parameter cf);
+ nl ();
+ printf " @[<2>data table_color_factors(%6d) / %s(%d,%d,color_factor_%06d) /"
+ !i omega_color_factor_abbrev (succ c1) (succ c2) !i;
+ incr i;
+ nl ();
+ done
+ done
+ end;
+ end
+
+ let print_color_tables amplitudes =
+ let cflows = CF.color_flows amplitudes
+ and cfactors = CF.color_factors amplitudes in
+ (* [print_color_flows_table_old "c" cflows; nl ();] *)
+ print_color_flows_table cflows; nl ();
+ (* [print_ghost_flags_table_old "g" cflows; nl ();] *)
+ print_ghost_flags_table cflows; nl ();
+ (* [print_color_factor_table_old cfactors; nl ();] *)
+ print_color_factor_table cfactors; nl ()
+
+ let option_to_logical = function
+ | Some _ -> "T"
+ | None -> "F"
+
+ (*i unused value
+ let print_flavor_color_table_old abbrev n_flv n_cflow table =
+ if n_flv <= 0 || n_cflow <= 0 then begin
+ printf " @[<2>logical, dimension(n_flv, n_cflow) ::";
+ printf "@ flv_col_is_allowed"; nl ()
+ end else begin
+ for c = 0 to pred n_cflow do
+ printf
+ " @[<2>logical, dimension(n_flv), parameter, private ::";
+ printf "@ %s%04d = (/@ %s" abbrev (succ c) (option_to_logical table.(0).(c));
+ for f = 1 to pred n_flv do
+ printf ",@ %s" (option_to_logical table.(f).(c))
+ done;
+ printf "@ /)"; nl ()
+ done;
+ printf
+ " @[<2>logical, dimension(n_flv, n_cflow), parameter ::";
+ printf "@ flv_col_is_allowed_old =@ reshape ( (/@ %s%04d" abbrev 1;
+ for c = 1 to pred n_cflow do
+ printf ",@ %s%04d" abbrev (succ c)
+ done;
+ printf "@ /),@ (/ n_flv, n_cflow /) )"; nl ()
+ end
+ i*)
+
+ let print_flavor_color_table n_flv n_cflow table =
+ if !amp_triv then begin
+ printf
+ " @[<2>logical, dimension(n_flv, n_cflow), save%s :: @ flv_col_is_allowed = T"
+ protected; nl ();
+ end
+ else begin
+ printf
+ " @[<2>logical, dimension(n_flv, n_cflow), save%s :: @ flv_col_is_allowed"
+ protected; nl ();
+ if n_flv > 0 then begin
+ for c = 0 to pred n_cflow do
+ printf
+ " @[<2>data flv_col_is_allowed(:,%4d) /" (succ c);
+ printf "@ %s" (option_to_logical table.(0).(c));
+ for f = 1 to pred n_flv do
+ printf ",@ %s" (option_to_logical table.(f).(c))
+ done;
+ printf "@ /"; nl ()
+ done;
+ end;
+ end
+
+ let print_amplitude_table a =
+ (* [print_flavor_color_table_old "a"
+ (num_flavors a) (List.length (CF.color_flows a)) (CF.process_table a);
+ nl ();] *)
+ print_flavor_color_table
+ (num_flavors a) (List.length (CF.color_flows a)) (CF.process_table a);
+ nl ();
+ printf
+ " @[<2>complex(kind=%s), dimension(n_flv, n_cflow, n_hel), save :: amp" !kind;
+ nl ();
+ nl ()
+
+ let print_helicity_selection_table () =
+ printf " @[<2>logical, dimension(n_hel), save :: ";
+ printf "hel_is_allowed = T"; nl ();
+ printf " @[<2>real(kind=%s), dimension(n_hel), save :: " !kind;
+ printf "hel_max_abs = 0"; nl ();
+ printf " @[<2>real(kind=%s), save :: " !kind;
+ printf "hel_sum_abs = 0, ";
+ printf "hel_threshold = 1E10_%s" !kind; nl ();
+ printf " @[<2>integer, save :: ";
+ printf "hel_count = 0, ";
+ printf "hel_cutoff = 100"; nl ();
+ printf " @[<2>integer :: ";
+ printf "i"; nl ();
+ printf " @[<2>integer, save, dimension(n_hel) :: ";
+ printf "hel_map = (/(i, i = 1, n_hel)/)"; nl ();
+ printf " @[<2>integer, save :: hel_finite = n_hel"; nl ();
+ nl ()
+
+(* \thocwmodulesubsection{Optional MD5 sum function} *)
+
+ let print_md5sum_functions = function
+ | Some s ->
+ printf " @[<5>"; if !fortran95 then printf "pure ";
+ printf "function md5sum ()"; nl ();
+ printf " character(len=32) :: md5sum"; nl ();
+ printf " ! DON'T EVEN THINK of modifying the following line!"; nl ();
+ printf " md5sum = \"%s\"" s; nl ();
+ printf " end function md5sum"; nl ();
+ nl ()
+ | None -> ()
+
+(* \thocwmodulesubsection{Maintenance \&\ Inquiry Functions} *)
+
+ let print_maintenance_functions () =
+ if !whizard then begin
+ printf " subroutine init (par, scheme)"; nl ();
+ printf " real(kind=%s), dimension(*), intent(in) :: par" !kind; nl ();
+ printf " integer, intent(in) :: scheme"; nl ();
+ printf " call import_from_whizard (par, scheme)"; nl ();
+ printf " end subroutine init"; nl ();
+ nl ();
+ printf " subroutine final ()"; nl ();
+ printf " end subroutine final"; nl ();
+ nl ();
+ printf " subroutine update_alpha_s (alpha_s)"; nl ();
+ printf " real(kind=%s), intent(in) :: alpha_s" !kind; nl ();
+ printf " call model_update_alpha_s (alpha_s)"; nl ();
+ printf " end subroutine update_alpha_s"; nl ();
+ nl ()
+ end
+
+ let print_inquiry_function_openmp () = begin
+ printf " pure function openmp_supported () result (status)"; nl ();
+ printf " logical :: status"; nl ();
+ printf " status = %s" (if !openmp then ".true." else ".false."); nl ();
+ printf " end function openmp_supported"; nl ();
+ nl ()
+ end
+
+ (*i unused value
+ let print_inquiry_function_declarations name =
+ printf " @[<2>public :: number_%s,@ %s" name name;
+ nl ()
+ i*)
+
+ (*i unused value
+ let print_numeric_inquiry_functions () =
+ printf " @[<5>"; if !fortran95 then printf "pure ";
+ printf "function number_particles_in () result (n)"; nl ();
+ printf " integer :: n"; nl ();
+ printf " n = n_in"; nl ();
+ printf " end function number_particles_in"; nl ();
+ nl ();
+ printf " @[<5>"; if !fortran95 then printf "pure ";
+ printf "function number_particles_out () result (n)"; nl ();
+ printf " integer :: n"; nl ();
+ printf " n = n_out"; nl ();
+ printf " end function number_particles_out"; nl ();
+ nl ()
+ i*)
+
+ let print_external_mass_case flv (fin, fout) =
+ printf " case (%3d)" (succ flv); nl ();
+ List.iteri
+ (fun i f ->
+ printf " m(%2d) = %s" (succ i) (M.mass_symbol f); nl ())
+ (fin @ fout)
+
+ let print_external_masses amplitudes =
+ printf " @[<5>"; if !fortran95 then printf "pure ";
+ printf "subroutine external_masses (m, flv)"; nl ();
+ printf " real(kind=%s), dimension(:), intent(out) :: m" !kind; nl ();
+ printf " integer, intent(in) :: flv"; nl ();
+ printf " select case (flv)"; nl ();
+ List.iteri print_external_mass_case (CF.flavors amplitudes);
+ printf " end select"; nl ();
+ printf " end subroutine external_masses"; nl ();
+ nl ()
+
+ let print_numeric_inquiry_functions (f, v) =
+ printf " @[<5>"; if !fortran95 then printf "pure ";
+ printf "function %s () result (n)" f; nl ();
+ printf " integer :: n"; nl ();
+ printf " n = %s" v; nl ();
+ printf " end function %s" f; nl ();
+ nl ()
+
+ let print_inquiry_functions name =
+ printf " @[<5>"; if !fortran95 then printf "pure ";
+ printf "function number_%s () result (n)" name; nl ();
+ printf " integer :: n"; nl ();
+ printf " n = size (table_%s, dim=2)" name; nl ();
+ printf " end function number_%s" name; nl ();
+ nl ();
+ printf " @[<5>"; if !fortran95 then printf "pure ";
+ printf "subroutine %s (a)" name; nl ();
+ printf " integer, dimension(:,:), intent(out) :: a"; nl ();
+ printf " a = table_%s" name; nl ();
+ printf " end subroutine %s" name; nl ();
+ nl ()
+
+ let print_color_flows () =
+ printf " @[<5>"; if !fortran95 then printf "pure ";
+ printf "function number_color_indices () result (n)"; nl ();
+ printf " integer :: n"; nl ();
+ if !amp_triv then begin
+ printf " n = n_cindex"; nl ();
+ end
+ else begin
+ printf " n = size (table_color_flows, dim=1)"; nl ();
+ end;
+ printf " end function number_color_indices"; nl ();
+ nl ();
+ printf " @[<5>"; if !fortran95 then printf "pure ";
+ printf "function number_color_flows () result (n)"; nl ();
+ printf " integer :: n"; nl ();
+ if !amp_triv then begin
+ printf " n = n_cflow"; nl ();
+ end
+ else begin
+ printf " n = size (table_color_flows, dim=3)"; nl ();
+ end;
+ printf " end function number_color_flows"; nl ();
+ nl ();
+ printf " @[<5>"; if !fortran95 then printf "pure ";
+ printf "subroutine color_flows (a, g)"; nl ();
+ printf " integer, dimension(:,:,:), intent(out) :: a"; nl ();
+ printf " logical, dimension(:,:), intent(out) :: g"; nl ();
+ printf " a = table_color_flows"; nl ();
+ printf " g = table_ghost_flags"; nl ();
+ printf " end subroutine color_flows"; nl ();
+ nl ()
+
+ let print_color_factors () =
+ printf " @[<5>"; if !fortran95 then printf "pure ";
+ printf "function number_color_factors () result (n)"; nl ();
+ printf " integer :: n"; nl ();
+ printf " n = size (table_color_factors)"; nl ();
+ printf " end function number_color_factors"; nl ();
+ nl ();
+ printf " @[<5>"; if !fortran95 then printf "pure ";
+ printf "subroutine color_factors (cf)"; nl ();
+ printf " type(%s), dimension(:), intent(out) :: cf"
+ omega_color_factor_abbrev; nl ();
+ printf " cf = table_color_factors"; nl ();
+ printf " end subroutine color_factors"; nl ();
+ nl ();
+ printf " @[<5>"; if !fortran95 && pure_unless_openmp then printf "pure ";
+ printf "function color_sum (flv, hel) result (amp2)"; nl ();
+ printf " integer, intent(in) :: flv, hel"; nl ();
+ printf " real(kind=%s) :: amp2" !kind; nl ();
+ printf " amp2 = real (omega_color_sum (flv, hel, amp, table_color_factors))"; nl ();
+ printf " end function color_sum"; nl ();
+ nl ()
+
+ let print_dispatch_functions () =
+ printf " @[<5>";
+ printf "subroutine new_event (p)"; nl ();
+ printf " real(kind=%s), dimension(0:3,*), intent(in) :: p" !kind; nl ();
+ printf " logical :: mask_dirty"; nl ();
+ printf " integer :: hel"; nl ();
+ printf " call calculate_amplitudes (amp, p, hel_is_allowed)"; nl ();
+ printf " if ((hel_threshold .gt. 0) .and. (hel_count .le. hel_cutoff)) then"; nl ();
+ printf " call @[<3>omega_update_helicity_selection@ (hel_count,@ amp,@ ";
+ printf "hel_max_abs,@ hel_sum_abs,@ hel_is_allowed,@ hel_threshold,@ hel_cutoff,@ mask_dirty)"; nl ();
+ printf " if (mask_dirty) then"; nl ();
+ printf " hel_finite = 0"; nl ();
+ printf " do hel = 1, n_hel"; nl ();
+ printf " if (hel_is_allowed(hel)) then"; nl ();
+ printf " hel_finite = hel_finite + 1"; nl ();
+ printf " hel_map(hel_finite) = hel"; nl ();
+ printf " end if"; nl ();
+ printf " end do"; nl ();
+ printf " end if"; nl ();
+ printf " end if"; nl ();
+ printf " end subroutine new_event"; nl ();
+ nl ();
+ printf " @[<5>";
+ printf "subroutine reset_helicity_selection (threshold, cutoff)"; nl ();
+ printf " real(kind=%s), intent(in) :: threshold" !kind; nl ();
+ printf " integer, intent(in) :: cutoff"; nl ();
+ printf " integer :: i"; nl ();
+ printf " hel_is_allowed = T"; nl ();
+ printf " hel_max_abs = 0"; nl ();
+ printf " hel_sum_abs = 0"; nl ();
+ printf " hel_count = 0"; nl ();
+ printf " hel_threshold = threshold"; nl ();
+ printf " hel_cutoff = cutoff"; nl ();
+ printf " hel_map = (/(i, i = 1, n_hel)/)"; nl ();
+ printf " hel_finite = n_hel"; nl ();
+ printf " end subroutine reset_helicity_selection"; nl ();
+ nl ();
+ printf " @[<5>"; if !fortran95 then printf "pure ";
+ printf "function is_allowed (flv, hel, col) result (yorn)"; nl ();
+ printf " logical :: yorn"; nl ();
+ printf " integer, intent(in) :: flv, hel, col"; nl ();
+ if !amp_triv then begin
+ printf " ! print *, 'inside is_allowed'"; nl ();
+ end;
+ if not !amp_triv then begin
+ printf " yorn = hel_is_allowed(hel) .and. ";
+ printf "flv_col_is_allowed(flv,col)"; nl ();
+ end
+ else begin
+ printf " yorn = .false."; nl ();
+ end;
+ printf " end function is_allowed"; nl ();
+ nl ();
+ printf " @[<5>"; if !fortran95 then printf "pure ";
+ printf "function get_amplitude (flv, hel, col) result (amp_result)"; nl ();
+ printf " complex(kind=%s) :: amp_result" !kind; nl ();
+ printf " integer, intent(in) :: flv, hel, col"; nl ();
+ printf " amp_result = amp(flv, col, hel)"; nl ();
+ printf " end function get_amplitude"; nl ();
+ nl ()
+
+(* \thocwmodulesubsection{Main Function} *)
+
+ let format_power_of_nc
+ { Color.Flow.num = num; Color.Flow.den = den; Color.Flow.power = pwr } =
+ match num, den, pwr with
+ | _, 0, _ -> invalid_arg "format_power_of_nc: zero denominator"
+ | 0, _, _ -> ""
+ | 1, 1, 0 | -1, -1, 0 -> "+ 1"
+ | -1, 1, 0 | 1, -1, 0 -> "- 1"
+ | 1, 1, 1 | -1, -1, 1 -> "+ N"
+ | -1, 1, 1 | 1, -1, 1 -> "- N"
+ | 1, 1, -1 | -1, -1, -1 -> "+ 1/N"
+ | -1, 1, -1 | 1, -1, -1 -> "- 1/N"
+ | 1, 1, p | -1, -1, p ->
+ "+ " ^ (if p > 0 then "" else "1/") ^ "N^" ^ string_of_int (abs p)
+ | -1, 1, p | 1, -1, p ->
+ "- " ^ (if p > 0 then "" else "1/") ^ "N^" ^ string_of_int (abs p)
+ | n, 1, 0 ->
+ (if n < 0 then "- " else "+ ") ^ string_of_int (abs n)
+ | n, d, 0 ->
+ (if n * d < 0 then "- " else "+ ") ^
+ string_of_int (abs n) ^ "/" ^ string_of_int (abs d)
+ | n, 1, 1 ->
+ (if n < 0 then "- " else "+ ") ^ string_of_int (abs n) ^ "N"
+ | n, 1, -1 ->
+ (if n < 0 then "- " else "+ ") ^ string_of_int (abs n) ^ "/N"
+ | n, d, 1 ->
+ (if n * d < 0 then "- " else "+ ") ^
+ string_of_int (abs n) ^ "/" ^ string_of_int (abs d) ^ "N"
+ | n, d, -1 ->
+ (if n * d < 0 then "- " else "+ ") ^
+ string_of_int (abs n) ^ "/" ^ string_of_int (abs d) ^ "/N"
+ | n, 1, p ->
+ (if n < 0 then "- " else "+ ") ^ string_of_int (abs n) ^
+ (if p > 0 then "*" else "/") ^ "N^" ^ string_of_int (abs p)
+ | n, d, p ->
+ (if n * d < 0 then "- " else "+ ") ^ string_of_int (abs n) ^ "/" ^
+ string_of_int (abs d) ^ (if p > 0 then "*" else "/") ^ "N^" ^ string_of_int (abs p)
+
+ let format_powers_of_nc = function
+ | [] -> "0"
+ | powers -> String.concat " " (List.map format_power_of_nc powers)
+
+ let dump_amplitude_slices amplitudes =
+ match CF.coupling_orders amplitudes with
+ | None -> ()
+ | Some (co_list, cop_list) ->
+ printf "! coupling orders:"; nl ();
+ printf "!"; nl ();
+ printf "! %s" (String.concat ", " (List.map CM.coupling_order_to_string co_list)); nl ();
+ List.iter
+ (fun cop_list ->
+ printf "! %s" (String.concat ", " (List.map string_of_int cop_list)); nl ())
+ cop_list;
+ printf "!"; nl ();
+ List.iter
+ (fun amplitude ->
+ printf "! %s" (process_to_string amplitude); nl ();
+ match F.brakets amplitude with
+ | [] -> ()
+ | lines ->
+ let order_to_string (order, n) =
+ Printf.sprintf "%s = %d" (CM.coupling_order_to_string order) n in
+ let orders_to_string orders =
+ String.concat ", " (List.map order_to_string orders) in
+ List.iter (fun (orders, _) -> printf "! %s" (orders_to_string orders); nl ()) lines;
+ printf "!"; nl ())
+ (CF.processes amplitudes);
+ printf "!"; nl ()
+
+ let print_description cmdline amplitudes () =
+ printf
+ "! File generated automatically by O'Mega %s %s %s"
+ Config.version Config.status Config.date; nl ();
+ List.iter (fun s -> printf "! %s" s; nl ()) (M.caveats ());
+ printf "!"; nl ();
+ printf "! %s" cmdline; nl ();
+ printf "!"; nl ();
+ printf "! with all scattering amplitudes for the process(es)"; nl ();
+ printf "!"; nl ();
+ printf "! flavor combinations:"; nl ();
+ printf "!"; nl ();
+ ThoList.iteri
+ (fun i process ->
+ printf "! %3d: %s" i (process_sans_color_to_string process); nl ())
+ 1 (CF.flavors amplitudes);
+ printf "!"; nl ();
+ printf "! color flows:"; nl ();
+ if not !amp_triv then begin
+ printf "!"; nl ();
+ ThoList.iteri
+ (fun i cflow ->
+ printf "! %3d: %s" i (cflow_to_string cflow); nl ())
+ 1 (CF.color_flows amplitudes);
+ printf "!"; nl ();
+ printf "! NB: i.g. not all color flows contribute to all flavor"; nl ();
+ printf "! combinations. Consult the array FLV_COL_IS_ALLOWED"; nl ();
+ printf "! below for the allowed combinations."; nl ();
+ end;
+ printf "!"; nl ();
+ printf "! Color Factors:"; nl ();
+ printf "!"; nl ();
+ if not !amp_triv then begin
+ let cfactors = CF.color_factors amplitudes in
+ for c1 = 0 to pred (Array.length cfactors) do
+ for c2 = 0 to c1 do
+ match cfactors.(c1).(c2) with
+ | [] -> ()
+ | cfactor ->
+ printf "! (%3d,%3d): %s"
+ (succ c1) (succ c2) (format_powers_of_nc cfactor); nl ()
+ done
+ done;
+ end;
+ if not !amp_triv then begin
+ printf "!"; nl ();
+ printf "! vanishing or redundant flavor combinations:"; nl ();
+ printf "!"; nl ();
+ List.iter (fun process ->
+ printf "! %s" (process_sans_color_to_string process); nl ())
+ (CF.vanishing_flavors amplitudes);
+ printf "!"; nl ();
+ end;
+ begin
+ match CF.constraints amplitudes with
+ | None -> ()
+ | Some s ->
+ printf
+ "! diagram selection (MIGHT BREAK GAUGE INVARIANCE!!!):"; nl ();
+ printf "!"; nl ();
+ printf "! %s" s; nl ();
+ printf "!"; nl ()
+ end;
+ begin
+ match CF.slicings amplitudes with
+ | [] -> ()
+ | lines ->
+ printf
+ "! coupling constant selections ('slicings'):"; nl ();
+ printf "!"; nl ();
+ List.iter (fun s -> printf "! %s" s; nl ()) lines;
+ printf "!"; nl ()
+ end;
+ dump_amplitude_slices amplitudes;
+ printf "!"; nl ()
+
+(* \thocwmodulesubsection{Printing Modules} *)
+
+ type accessibility =
+ | Public
+ | Private
+ | Protected (* Fortran 2003 *)
+
+ let accessibility_to_string = function
+ | Public -> "public"
+ | Private -> "private"
+ | Protected -> "protected"
+
+ type used_symbol =
+ | As_Is of string
+ | Aliased of string * string
+
+ let print_used_symbol = function
+ | As_Is name -> printf "%s" name
+ | Aliased (orig, alias) -> printf "%s => %s" alias orig
+
+ type used_module =
+ | Full of string
+ | Full_Aliased of string * (string * string) list
+ | Subset of string * used_symbol list
+
+ let print_used_module = function
+ | Full name
+ | Full_Aliased (name, [])
+ | Subset (name, []) ->
+ printf " use %s" name;
+ nl ()
+ | Full_Aliased (name, aliases) ->
+ printf " @[<5>use %s" name;
+ List.iter
+ (fun (orig, alias) -> printf ", %s => %s" alias orig)
+ aliases;
+ nl ()
+ | Subset (name, used_symbol :: used_symbols) ->
+ printf " @[<5>use %s, only: " name;
+ print_used_symbol used_symbol;
+ List.iter (fun s -> printf ", "; print_used_symbol s) used_symbols;
+ nl ()
+
+ type fortran_module =
+ { module_name : string;
+ default_accessibility : accessibility;
+ used_modules : used_module list;
+ public_symbols : string list;
+ print_declarations : (unit -> unit) list;
+ print_implementations : (unit -> unit) list }
+
+ let print_public = function
+ | name1 :: names ->
+ printf " @[<2>public :: %s" name1;
+ List.iter (fun n -> printf ",@ %s" n) names; nl ()
+ | [] -> ()
+
+ (*i unused value
+ let print_public_interface generic procedures =
+ printf " public :: %s" generic; nl ();
+ begin match procedures with
+ | name1 :: names ->
+ printf " interface %s" generic; nl ();
+ printf " @[<2>module procedure %s" name1;
+ List.iter (fun n -> printf ",@ %s" n) names; nl ();
+ printf " end interface"; nl ();
+ print_public procedures
+ | [] -> ()
+ end
+ i*)
+
+ let print_module m =
+ printf "module %s" m.module_name; nl ();
+ List.iter print_used_module m.used_modules;
+ printf " implicit none"; nl ();
+ printf " %s" (accessibility_to_string m.default_accessibility); nl ();
+ print_public m.public_symbols; nl ();
+ begin match m.print_declarations with
+ | [] -> ()
+ | print_declarations ->
+ List.iter (fun f -> f ()) print_declarations; nl ()
+ end;
+ begin match m.print_implementations with
+ | [] -> ()
+ | print_implementations ->
+ printf "contains"; nl (); nl ();
+ List.iter (fun f -> f ()) print_implementations; nl ();
+ end;
+ printf "end module %s" m.module_name; nl ()
+
+ let print_modules modules =
+ List.iter print_module modules;
+ print_flush ()
+
+ let module_to_file line_length oc prelude m =
+ output_string oc (m.module_name ^ "\n");
+ let filename = m.module_name ^ ".f90" in
+ let channel = open_out filename in
+ Format_Fortran.set_formatter_out_channel ~width:line_length channel;
+ prelude ();
+ print_modules [m];
+ close_out channel
+
+ let modules_to_file line_length oc prelude = function
+ | [] -> ()
+ | m :: mlist ->
+ module_to_file line_length oc prelude m;
+ List.iter (module_to_file line_length oc (fun () -> ())) mlist
+
+(* \thocwmodulesubsection{Chopping Up Amplitudes} *)
+ let all_brakets process =
+ ThoList.flatmap snd (F.brakets process)
+
+ let num_fusions_brakets size amplitudes =
+ let num_fusions =
+ max 1 size in
+ let count_brakets =
+ List.fold_left
+ (fun sum process -> sum + List.length (all_brakets process))
+ 0 (CF.processes amplitudes)
+ and count_processes =
+ List.length (CF.processes amplitudes) in
+ if count_brakets > 0 then
+ let num_brakets =
+ max 1 ((num_fusions * count_processes) / count_brakets) in
+ (num_fusions, num_brakets)
+ else
+ (num_fusions, 1)
+
+ let chop_amplitudes size amplitudes =
+ let num_fusions, num_brakets = num_fusions_brakets size amplitudes in
+ (ThoList.enumerate 1 (ThoList.chopn num_fusions (CF.fusions amplitudes)),
+ ThoList.enumerate 1 (ThoList.chopn num_brakets (CF.processes amplitudes)))
+
+ let print_compute_fusions1 dictionary (n, fusions) =
+ if not !amp_triv then begin
+ if !openmp then begin
+ printf " subroutine compute_fusions_%04d (%s)" n openmp_tld; nl ();
+ printf " @[<5>type(%s), intent(inout) :: %s" openmp_tld_type openmp_tld; nl ();
+ end else begin
+ printf " @[<5>subroutine compute_fusions_%04d ()" n; nl ();
+ end;
+ print_fusions dictionary fusions;
+ printf " end subroutine compute_fusions_%04d" n; nl ();
+ end
+
+ and print_compute_brakets1 dictionary (n, processes) =
+ if not !amp_triv then begin
+ if !openmp then begin
+ printf " subroutine compute_brakets_%04d (%s)" n openmp_tld; nl ();
+ printf " @[<5>type(%s), intent(inout) :: %s" openmp_tld_type openmp_tld; nl ();
+ end else begin
+ printf " @[<5>subroutine compute_brakets_%04d ()" n; nl ();
+ end;
+ List.iter (print_brakets dictionary) processes;
+ printf " end subroutine compute_brakets_%04d" n; nl ();
+ end
+
+(* \thocwmodulesubsection{Common Stuff} *)
+
+ let omega_public_symbols =
+ ["number_particles_in"; "number_particles_out";
+ "number_color_indices";
+ "reset_helicity_selection"; "new_event";
+ "is_allowed"; "get_amplitude"; "color_sum";
+ "external_masses"; "openmp_supported"] @
+ ThoList.flatmap
+ (fun n -> ["number_" ^ n; n])
+ ["spin_states"; "flavor_states"; "color_flows"; "color_factors"]
+
+ let whizard_public_symbols md5sum =
+ ["init"; "final"; "update_alpha_s"] @
+ (match md5sum with Some _ -> ["md5sum"] | None -> [])
+
+ let used_modules () =
+ [Full "kinds";
+ Full Names.use_module;
+ Full_Aliased ("omega_color", ["omega_color_factor", omega_color_factor_abbrev])] @
+ List.map
+ (fun m -> Full m)
+ (match !parameter_module with
+ | "" -> !use_modules
+ | pm -> pm :: !use_modules)
+
+ let public_symbols () =
+ if !whizard then
+ omega_public_symbols @ (whizard_public_symbols !md5sum)
+ else
+ omega_public_symbols
+
+ let print_constants amplitudes =
+
+ printf " ! DON'T EVEN THINK of removing the following!"; nl ();
+ printf " ! If the compiler complains about undeclared"; nl ();
+ printf " ! or undefined variables, you are compiling"; nl ();
+ printf " ! against an incompatible omega95 module!"; nl ();
+ printf " @[<2>integer, dimension(%d), parameter, private :: "
+ (List.length require_library);
+ printf "require =@ (/ @[";
+ print_list require_library;
+ printf " /)"; nl (); nl ();
+
+ (* Using these parameters makes sense for documentation, but in
+ practice, there is no need to ever change them. *)
+ List.iter
+ (function name, value -> print_integer_parameter name (value amplitudes))
+ [ ("n_prt", num_particles);
+ ("n_in", num_particles_in);
+ ("n_out", num_particles_out);
+ ("n_cflow", num_color_flows); (* Number of different color amplitudes. *)
+ ("n_cindex", num_color_indices); (* Maximum rank of color tensors. *)
+ ("n_flv", num_flavors); (* Number of different flavor amplitudes. *)
+ ("n_hel", num_helicities); (* Number of different helicity amplitudes. *)
+ ("n_co", num_coupling_orders); (* Number of different coupling orders. *)
+ ("n_cop", num_coupling_order_powers) (* Number of different powers of coupling orders. *) ];
+ nl ();
+
+ (* Abbreviations. *)
+ printf " ! NB: you MUST NOT change the value of %s here!!!" nc_parameter;
+ nl ();
+ printf " ! It is defined here for convenience only and must be"; nl ();
+ printf " ! compatible with hardcoded values in the amplitude!"; nl ();
+ print_real_parameter nc_parameter (SCM.nc ()); (* $N_C$ *)
+ List.iter
+ (function name, value -> print_logical_parameter name value)
+ [ ("F", false); ("T", true) ]; nl ();
+
+ print_coupling_orders_table amplitudes;
+ print_spin_tables amplitudes;
+ print_flavor_tables amplitudes;
+ print_color_tables amplitudes;
+ print_amplitude_table amplitudes;
+ print_helicity_selection_table ()
+
+ let print_interface amplitudes =
+ print_md5sum_functions !md5sum;
+ print_maintenance_functions ();
+ List.iter print_numeric_inquiry_functions
+ [("number_particles_in", "n_in");
+ ("number_particles_out", "n_out")];
+ List.iter print_inquiry_functions
+ ["spin_states"; "flavor_states"];
+ print_external_masses amplitudes;
+ print_inquiry_function_openmp ();
+ print_color_flows ();
+ print_color_factors ();
+ print_dispatch_functions ();
+ nl ();
+ (* Is this really necessary? *)
+ Format_Fortran.switch_line_continuation false;
+ if !km_write || !km_pure then (Targets_Kmatrix.Fortran.print !km_pure);
+ if !km_2_write || !km_2_pure then (Targets_Kmatrix_2.Fortran.print !km_2_pure);
+ Format_Fortran.switch_line_continuation true;
+ nl ()
+
+ let print_calculate_amplitudes declarations computations amplitudes =
+ printf " @[<5>subroutine calculate_amplitudes (amp, k, mask)"; nl ();
+ printf " complex(kind=%s), dimension(:,:,:), intent(out) :: amp" !kind; nl ();
+ printf " real(kind=%s), dimension(0:3,*), intent(in) :: k" !kind; nl ();
+ printf " logical, dimension(:), intent(in) :: mask"; nl ();
+ printf " integer, dimension(n_prt) :: s"; nl ();
+ printf " integer :: h, hi"; nl ();
+ declarations ();
+ if not !amp_triv then begin
+ begin match CF.processes amplitudes with
+ | p :: _ -> print_external_momenta p
+ | _ -> ()
+ end;
+ ignore (List.fold_left print_momenta PSet.empty (CF.processes amplitudes));
+ end;
+ printf " amp = 0"; nl ();
+ if not !amp_triv then begin
+ if num_helicities amplitudes > 0 then begin
+ printf " if (hel_finite == 0) return"; nl ();
+ if !openmp then begin
+ printf "!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(s, h, %s) SCHEDULE(STATIC)" openmp_tld; nl ();
+ end;
+ printf " do hi = 1, hel_finite"; nl ();
+ printf " h = hel_map(hi)"; nl ();
+ printf " s = table_spin_states(:,h)"; nl ();
+ ignore (List.fold_left print_externals WFSet.empty (CF.processes amplitudes));
+ computations ();
+ List.iter print_fudge_factor (CF.processes amplitudes);
+ (* This sorting should slightly improve cache locality. *)
+ let triple_snd = fun (_, x, _) -> x
+ in let triple_fst = fun (x, _, _) -> x
+ in let rec builder1 flvi flowi flows = match flows with
+ | (Some a) :: tl -> (flvi, flowi, flavors_symbol (flavors a)) :: (builder1 flvi (flowi + 1) tl)
+ | None :: tl -> builder1 flvi (flowi + 1) tl
+ | [] -> []
+ in let rec builder2 flvi flvs = match flvs with
+ | flv :: tl -> (builder1 flvi 1 flv) @ (builder2 (flvi + 1) tl)
+ | [] -> []
+ in let unsorted = builder2 1 (List.map Array.to_list (Array.to_list (CF.process_table amplitudes)))
+ in let sorted = List.sort (fun a b ->
+ if (triple_snd a != triple_snd b) then triple_snd a - triple_snd b else (triple_fst a - triple_fst b))
+ unsorted
+ in List.iter (fun (flvi, flowi, flv) ->
+ (printf " amp(%d,%d,h) = %s" flvi flowi flv; nl ();)) sorted;
+
+ (*i printf " else"; nl ();
+ printf " amp(:,h,:) = 0"; nl (); i*)
+ printf " end do"; nl ();
+ if !openmp then begin
+ printf "!$OMP END PARALLEL DO"; nl ();
+ end;
+ end;
+ end;
+ printf " end subroutine calculate_amplitudes"; nl ()
+
+ let print_compute_chops chopped_fusions chopped_brakets () =
+ List.iter
+ (fun (i, _) -> printf " call compute_fusions_%04d (%s)" i
+ (if !openmp then openmp_tld else ""); nl ())
+ chopped_fusions;
+ List.iter
+ (fun (i, _) -> printf " call compute_brakets_%04d (%s)" i
+ (if !openmp then openmp_tld else ""); nl ())
+ chopped_brakets
+
+ (* \thocwmodulesubsection{UFO Fusions} *)
+
+ module VSet =
+ Set.Make (struct type t = F.constant Coupling.t let compare = compare end)
+
+ let ufo_fusions_used amplitudes =
+ let couplings =
+ List.fold_left
+ (fun acc p ->
+ let fusions = ThoList.flatmap F.rhs (F.fusions p)
+ and brakets = ThoList.flatmap F.ket (all_brakets p) in
+ let couplings =
+ VSet.of_list (List.map F.coupling (fusions @ brakets)) in
+ VSet.union acc couplings)
+ VSet.empty (CF.processes amplitudes) in
+ VSet.fold
+ (fun v acc ->
+ match v with
+ | Coupling.Vn (Coupling.UFO (_, v, _, _, _), _, _) ->
+ Sets.String.add v acc
+ | _ -> acc)
+ couplings Sets.String.empty
+
+(* \thocwmodulesubsection{Single Function} *)
+
+ let amplitudes_to_channel_single_function cmdline oc amplitudes =
+
+ let print_declarations () =
+ print_constants amplitudes
+
+ and print_implementations () =
+ print_interface amplitudes;
+ print_calculate_amplitudes
+ (fun () -> print_variable_declarations amplitudes)
+ (fun () ->
+ print_fusions (CF.dictionary amplitudes) (CF.fusions amplitudes);
+ List.iter
+ (print_brakets (CF.dictionary amplitudes))
+ (CF.processes amplitudes))
+ amplitudes in
+
+ let fortran_module =
+ { module_name = !module_name;
+ used_modules = used_modules ();
+ default_accessibility = Private;
+ public_symbols = public_symbols ();
+ print_declarations = [print_declarations];
+ print_implementations = [print_implementations] } in
+
+ Format_Fortran.set_formatter_out_channel ~width:!line_length oc;
+ print_description cmdline amplitudes ();
+ print_modules [fortran_module]
+
+(* \thocwmodulesubsection{Single Module} *)
+
+ let amplitudes_to_channel_single_module cmdline oc size amplitudes =
+
+ let print_declarations () =
+ print_constants amplitudes;
+ print_variable_declarations amplitudes
+
+ and print_implementations () =
+ print_interface amplitudes in
+
+ let chopped_fusions, chopped_brakets =
+ chop_amplitudes size amplitudes in
+
+ let dictionary = CF.dictionary amplitudes in
+
+ let print_compute_amplitudes () =
+ print_calculate_amplitudes
+ (fun () -> ())
+ (print_compute_chops chopped_fusions chopped_brakets)
+ amplitudes
+
+ and print_compute_fusions () =
+ List.iter (print_compute_fusions1 dictionary) chopped_fusions
+
+ and print_compute_brakets () =
+ List.iter (print_compute_brakets1 dictionary) chopped_brakets in
+
+ let fortran_module =
+ { module_name = !module_name;
+ used_modules = used_modules ();
+ default_accessibility = Private;
+ public_symbols = public_symbols ();
+ print_declarations = [print_declarations];
+ print_implementations = [print_implementations;
+ print_compute_amplitudes;
+ print_compute_fusions;
+ print_compute_brakets] } in
+
+ Format_Fortran.set_formatter_out_channel ~width:!line_length oc;
+ print_description cmdline amplitudes ();
+ print_modules [fortran_module]
+
+(* \thocwmodulesubsection{Multiple Modules} *)
+
+ let modules_of_amplitudes _ _ size amplitudes =
+
+ let name = !module_name in
+
+ let print_declarations () =
+ print_constants amplitudes
+ and print_variables () =
+ print_variable_declarations amplitudes in
+
+ let constants_module =
+ { module_name = name ^ "_constants";
+ used_modules = used_modules ();
+ default_accessibility = Public;
+ public_symbols = [];
+ print_declarations = [print_declarations];
+ print_implementations = [] } in
+
+ let variables_module =
+ { module_name = name ^ "_variables";
+ used_modules = used_modules ();
+ default_accessibility = Public;
+ public_symbols = [];
+ print_declarations = [print_variables];
+ print_implementations = [] } in
+
+ let dictionary = CF.dictionary amplitudes in
+
+ let print_compute_fusions (n, fusions) () =
+ if not !amp_triv then begin
+ if !openmp then begin
+ printf " subroutine compute_fusions_%04d (%s)" n openmp_tld; nl ();
+ printf " @[<5>type(%s), intent(inout) :: %s" openmp_tld_type openmp_tld; nl ();
+ end else begin
+ printf " @[<5>subroutine compute_fusions_%04d ()" n; nl ();
+ end;
+ print_fusions dictionary fusions;
+ printf " end subroutine compute_fusions_%04d" n; nl ();
+ end in
+
+ let print_compute_brakets (n, processes) () =
+ if not !amp_triv then begin
+ if !openmp then begin
+ printf " subroutine compute_brakets_%04d (%s)" n openmp_tld; nl ();
+ printf " @[<5>type(%s), intent(inout) :: %s" openmp_tld_type openmp_tld; nl ();
+ end else begin
+ printf " @[<5>subroutine compute_brakets_%04d ()" n; nl ();
+ end;
+ List.iter (print_brakets dictionary) processes;
+ printf " end subroutine compute_brakets_%04d" n; nl ();
+ end in
+
+ let fusions_module (n, _ as fusions) =
+ let tag = Printf.sprintf "_fusions_%04d" n in
+ { module_name = name ^ tag;
+ used_modules = (used_modules () @
+ [Full constants_module.module_name;
+ Full variables_module.module_name]);
+ default_accessibility = Private;
+ public_symbols = ["compute" ^ tag];
+ print_declarations = [];
+ print_implementations = [print_compute_fusions fusions] } in
+
+ let brakets_module (n, _ as processes) =
+ let tag = Printf.sprintf "_brakets_%04d" n in
+ { module_name = name ^ tag;
+ used_modules = (used_modules () @
+ [Full constants_module.module_name;
+ Full variables_module.module_name]);
+ default_accessibility = Private;
+ public_symbols = ["compute" ^ tag];
+ print_declarations = [];
+ print_implementations = [print_compute_brakets processes] } in
+
+ let chopped_fusions, chopped_brakets =
+ chop_amplitudes size amplitudes in
+
+ let fusions_modules =
+ List.map fusions_module chopped_fusions in
+
+ let brakets_modules =
+ List.map brakets_module chopped_brakets in
+
+ let print_implementations () =
+ print_interface amplitudes;
+ print_calculate_amplitudes
+ (fun () -> ())
+ (print_compute_chops chopped_fusions chopped_brakets)
+ amplitudes in
+
+ let public_module =
+ { module_name = name;
+ used_modules = (used_modules () @
+ [Full constants_module.module_name;
+ Full variables_module.module_name ] @
+ List.map
+ (fun m -> Full m.module_name)
+ (fusions_modules @ brakets_modules));
+ default_accessibility = Private;
+ public_symbols = public_symbols ();
+ print_declarations = [];
+ print_implementations = [print_implementations] }
+ and private_modules =
+ [constants_module; variables_module] @
+ fusions_modules @ brakets_modules in
+ (public_module, private_modules)
+
+ let amplitudes_to_channel_single_file cmdline oc size amplitudes =
+ let public_module, private_modules =
+ modules_of_amplitudes cmdline oc size amplitudes in
+ Format_Fortran.set_formatter_out_channel ~width:!line_length oc;
+ print_description cmdline amplitudes ();
+ print_modules (private_modules @ [public_module])
+
+ let amplitudes_to_channel_multi_file cmdline oc size amplitudes =
+ let public_module, private_modules =
+ modules_of_amplitudes cmdline oc size amplitudes in
+ modules_to_file !line_length oc
+ (print_description cmdline amplitudes)
+ (public_module :: private_modules)
+
+(* \thocwmodulesubsection{Dispatch} *)
+
+ let amplitudes_to_channel cmdline oc diagnostics amplitudes =
+ parse_diagnostics diagnostics;
+ let ufo_fusions =
+ let ufo_fusions_set = ufo_fusions_used amplitudes in
+ if Sets.String.is_empty ufo_fusions_set then
+ None
+ else
+ Some ufo_fusions_set in
+ begin match ufo_fusions with
+ | Some only ->
+ let name = !module_name ^ "_ufo"
+ and fortran_module = Names.use_module in
+ use_modules := name :: !use_modules;
+ UFO.Targets.Fortran.lorentz_module
+ ~only ~name ~fortran_module ~parameter_module:!parameter_module
+ (Format_Fortran.formatter_of_out_channel oc) ()
+ | None -> ()
+ end;
+ match !output_mode with
+ | Single_Function ->
+ amplitudes_to_channel_single_function cmdline oc amplitudes
+ | Single_Module size ->
+ amplitudes_to_channel_single_module cmdline oc size amplitudes
+ | Single_File size ->
+ amplitudes_to_channel_single_file cmdline oc size amplitudes
+ | Multi_File size ->
+ amplitudes_to_channel_multi_file cmdline oc size amplitudes
+
+ let parameters_to_channel oc =
+ parameters_to_fortran oc (CM.parameters ())
+
+ end
+
+module Make =
+ Make_Fortran(Target_Fortran_Names.Dirac)(Targets_vintage.Fortran_Fermions)
+module Make_Majorana =
+ Make_Fortran(Target_Fortran_Names.Majorana)(Targets_vintage.Fortran_Majorana_Fermions)
Index: trunk/omega/src/modeltools.ml
===================================================================
--- trunk/omega/src/modeltools.ml (revision 8899)
+++ trunk/omega/src/modeltools.ml (revision 8900)
@@ -1,688 +1,673 @@
(* modeltools.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
(* \thocwmodulesection{Compilation} *)
(* Flavors and coupling constants: flavors can be tested for equality
and charge conjugation is defined. *)
module type Flavor =
sig
type f
type c
val compare : f -> f -> int
val conjugate : f -> f
end
(* Compiling fusions from a list of vertices: *)
module type Fusions =
sig
type t
type f
type c
val fuse2 : t -> f -> f -> (f * c Coupling.t) list
val fuse3 : t -> f -> f -> f -> (f * c Coupling.t) list
val fuse : t -> f list -> (f * c Coupling.t) list
val of_vertices :
(((f * f * f) * c Coupling.vertex3 * c) list
* ((f * f * f * f) * c Coupling.vertex4 * c) list
* (f list * c Coupling.vertexn * c) list) -> t
end
module Fusions (F : Flavor) : Fusions with type f = F.f and type c = F.c =
struct
type f = F.f
type c = F.c
module F2 =
struct
type t = f * f
let hash = Hashtbl.hash
let compare (f1, f2) (f1', f2') =
let c1 = F.compare f1 f1' in
if c1 <> 0 then
c1
else
F.compare f2 f2'
let equal f f' = compare f f' = 0
end
module F3 =
struct
type t = f * f * f
let hash = Hashtbl.hash
let compare (f1, f2, f3) (f1', f2', f3') =
let c1 = F.compare f1 f1' in
if c1 <> 0 then
c1
else
let c2 = F.compare f2 f2' in
if c2 <> 0 then
c2
else
F.compare f3 f3'
let equal f f' = compare f f' = 0
end
module Fn =
struct
type t = f list
let hash = Hashtbl.hash
let compare f f' = ThoList.compare ~cmp:F.compare f f'
let equal f f' = compare f f' = 0
end
module H2 = Hashtbl.Make (F2)
module H3 = Hashtbl.Make (F3)
module Hn = Hashtbl.Make (Fn)
type t =
{ v3 : (f * c Coupling.t) list H2.t;
v4 : (f * c Coupling.t) list H3.t;
vn : (f * c Coupling.t) list Hn.t }
let lookup_fuse2 table f1 f2 =
try H2.find table.v3 (f1, f2) with Not_found -> []
let lookup_fuse3 table f1 f2 f3 =
try H3.find table.v4 (f1, f2, f3) with Not_found -> []
let lookup_fusen table f =
try Hn.find table.vn f with Not_found -> []
let fuse2 table f1 f2 =
List.rev_append
(lookup_fusen table [f1; f2])
(lookup_fuse2 table f1 f2)
let fuse3 table f1 f2 f3 =
List.rev_append
(lookup_fusen table [f1; f2; f3])
(lookup_fuse3 table f1 f2 f3)
let fusen table f =
lookup_fusen table f
let fuse table = function
| [] | [_] -> invalid_arg "Fusions().fuse"
| [f1; f2] -> fuse2 table f1 f2
| [f1; f2; f3] -> fuse3 table f1 f2 f3
| f -> fusen table f
(* Note that a pair or a triplet can appear more than once
(e.\,g.~$e^+e^-\to \gamma$ and~$e^+e^-\to Z$). Therefore don't
replace the entry, but augment it instead. *)
let add_fusion2 table f1 f2 fusions =
H2.add table.v3 (f1, f2) (fusions :: lookup_fuse2 table f1 f2)
let add_fusion3 table f1 f2 f3 fusions =
H3.add table.v4 (f1, f2, f3) (fusions :: lookup_fuse3 table f1 f2 f3)
let add_fusionn table f fusions =
Hn.add table.vn f (fusions :: lookup_fusen table f)
(* \begin{dubious}
Do we need to take into account the charge conjugation
of the coupling constants here?
\end{dubious} *)
(* If some flavors are identical, we must not introduce the
same vertex more than once: *)
open Coupling
let permute3 (f1, f2, f3) =
[ (f1, f2), F.conjugate f3, F12;
(f2, f1), F.conjugate f3, F21;
(f2, f3), F.conjugate f1, F23;
(f3, f2), F.conjugate f1, F32;
(f3, f1), F.conjugate f2, F31;
(f1, f3), F.conjugate f2, F13 ]
(* Here we add identical permutations of pairs only once: *)
module F2' = Set.Make (F2)
let add_permute3 table v c set ((f1, f2 as f12), f, p) =
if F2'.mem f12 set then
set
else begin
add_fusion2 table f1 f2 (f, V3 (v, p, c));
F2'.add f12 set
end
let add_vertex3 table (f123, v, c) =
ignore (List.fold_left (fun set f -> add_permute3 table v c set f)
F2'.empty (permute3 f123))
(* \begin{dubious}
Handling all the cases explicitely is OK for cubic vertices, but starts
to become questionable already for quartic couplings. The advantage
remains that we can check completeness in [Targets].
\end{dubious} *)
let permute4 (f1, f2, f3, f4) =
[ (f1, f2, f3), F.conjugate f4, F123;
(f2, f3, f1), F.conjugate f4, F231;
(f3, f1, f2), F.conjugate f4, F312;
(f2, f1, f3), F.conjugate f4, F213;
(f3, f2, f1), F.conjugate f4, F321;
(f1, f3, f2), F.conjugate f4, F132;
(f1, f2, f4), F.conjugate f3, F124;
(f2, f4, f1), F.conjugate f3, F241;
(f4, f1, f2), F.conjugate f3, F412;
(f2, f1, f4), F.conjugate f3, F214;
(f4, f2, f1), F.conjugate f3, F421;
(f1, f4, f2), F.conjugate f3, F142;
(f1, f3, f4), F.conjugate f2, F134;
(f3, f4, f1), F.conjugate f2, F341;
(f4, f1, f3), F.conjugate f2, F413;
(f3, f1, f4), F.conjugate f2, F314;
(f4, f3, f1), F.conjugate f2, F431;
(f1, f4, f3), F.conjugate f2, F143;
(f2, f3, f4), F.conjugate f1, F234;
(f3, f4, f2), F.conjugate f1, F342;
(f4, f2, f3), F.conjugate f1, F423;
(f3, f2, f4), F.conjugate f1, F324;
(f4, f3, f2), F.conjugate f1, F432;
(f2, f4, f3), F.conjugate f1, F243 ]
(* Add identical permutations of triplets only once: *)
module F3' = Set.Make (F3)
let add_permute4 table v c set ((f1, f2, f3 as f123), f, p) =
if F3'.mem f123 set then
set
else begin
add_fusion3 table f1 f2 f3 (f, V4 (v, p, c));
F3'.add f123 set
end
let add_vertex4 table (f1234, v, c) =
ignore (List.fold_left (fun set f -> add_permute4 table v c set f)
F3'.empty (permute4 f1234))
module Fn' = Set.Make (Fn)
let permuten = function
| [] -> invalid_arg "Modeltools.permuten"
| f ->
List.map
(fun f' ->
match List.split f' with
| i :: i_list, f :: f_list ->
(f_list, F.conjugate f, i_list @ [i])
| _ -> failwith "Modeltools.permuten: impossible")
(Combinatorics.permute (ThoList.enumerate 1 f))
(* This is for debugging: it provides the same permutations
than the legacy version. *)
let permutations = function
| [f1; f2; f3] ->
[ [f1; f2; f3];
[f2; f1; f3];
[f2; f3; f1];
[f3; f2; f1];
[f3; f1; f2];
[f1; f3; f2] ]
| [f1; f2; f3; f4] ->
[ [f1; f2; f3; f4];
[f1; f2; f4; f3];
[f1; f3; f2; f4];
[f1; f3; f4; f2];
[f1; f4; f2; f3];
[f1; f4; f3; f2];
[f2; f1; f3; f4];
[f2; f1; f4; f3];
[f2; f3; f1; f4];
[f2; f3; f4; f1];
[f2; f4; f1; f3];
[f2; f4; f3; f1];
[f3; f1; f2; f4];
[f3; f1; f4; f2];
[f3; f2; f1; f4];
[f3; f2; f4; f1];
[f3; f4; f1; f2];
[f3; f4; f2; f1];
[f4; f1; f2; f3];
[f4; f1; f3; f2];
[f4; f2; f1; f3];
[f4; f2; f3; f1];
[f4; f3; f1; f2];
[f4; f3; f2; f1] ]
| flist -> Combinatorics.permute flist
let permutations = Combinatorics.permute
let permuten = function
| [] -> invalid_arg "Modeltools.permuten"
| f ->
List.map
(fun f' ->
match List.split (List.rev f') with
| i_list, f :: f_list ->
(* [Printf.eprintf
"permuten: %s\n"
(ThoList.to_string string_of_int (List.rev i_list));] *)
(List.rev f_list, F.conjugate f, List.rev i_list)
| _ -> failwith "Modeltools.permuten: impossible")
(permutations (ThoList.enumerate 1 f))
let add_permuten table v c set (f12__n, f, p) =
if Fn'.mem f12__n set then
set
else begin
add_fusionn table f12__n (f, Vn (v, p, c));
Fn'.add f12__n set
end
(* \begin{dubious}
We could apply any necessary permutations
to objects that are hidden inside of the vertex [v] here
instead of in [Fusion.stat_fuse] and [Colorize.fuse].
\end{dubious} *)
let add_vertexn table (f12__n, v, c) =
ignore
(List.fold_left
(fun set f -> add_permuten table v c set f)
Fn'.empty (permuten f12__n))
let of_vertices (vlist3, vlist4, vlistn) =
let table =
{ v3 = H2.create 37; v4 = H3.create 37; vn = Hn.create 37 } in
List.iter (add_vertex3 table) vlist3;
List.iter (add_vertex4 table) vlist4;
List.iter (add_vertexn table) vlistn;
table
end
module type Constant =
sig
type t
val of_string : string -> t
end
module Constant (M : Model.T) : Constant with type t = M.constant =
struct
type t = M.constant
module String_Key =
struct
type t = string
let hash = Hashtbl.hash
let equal = (=)
end
module String_Hash = Hashtbl.Make (String_Key)
let table = String_Hash.create 37
let fill_table table vs =
List.iter
(fun (_, _, c) ->
String_Hash.add table (M.constant_symbol c) c)
vs
(* Delay loading of the tables until the first use, so that
[M.vertices] can be initialized from a file. *)
let tables_filled = ref false
let fill_tables () =
if not !tables_filled then begin
let (v3, v4, vn) = M.vertices () in
fill_table table v3;
fill_table table v4;
fill_table table vn;
tables_filled := true
end
let of_string name =
try
fill_tables ();
String_Hash.find table name
with
| Not_found ->
invalid_arg
("Constant(Model).of_string: unknown coupling constant: " ^ name)
end
(* \thocwmodulesection{Mutable Models} *)
-module Mutable (FGC : sig type f and g and c end) : Model.Mutable
- with type flavor = FGC.f and type gauge = FGC.g and type constant = FGC.c =
+exception Uninitialized of string
+
+module Mutable (FGC : sig type f and g and c and co end) : Model.Mutable
+ with type flavor = FGC.f and type gauge = FGC.g
+ and type constant = FGC.c and type coupling_order = FGC.co =
struct
type flavor = FGC.f
type gauge = FGC.g
type constant = FGC.c
+ type coupling_order = FGC.co
- let init () = ()
+ type init = string
+ let init _ = ()
+ let write_whizard _ = ()
let options = Options.empty
let caveats () = []
module Ch = Charges.Null
let charges _ = ()
- exception Uninitialized of string
let uninitialized name =
raise (Uninitialized name)
(* Note that [lookup] works, by the magic of currying, for any arity. But
we need to supply one argument to delay evaluation. *)
(* Also note that the references are \emph{not} shared among results
of functor applications. Simple module renaming causes sharing. *)
- let declare template =
- let reference = ref template in
+ let declare initial =
+ let reference = ref initial in
let update fct = reference := fct
and lookup arg = !reference arg in
(update, lookup)
- let set_color, color =
- declare (fun f -> uninitialized "color")
-
- let set_nc, nc =
- declare (fun f -> uninitialized "nc")
-
- let set_pdg, pdg =
- declare (fun f -> uninitialized "pdg")
-
- let set_lorentz, lorentz =
- declare (fun f -> uninitialized "lorentz")
-
- let set_propagator, propagator =
- declare (fun f -> uninitialized "propagator")
-
- let set_width, width =
- declare (fun f -> uninitialized "width")
-
- let set_goldstone, goldstone =
- declare (fun f -> uninitialized "goldstone")
-
- let set_conjugate, conjugate =
- declare (fun f -> uninitialized "conjugate")
-
- let set_fermion, fermion =
- declare (fun f -> uninitialized "fermion")
-
- let set_max_degree, max_degree =
- declare (fun () -> uninitialized "max_degree")
-
- let set_vertices, vertices =
- declare (fun () -> uninitialized "vertices")
-
- let set_fuse2, fuse2 =
- declare (fun f1 f2 -> uninitialized "fuse2")
-
- let set_fuse3, fuse3 =
- declare (fun f1 f2 f3 -> uninitialized "fuse3")
-
- let set_fuse, fuse =
- declare (fun f -> uninitialized "fuse")
-
- let set_flavors, flavors =
- declare (fun () -> [])
-
- let set_external_flavors, external_flavors =
- declare (fun () -> [("uninitialized", [])])
-
- let set_parameters, parameters =
- declare (fun () -> uninitialized "parameters")
-
- let set_flavor_of_string, flavor_of_string =
- declare (fun f -> uninitialized "flavor_of_string")
-
- let set_flavor_to_string, flavor_to_string =
- declare (fun f -> uninitialized "flavor_to_string")
-
- let set_flavor_to_TeX, flavor_to_TeX =
- declare (fun f -> uninitialized "flavor_to_TeX")
-
- let set_flavor_symbol, flavor_symbol =
- declare (fun f -> uninitialized "flavor_symbol")
-
- let set_gauge_symbol, gauge_symbol =
- declare (fun g -> uninitialized "gauge_symbol")
-
- let set_mass_symbol, mass_symbol =
- declare (fun f -> uninitialized "mass_symbol")
-
- let set_width_symbol, width_symbol =
- declare (fun f -> uninitialized "width_symbol")
-
- let set_constant_symbol, constant_symbol =
- declare (fun c -> uninitialized "constant_symbol")
+ let declare1 name = declare (fun _ -> uninitialized name)
+ let declare2 name = declare (fun _ _ -> uninitialized name)
+ let declare3 name = declare (fun _ _ _ -> uninitialized name)
+
+ let set_all_coupling_orders, all_coupling_orders =
+ declare1 "all_coupling_orders"
+ let set_coupling_orders, coupling_orders =
+ declare1 "coupling_orders"
+ let set_coupling_order_to_string, coupling_order_to_string =
+ declare1 "coupling_order_to_string"
+ let set_color, color = declare1 "color"
+ let set_nc, nc = declare1 "nc"
+ let set_pdg, pdg = declare1 "pdg"
+ let set_lorentz, lorentz = declare1 "lorentz"
+ let set_propagator, propagator = declare1 "propagator"
+ let set_width, width = declare1 "width"
+ let set_goldstone, goldstone = declare1 "goldstone"
+ let set_conjugate, conjugate = declare1 "conjugate"
+ let set_fermion, fermion = declare1 "fermion"
+ let set_max_degree, max_degree = declare1 "max_degree"
+ let set_vertices, vertices = declare1 "vertices"
+ let set_fuse2, fuse2 = declare2 "fuse2"
+ let set_fuse3, fuse3 = declare3 "fuse3"
+ let set_fuse, fuse = declare1 "fuse"
+ let set_flavors, flavors = declare1 "flavors"
+ let set_external_flavors, external_flavors = declare (fun () -> [("uninitialized", [])])
+ let set_parameters, parameters = declare1 "parameters"
+ let set_flavor_of_string, flavor_of_string = declare1 "flavor_of_string"
+ let set_flavor_to_string, flavor_to_string = declare1 "flavor_to_string"
+ let set_flavor_to_TeX, flavor_to_TeX = declare1 "flavor_to_TeX"
+ let set_flavor_symbol, flavor_symbol = declare1 "flavor_symbol"
+ let set_gauge_symbol, gauge_symbol = declare1 "gauge_symbol"
+ let set_mass_symbol, mass_symbol = declare1 "mass_symbol"
+ let set_width_symbol, width_symbol = declare1 "width_symbol"
+ let set_constant_symbol, constant_symbol = declare1 "constant_symbol"
module F = Fusions (struct
type f = flavor
type c = constant
let compare = compare
let conjugate = conjugate
end)
let max_degree_of_vertices (v3, v4, vn) =
List.fold_left
(fun acc (p, _, _) -> max acc (List.length p))
(max (match v3 with [] -> 0 | _ -> 3) (match v4 with [] -> 0 | _ -> 4))
vn
let setup ~color ~nc ~pdg ~lorentz ~propagator ~width ~goldstone
~conjugate ~fermion ~vertices
~flavors ~parameters ~flavor_of_string ~flavor_to_string
~flavor_to_TeX ~flavor_symbol
- ~gauge_symbol ~mass_symbol ~width_symbol ~constant_symbol =
+ ~gauge_symbol ~mass_symbol ~width_symbol ~constant_symbol
+ ~all_coupling_orders ~coupling_order_to_string ~coupling_orders =
set_color color;
set_nc nc;
set_pdg pdg;
set_lorentz lorentz;
set_propagator propagator;
set_width width;
set_goldstone goldstone;
set_conjugate conjugate;
set_fermion fermion;
let v = vertices () in
let max_degree = max_degree_of_vertices v in
set_max_degree (fun () -> max_degree);
set_vertices (fun () -> v);
let table = F.of_vertices v in
set_fuse2 (F.fuse2 table);
set_fuse3 (F.fuse3 table);
set_fuse (F.fuse table);
set_external_flavors (fun () -> flavors);
let flavors = ThoList.flatmap snd flavors in
set_flavors (fun () -> flavors);
set_parameters parameters;
set_flavor_of_string flavor_of_string;
set_flavor_to_string flavor_to_string;
set_flavor_to_TeX flavor_to_TeX;
set_flavor_symbol flavor_symbol;
set_gauge_symbol gauge_symbol;
set_mass_symbol mass_symbol;
set_width_symbol width_symbol;
- set_constant_symbol constant_symbol
+ set_constant_symbol constant_symbol;
+ set_all_coupling_orders all_coupling_orders;
+ set_coupling_orders coupling_orders;
+ set_coupling_order_to_string coupling_order_to_string
end
module Static (M : Model.T) =
struct
type flavor = M.flavor
type gauge = M.gauge
type constant = M.constant
+ type coupling_order = M.coupling_order
+ type init = string
module Ch = M.Ch
+ let all_coupling_orders = M.all_coupling_orders
+ let coupling_orders = M.coupling_orders
+ let coupling_order_to_string = M.coupling_order_to_string
let color = M.color
let nc = M.nc
let charges = M.charges
let pdg = M.pdg
let lorentz = M.lorentz
let propagator = M.propagator
let width = M.width
let conjugate = M.conjugate
let fermion = M.fermion
let max_degree = M.max_degree
let vertices = M.vertices
let fuse2 = M.fuse2
let fuse3 = M.fuse3
let fuse = M.fuse
let flavors = M.flavors
let external_flavors = M.external_flavors
let goldstone = M.goldstone
let parameters = M.parameters
let flavor_of_string = M.flavor_of_string
let flavor_to_string = M.flavor_to_string
let flavor_to_TeX = M.flavor_to_TeX
let flavor_symbol = M.flavor_symbol
let gauge_symbol = M.gauge_symbol
let mass_symbol = M.mass_symbol
let width_symbol = M.width_symbol
let constant_symbol = M.constant_symbol
let options = M.options
let caveats = M.caveats
- let init () = ()
+ let init _ = ()
+ let write_whizard _ = ()
let setup ~color ~nc ~pdg ~lorentz ~propagator ~width ~goldstone
~conjugate ~fermion ~vertices
~flavors ~parameters ~flavor_of_string ~flavor_to_string
~flavor_to_TeX ~flavor_symbol
- ~gauge_symbol ~mass_symbol ~width_symbol ~constant_symbol =
+ ~gauge_symbol ~mass_symbol ~width_symbol ~constant_symbol
+ ~all_coupling_orders ~coupling_order_to_string ~coupling_orders =
()
end
(* \thocwmodulesection{Topology Only} *)
(* UFO models can have more than one Lorentz structure for a
given flavor combination. This messes up the phase space
generation. There we need to be able to ignore the redundant
flavor combinations. *)
(* Filter vertices with more than one Lorentz structure
for a combination of flavors. Only the first Lorentz
structure is kept. *)
let filter_couplings flavor_coupling_list =
List.map
(fun (f, c_list) -> (f, List.hd c_list))
(ThoList.factorize flavor_coupling_list)
let triple_to_nested (a, b, c) = (a, (b, c))
let nested_to_triple (a, (b, c)) = (a, b, c)
let filter_couplings_triples fc =
List.map
nested_to_triple
(filter_couplings (List.map triple_to_nested fc))
(* \begin{dubious}
It would be clearer to replace [constant Coupling.t] by
[unit] in the resultig model, but that would require
much more code duplication.
\end{dubious} *)
module Topology (M : Model.T) =
struct
type flavor = M.flavor
type gauge = M.gauge
type constant = M.constant
+ type coupling_order = M.coupling_order
module Ch = M.Ch
+ let all_coupling_orders = M.all_coupling_orders
+ let coupling_orders = M.coupling_orders
+ let coupling_order_to_string = M.coupling_order_to_string
let color = M.color
let nc = M.nc
let charges = M.charges
let pdg = M.pdg
let lorentz = M.lorentz
let propagator = M.propagator
let width = M.width
let conjugate = M.conjugate
let fermion = M.fermion
let max_degree = M.max_degree
let vertices () =
let (v3, v4, vn) = M.vertices () in
(filter_couplings_triples v3,
filter_couplings_triples v4,
filter_couplings_triples vn)
let fuse2 f1 f2 = filter_couplings (M.fuse2 f1 f2)
let fuse3 f1 f2 f3 = filter_couplings (M.fuse3 f1 f2 f3)
let fuse f_list = filter_couplings (M.fuse f_list)
let flavors = M.flavors
let external_flavors = M.external_flavors
let goldstone = M.goldstone
let parameters = M.parameters
let flavor_of_string = M.flavor_of_string
let flavor_to_string = M.flavor_to_string
let flavor_to_TeX = M.flavor_to_TeX
let flavor_symbol = M.flavor_symbol
let gauge_symbol = M.gauge_symbol
let mass_symbol = M.mass_symbol
let width_symbol = M.width_symbol
let constant_symbol = M.constant_symbol
let options = M.options
let caveats = M.caveats
end
module Topology3 (M : Model.T) =
struct
type flavor = M.flavor
type gauge = M.gauge
type constant = M.constant
+ type coupling_order = M.coupling_order
module Ch = M.Ch
+ let all_coupling_orders = M.all_coupling_orders
+ let coupling_orders = M.coupling_orders
+ let coupling_order_to_string = M.coupling_order_to_string
let color = M.color
let nc = M.nc
let charges = M.charges
let pdg = M.pdg
let lorentz = M.lorentz
let propagator = M.propagator
let width = M.width
let conjugate = M.conjugate
let fermion = M.fermion
let max_degree = M.max_degree
let vertices () =
let (v3, _, vn) = M.vertices () in
(filter_couplings_triples v3,
[],
filter_couplings_triples
(List.filter (fun (f, _, _) -> List.length f < 3) vn))
let fuse2 f1 f2 = filter_couplings (M.fuse2 f1 f2)
let fuse3 f1 f2 f3 = []
let fuse = function
| [_; _] as f_list -> filter_couplings (M.fuse f_list)
| _ -> []
let flavors = M.flavors
let external_flavors = M.external_flavors
let goldstone = M.goldstone
let parameters = M.parameters
let flavor_of_string = M.flavor_of_string
let flavor_to_string = M.flavor_to_string
let flavor_to_TeX = M.flavor_to_TeX
let flavor_symbol = M.flavor_symbol
let gauge_symbol = M.gauge_symbol
let mass_symbol = M.mass_symbol
let width_symbol = M.width_symbol
let constant_symbol = M.constant_symbol
let options = M.options
let caveats = M.caveats
end
Index: trunk/omega/src/SU3.mli
===================================================================
--- trunk/omega/src/SU3.mli (revision 0)
+++ trunk/omega/src/SU3.mli (revision 8900)
@@ -0,0 +1,73 @@
+(* SU3.mli --
+
+ Copyright (C) 2022-2023 by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+ with contributions from
+ Christian Speckner <cnspeckn@googlemail.com>
+
+ 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. *)
+
+(* We're computing with a general $N_C$, but [epsilon] and [epsilonbar]
+ make only sense for $N_C=3$. Also some of the terminology alludes
+ to $N_C=3$: triplet, sextet, octet. *)
+
+(* We can use all functions from [Birdtracks] that operate on
+ [Birdtracks.t] transparently. *)
+type t = Birdtracks.t
+
+(* \thocwmodulesection{Constructors specific to $\mathrm{SU}(N_C)$} *)
+
+(* Fundamental representation $N=3$ *)
+val delta3 : int -> int -> t
+
+(* ``Adjoint'' representation, but \emph{without} subtracting ghosts,
+ i.\,e.~$N\otimes\bar N=9$. Therefore, the ``8'' is a misnomer! *)
+val delta8 : int -> int -> t
+
+(* The trace $\tr(T_aT_b)$ contains additional ghosts *)
+val delta8_loop : int -> int -> t
+
+(* Gauge boson in the adjoint representation
+ $N\otimes\bar N - N\cdot\text{ghost}$ *)
+val gluon : int -> int -> t
+
+(* Symmetric $N\otimes_{\mathrm{S}}N=6$ and
+ $N\otimes_{\mathrm{S}}N\otimes_{\mathrm{S}}N=10$. *)
+val delta6 : int -> int -> t
+val delta10 : int -> int -> t
+
+val t : int -> int -> int -> t
+val f : int -> int -> int -> t
+val d : int -> int -> int -> t
+
+val epsilon : int list -> t
+val epsilon_bar : int list -> t
+
+val t8 : int -> int -> int -> t
+val t6 : int -> int -> int -> t
+val t10 : int -> int -> int -> t
+
+val k6 : int -> int -> int -> t
+val k6bar : int -> int -> int -> t
+
+val delta_of_tableau : int Young.tableau -> int -> int -> t
+val t_of_tableau : int Young.tableau -> int -> int -> int -> t
+
+(* The Unit tests are in fact the largest part of this module. *)
+module Test : sig val suite : OUnit.test val suite_long : OUnit.test end
+
Index: trunk/omega/src/omega_MSSM.ml
===================================================================
--- trunk/omega/src/omega_MSSM.ml (revision 8899)
+++ trunk/omega/src/omega_MSSM.ml (revision 8900)
@@ -1,26 +1,26 @@
(* omega_MSSM.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23_Majorana_vintage(Targets.Fortran_Majorana)(Modellib_MSSM.MSSM(Modellib_MSSM.MSSM_no_4))
+module O = Omega.Mixed23_Majorana_vintage(Target_Fortran.Make_Majorana)(Modellib_MSSM.MSSM(Modellib_MSSM.MSSM_no_4))
let _ = O.main ()
Index: trunk/omega/src/omega.ml
===================================================================
--- trunk/omega/src/omega.ml (revision 8899)
+++ trunk/omega/src/omega.ml (revision 8900)
@@ -1,747 +1,565 @@
(* omega.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-let (<<) f g x = f (g x)
-let (>>) f g x = g (f x)
-
module P = Momentum.Default
module P_Whizard = Momentum.DefaultW
module type T =
sig
- val main : unit -> unit
+ val main : ?current:int ref -> ?argv:string array -> unit -> unit
type flavor
val diagrams : flavor -> flavor -> flavor list ->
((flavor * Momentum.Default.t) *
(flavor * Momentum.Default.t,
flavor * Momentum.Default.t) Tree.t) list
end
module Make (Fusion_Maker : Fusion.Maker) (PHS_Maker : Fusion.Maker)
(Target_Maker : Target.Maker) (M : Model.T) =
struct
module CM = Colorize.It(M)
+ module SCM = Orders.Slice(Colorize.It(M))
type flavor = M.flavor
module Proc = Process.Make(M)
+ module Coupling_Orders = Orders.Conditions(Colorize.It(M))
+
(* \begin{dubious}
We must have initialized the vertices \emph{before}
applying [Fusion_Maker], at least if we want to continue
using the vertex cache!
\end{dubious} *)
(* \begin{dubious}
NB: this causes the constant initializers in [Fusion_Maker] more than once.
Such side effects must be avoided if the initializers involve expensive
computations. \emph{Relying on the fact that the functor will be
called only once is not a good idea!}
\end{dubious} *)
module F = Fusion_Maker(P)(M)
module CF = Fusion.Multi(Fusion_Maker)(P)(M)
module T = Target_Maker(Fusion_Maker)(P)(M)
module W = Whizard.Make(Fusion_Maker)(P)(P_Whizard)(M)
module C = Cascade.Make(M)(P)
module VSet =
Set.Make (struct type t = F.constant Coupling.t let compare = compare end)
(* For the phase space, we need asymmetric DAGs.
Since we will not use this to compute amplitudes, there's
no need to supply the proper statistics module and we may
always use Majorana fermions to be as general as possible.
In principle, we could expose in [Fusion.T] the [Fusion.Stat_Maker]
used by [Fusion_Maker] to construct it, but that is just not
worth the effort.
\begin{dubious}
For the phase space, we should be able to work on the
uncolored model.
\end{dubious} *)
module MT = Modeltools.Topology3(M)
module PHS = PHS_Maker(P)(MT)
module CT = Cascade.Make(MT)(P)
(* Form a ['a list] from a ['a option array], containing
the elements that are not [None] in order. *)
let opt_array_to_list a =
let rec opt_array_to_list' acc i a =
if i < 0 then
acc
else
begin match a.(i) with
| None -> opt_array_to_list' acc (pred i) a
| Some x -> opt_array_to_list' (x :: acc) (pred i) a
end in
opt_array_to_list' [] (Array.length a - 1) a
(* Return a list of [CF.amplitude list]s, corresponig to the diagrams
for a specific color flow for each flavor combination. *)
let amplitudes_by_flavor amplitudes =
List.map opt_array_to_list (Array.to_list (CF.process_table amplitudes))
(* \begin{dubious}
If we plan to distiguish different couplings later on,
we can no long map all instances of [coupling option]
in the tree to [None]. In this case, we will need
to normalize different fusion orders [Coupling.fuse2],
[Coupling.fuse3] or [Coupling.fusen], because they would
- otherwise lead to inequivalent diagrams. Unfortunately, this
- stuff packaged deep in [Fusion.Tagged_Coupling].
+ otherwise lead to inequivalent diagrams.
\end{dubious} *)
(*i
let strip_fuse' = function
| Coupling.V3 (v, f, c) -> Coupling.V3 (v, Coupling.F12, c)
| Coupling.V4 (v, f, c) -> Coupling.V4 (v, Coupling.F123, c)
| Coupling.Vn (v, f, c) -> Coupling.Vn (v, [], c)
let strip_fuse = function
| Some c -> Some (strip_fuse' c)
| None -> None
i*)
(* \begin{dubious}
The [Tree.canonicalize] below should be necessary to remove
topologically equivalent duplicates.
\end{dubious} *)
-(* Take a [CF.amplitude list] assumed to correspond to the same
- external states after stripping the color and return a
- pair of the list of external particles and the corresponding
- Feynman diagrams without color. *)
-
- let wf1 amplitude =
- match F.externals amplitude with
- | wf :: _ -> wf
- | [] -> failwith "Omega.forest_sans_color: no external particles"
-
- let uniq l =
- ThoList.uniq (List.sort compare l)
-
- let forest_sans_color = function
- | amplitude :: _ as amplitudes ->
- let externals = F.externals amplitude in
- let prune_color wf =
- (F.flavor_sans_color wf, F.momentum_list wf) in
- let prune_color_and_couplings (wf, c) =
- (prune_color wf, None) in
- (List.map prune_color externals,
- uniq
- (List.map
- (fun t ->
- Tree.canonicalize
- (Tree.map prune_color_and_couplings prune_color t))
- (ThoList.flatmap (fun a -> F.forest (wf1 a) a) amplitudes)))
- | [] -> ([], [])
-
- let dag_sans_color = function
- | amplitude :: _ as amplitudes ->
- let prune a = a in
- List.map prune amplitudes
- | [] -> []
-
let p2s p =
if p >= 0 && p <= 9 then
string_of_int p
else if p <= 36 then
String.make 1 (Char.chr (Char.code 'A' + p - 10))
else
"_"
let format_p wf =
String.concat "" (List.map p2s (F.momentum_list wf))
let variable wf =
M.flavor_to_string (F.flavor_sans_color wf) ^ "[" ^ format_p wf ^ "]"
- let variable' wf =
- CM.flavor_to_TeX (F.flavor wf) ^ "(" ^ format_p wf ^ ")"
-
- let feynmf_style propagator color =
- { Tree.style =
- begin match propagator with
- | Coupling.Prop_Feynman
- | Coupling.Prop_Gauge _ ->
- begin match color with
- | Color.AdjSUN _ -> Some ("gluon", "")
- | _ -> Some ("boson", "")
- end
- | Coupling.Prop_Col_Feynman -> Some ("gluon", "")
- | Coupling.Prop_Unitarity
- | Coupling.Prop_Rxi _ -> Some ("dbl_wiggly", "")
- | Coupling.Prop_Spinor
- | Coupling.Prop_ConjSpinor -> Some ("fermion", "")
- | _ -> None
- end;
- Tree.rev =
- begin match propagator with
- | Coupling.Prop_Spinor -> true
- | Coupling.Prop_ConjSpinor -> false
- | _ -> false
- end;
- Tree.label = None;
- Tree.tension = None }
-
- let header incoming outgoing =
- "$ " ^
- String.concat " "
- (List.map (CM.flavor_to_TeX << F.flavor) incoming) ^
- " \\to " ^
- String.concat " "
- (List.map (CM.flavor_to_TeX << CM.conjugate << F.flavor) outgoing) ^
- " $"
-
- let header_sans_color incoming outgoing =
- "$ " ^
- String.concat " "
- (List.map (M.flavor_to_TeX << fst) incoming) ^
- " \\to " ^
- String.concat " "
- (List.map (M.flavor_to_TeX << M.conjugate << fst) outgoing) ^
- " $"
-
- let diagram incoming tree =
- let fmf wf =
- let f = F.flavor wf in
- feynmf_style (CM.propagator f) (CM.color f) in
- Tree.map
- (fun (n, _) ->
- let n' = fmf n in
- if List.mem n incoming then
- { n' with Tree.rev = not n'.Tree.rev }
- else
- n')
- (fun l ->
- if List.mem l incoming then
- l
- else
- F.conjugate l)
- tree
-
- let diagram_sans_color incoming (tree) =
- let fmf (f, p) =
- feynmf_style (M.propagator f) (M.color f) in
- Tree.map
- (fun (n, c) ->
- let n' = fmf n in
- if List.mem n incoming then
- { n' with Tree.rev = not n'.Tree.rev }
- else
- n')
- (fun (f, p) ->
- if List.mem (f, p) incoming then
- (f, p)
- else
- (M.conjugate f, p))
- tree
-
- let feynmf_set amplitude =
- match F.externals amplitude with
- | wf1 :: wf2 :: wfs ->
- let incoming = [wf1; wf2] in
- { Tree.header = header incoming wfs;
- Tree.incoming = incoming;
- Tree.diagrams =
- List.map (diagram incoming) (F.forest wf1 amplitude) }
- | _ -> failwith "less than two external particles"
-
- let feynmf_set_sans_color (externals, trees) =
- match externals with
- | wf1 :: wf2 :: wfs ->
- let incoming = [wf1; wf2] in
- { Tree.header = header_sans_color incoming wfs;
- Tree.incoming = incoming;
- Tree.diagrams =
- List.map (diagram_sans_color incoming) trees }
- | _ -> failwith "less than two external particles"
-
- let feynmf_set_sans_color_empty (externals, trees) =
- match externals with
- | wf1 :: wf2 :: wfs ->
- let incoming = [wf1; wf2] in
- { Tree.header = header_sans_color incoming wfs;
- Tree.incoming = incoming;
- Tree.diagrams = [] }
- | _ -> failwith "less than two external particles"
-
- let uncolored_colored amplitudes =
- { Tree.outer = feynmf_set_sans_color (forest_sans_color amplitudes);
- Tree.inner = List.map feynmf_set amplitudes }
-
- let uncolored_only amplitudes =
- { Tree.outer = feynmf_set_sans_color (forest_sans_color amplitudes);
- Tree.inner = [] }
-
- let colored_only amplitudes =
- { Tree.outer = feynmf_set_sans_color_empty (forest_sans_color amplitudes);
- Tree.inner = List.map feynmf_set amplitudes }
-
- let momentum_to_TeX (_, p) =
- String.concat "" (List.map p2s p)
-
- let wf_to_TeX (f, _ as wf) =
- M.flavor_to_TeX f ^ "(" ^ momentum_to_TeX wf ^ ")"
-
- let amplitudes_to_feynmf latex name amplitudes =
- Tree.feynmf_sets_wrapped latex name
- wf_to_TeX momentum_to_TeX variable' format_p
- (List.map uncolored_colored (amplitudes_by_flavor amplitudes))
-
- let amplitudes_to_feynmf_sans_color latex name amplitudes =
- Tree.feynmf_sets_wrapped latex name
- wf_to_TeX momentum_to_TeX variable' format_p
- (List.map uncolored_only (amplitudes_by_flavor amplitudes))
-
- let amplitudes_to_feynmf_color_only latex name amplitudes =
- Tree.feynmf_sets_wrapped latex name
- wf_to_TeX momentum_to_TeX variable' format_p
- (List.map colored_only (amplitudes_by_flavor amplitudes))
-
let debug (str, descr, opt, var) =
[ "-warning:" ^ str, Arg.Unit (fun () -> var := (opt, false):: !var),
" check " ^ descr ^ " and print warning on error";
"-error:" ^ str, Arg.Unit (fun () -> var := (opt, true):: !var),
" check " ^ descr ^ " and terminate on error" ]
let rec include_goldstones = function
| [] -> false
| (T.Gauge, _) :: _ -> true
| _ :: rest -> include_goldstones rest
let read_lines_rev file =
let ic = open_in file in
let rev_lines = ref [] in
let rec slurp () =
rev_lines := input_line ic :: !rev_lines;
slurp () in
try
slurp ()
with
| End_of_file ->
close_in ic;
!rev_lines
let read_lines file =
List.rev (read_lines_rev file)
(*i
type cache_mode =
| Cache_Default
| Cache_Initialize of string
let cache_option =
ref Cache_Default
i*)
let unphysical_polarization = ref None
+ module FMP = Feynmp.Make(Fusion_Maker)(P)(M)
+
(* \thocwmodulesection{Main Program} *)
- let main () =
+ let main ?current ?argv () =
(* Delay evaluation of [M.external_flavors ()]! *)
let usage () =
"usage: " ^ Sys.argv.(0) ^
" [options] [" ^
String.concat "|" (List.map M.flavor_to_string
(ThoList.flatmap snd
(M.external_flavors ()))) ^ "]"
and rev_scatterings = ref []
and rev_decays = ref []
and cascades = ref []
+ and orders = ref []
and checks = ref []
and output_file = ref None
and print_forest = ref false
and template = ref false
and diagrams_all = ref None
and diagrams_sans_color = ref None
and diagrams_color_only = ref None
and diagrams_LaTeX = ref false
and quiet = ref false
and write = ref true
and params = ref false
and poles = ref false
and dag_out = ref None
and dag0_out = ref None
and phase_space_out = ref None in
- Options.parse
+ Options.parse ?current ?argv
(Options.cmdline "-target:" T.options @
Options.cmdline "-model:" M.options @
Options.cmdline "-fusion:" CF.options @
ThoList.flatmap debug
["a", "arguments", T.All, checks;
"n", "# of input arguments", T.Arguments, checks;
"m", "input momenta", T.Momenta, checks;
"g", "internal Ward identities", T.Gauge, checks] @
[("-o", Arg.String (fun s -> output_file := Some s),
"file write to given file instead of /dev/stdout");
("-scatter",
Arg.String (fun s -> rev_scatterings := s :: !rev_scatterings),
"expr in1 in2 -> out1 out2 ...");
("-scatter_file",
Arg.String (fun s -> rev_scatterings := read_lines_rev s @ !rev_scatterings),
"name each line: in1 in2 -> out1 out2 ...");
("-decay", Arg.String (fun s -> rev_decays := s :: !rev_decays),
"expr in -> out1 out2 ...");
("-decay_file",
Arg.String (fun s -> rev_decays := read_lines_rev s @ !rev_decays),
"name each line: in -> out1 out2 ...");
("-cascade", Arg.String (fun s -> cascades := s :: !cascades),
"expr select diagrams");
+ ("-orders", Arg.String (fun s -> orders := s :: !orders),
+ "expr select coupling orders");
(*i
("-initialize",
Arg.String (fun s -> cache_option := Cache_Initialize s),
"dir precompute lookup tables and store them in directory");
i*)
("-unphysical", Arg.Int (fun i -> unphysical_polarization := Some i),
"n use unphysical polarization for n-th particle / test WIs");
("-template", Arg.Set template,
" write a template for handwritten amplitudes");
("-forest", Arg.Set print_forest,
" Diagrammatic expansion");
("-diagrams", Arg.String (fun s -> diagrams_sans_color := Some s),
"file produce FeynMP output for Feynman diagrams");
("-diagrams:c", Arg.String (fun s -> diagrams_color_only := Some s),
"file produce FeynMP output for color flow diagrams");
("-diagrams:C", Arg.String (fun s -> diagrams_all := Some s),
"file produce FeynMP output for Feynman and color flow diagrams");
("-diagrams_LaTeX", Arg.Set diagrams_LaTeX,
" enclose FeynMP output in LaTeX wrapper");
("-quiet", Arg.Set quiet,
" don't print a summary");
("-summary", Arg.Clear write,
" print only a summary");
("-params", Arg.Set params,
" print the model parameters");
("-poles", Arg.Set poles,
" print the Monte Carlo poles");
("-dag", Arg.String (fun s -> dag_out := Some s),
" print minimal DAG");
("-full_dag", Arg.String (fun s -> dag0_out := Some s),
" print complete DAG");
("-phase_space", Arg.String (fun s -> phase_space_out := Some s),
" print minimal DAG for phase space")])
(*i ("-T", Arg.Int Topology.Binary.debug_triplet, "");
("-P", Arg.Int Topology.Binary.debug_partition, "")])
i*)
(fun _ -> prerr_endline (usage ()); exit 1)
usage;
let cmdline =
String.concat " " (List.map ThoString.quote (Array.to_list Sys.argv)) in
let output_channel, close_output_channel =
match !output_file with
| None ->
(stdout, fun () -> ())
| Some name ->
let oc = open_out name in
(oc, fun () -> close_out oc) in
let processes =
try
ThoList.uniq
(List.sort compare
(match List.rev !rev_scatterings, List.rev !rev_decays with
| [], [] -> []
| scatterings, [] ->
Proc.expand_scatterings (List.map Proc.parse_scattering scatterings)
| [], decays ->
Proc.expand_decays (List.map Proc.parse_decay decays)
| scatterings, decays ->
invalid_arg "mixed scattering and decay!"))
with
| Invalid_argument s ->
begin
Printf.eprintf "O'Mega: invalid process specification: %s!\n" s;
flush stderr;
[]
end in
(* \begin{dubious}
This is still crude. Eventually, we want to catch \emph{all} exceptions
and write an empty (but compilable) amplitude unless one of the special options
is selected.
\end{dubious} *)
(*i
begin match processes, !cache_option, !params with
| [], Cache_Initialize dir, false ->
(* [F.initialize_cache dir;] *)
exit 0
| _, _, true ->
if !write then
T.parameters_to_channel output_channel;
exit 0
| [], _, false ->
if !write then
T.amplitudes_to_channel cmdline output_channel !checks CF.empty;
exit 0
| _, _, false ->
i*)
begin match processes, !params with
| _, true ->
if !write then
T.parameters_to_channel output_channel;
exit 0
| [], false ->
if !write then
T.amplitudes_to_channel cmdline output_channel !checks CF.empty;
exit 0
| _, false ->
let selectors =
let fin, fout = List.hd processes in
C.to_selectors (C.of_string_list (List.length fin + List.length fout) !cascades) in
+ let orders =
+ match !orders with
+ | [] -> None
+ | strings -> Some (Coupling_Orders.of_strings (List.rev strings)) in
+
let amplitudes =
try
begin match F.check_charges () with
| [] -> ()
| violators ->
let violator_strings =
String.concat ", "
(List.map
(fun flist ->
"(" ^ String.concat "," (List.map M.flavor_to_string flist) ^ ")")
violators) in
failwith ("charge violating vertices: " ^ violator_strings)
end;
- CF.amplitudes (include_goldstones !checks) !unphysical_polarization
- CF.no_exclusions selectors processes
+ CF.amplitudes (include_goldstones !checks) !unphysical_polarization selectors orders processes
with
| Fusion.Majorana ->
begin
Printf.eprintf
"O'Mega: found Majorana fermions, switching representation!\n";
flush stderr;
close_output_channel ();
Arg.current := 0;
raise Fusion.Majorana
end
| exc ->
begin
Printf.eprintf
"O'Mega: exception %s in amplitude construction!\n"
(Printexc.to_string exc);
flush stderr;
CF.empty;
end in
if !write then
T.amplitudes_to_channel cmdline output_channel !checks amplitudes;
if not !quiet then begin
List.iter
(fun amplitude ->
Printf.eprintf "SUMMARY: %d fusions, %d propagators"
(F.count_fusions amplitude) (F.count_propagators amplitude);
flush stderr;
Printf.eprintf ", %d diagrams" (F.count_diagrams amplitude);
Printf.eprintf "\n")
(CF.processes amplitudes);
let couplings =
List.fold_left
(fun acc p ->
+ let brakets = ThoList.flatmap snd (F.brakets p) in
let fusions = ThoList.flatmap F.rhs (F.fusions p)
- and brakets = ThoList.flatmap F.ket (F.brakets p) in
- let couplings =
- VSet.of_list (List.map F.coupling (fusions @ brakets)) in
+ and brakets = ThoList.flatmap F.ket brakets in
+ let couplings = VSet.of_list (List.map F.coupling (fusions @ brakets)) in
VSet.union acc couplings)
VSet.empty (CF.processes amplitudes) in
Printf.eprintf "SUMMARY: %d vertices\n" (VSet.cardinal couplings);
let ufo_couplings =
VSet.fold
(fun v acc ->
match v with
| Coupling.Vn (Coupling.UFO (_, v, _, _, _), _, _) ->
Sets.String.add v acc
| _ -> acc)
couplings Sets.String.empty in
if not (Sets.String.is_empty ufo_couplings) then
Printf.eprintf
"SUMMARY: %d UFO vertices: %s\n"
(Sets.String.cardinal ufo_couplings)
(String.concat ", " (Sets.String.elements ufo_couplings))
end;
if !poles then begin
List.iter
(fun amplitude ->
W.write output_channel "omega" (W.merge (W.trees amplitude)))
(CF.processes amplitudes)
end;
begin match !dag0_out with
| Some name ->
let ch = open_out name in
List.iter (F.tower_to_dot ch) (CF.processes amplitudes);
close_out ch
| None -> ()
end;
begin match !dag_out with
| Some name ->
let ch = open_out name in
List.iter (F.amplitude_to_dot ch) (CF.processes amplitudes);
close_out ch
| None -> ()
end;
begin match !phase_space_out with
| Some name ->
let selectors =
let fin, fout = List.hd processes in
CT.to_selectors (CT.of_string_list (List.length fin + List.length fout) !cascades) in
let ch = open_out name in
begin try
List.iter
(fun (fin, fout) ->
Printf.fprintf
ch "%s -> %s ::\n"
(String.concat " " (List.map M.flavor_to_string fin))
(String.concat " " (List.map M.flavor_to_string fout));
match fin with
| [] ->
failwith "Omega(): phase space: no incoming particles"
| [f] ->
- PHS.phase_space_channels
- ch
- (PHS.amplitude_sans_color
- false PHS.no_exclusions selectors fin fout)
+ PHS.phase_space_channels ch (PHS.amplitude_sans_color false selectors fin fout)
| [f1; f2] ->
- PHS.phase_space_channels
- ch
- (PHS.amplitude_sans_color
- false PHS.no_exclusions selectors fin fout);
- PHS.phase_space_channels_flipped
- ch
- (PHS.amplitude_sans_color
- false PHS.no_exclusions selectors [f2; f1] fout)
+ PHS.phase_space_channels ch (PHS.amplitude_sans_color false selectors fin fout);
+ PHS.phase_space_channels_flipped ch (PHS.amplitude_sans_color false selectors [f2; f1] fout)
| _ ->
failwith "Omega(): phase space: 3 or more incoming particles")
processes;
close_out ch
with
| exc ->
begin
close_out ch;
Printf.eprintf
"O'Mega: exception %s in phase space construction!\n"
(Printexc.to_string exc);
flush stderr
end
end
| None -> ()
end;
if !print_forest then
List.iter
(fun amplitude ->
List.iter (fun t -> Printf.eprintf "%s\n"
(Tree.to_string
(Tree.map (fun (wf, _) -> variable wf) (fun _ -> "") t)))
(F.forest (List.hd (F.externals amplitude)) amplitude))
(CF.processes amplitudes);
begin match !diagrams_all with
- | Some name ->
- amplitudes_to_feynmf !diagrams_LaTeX name amplitudes
+ | Some name -> FMP.amplitudes !diagrams_LaTeX name amplitudes
| None -> ()
end;
begin match !diagrams_sans_color with
- | Some name ->
- amplitudes_to_feynmf_sans_color !diagrams_LaTeX name amplitudes
+ | Some name -> FMP.amplitudes_sans_color !diagrams_LaTeX name amplitudes
| None -> ()
end;
begin match !diagrams_color_only with
- | Some name ->
- amplitudes_to_feynmf_color_only !diagrams_LaTeX name amplitudes
+ | Some name -> FMP.amplitudes_color_only !diagrams_LaTeX name amplitudes
| None -> ()
end;
close_output_channel ();
exit 0
end
(* \begin{dubious}
This was only intended for debugging O'Giga \ldots
\end{dubious} *)
let decode wf =
(F.flavor wf, (F.momentum wf : Momentum.Default.t))
let diagrams in1 in2 out =
- match F.amplitudes false F.no_exclusions C.no_cascades [in1; in2] out with
+ match F.amplitudes false C.no_cascades None [in1; in2] out with
| a :: _ ->
let wf1 = List.hd (F.externals a)
and wf2 = List.hd (List.tl (F.externals a)) in
let wf2 = decode wf2 in
List.map (fun t ->
(wf2,
Tree.map (fun (wf, _) -> decode wf) decode t))
(F.forest wf1 a)
| [] -> []
let diagrams in1 in2 out =
failwith "Omega().diagrams: disabled"
end
module Binary (TM : Target.Maker) (M : Model.T) =
Make(Fusion.Binary)(Fusion.Helac_Binary)(TM)(M)
module Binary_Majorana (TM : Target.Maker) (M : Model.T) =
Make(Fusion.Binary_Majorana)(Fusion.Helac_Binary_Majorana)(TM)(M)
module Mixed23 (TM : Target.Maker) (M : Model.T) =
Make(Fusion.Mixed23)(Fusion.Helac_Mixed23)(TM)(M)
module Mixed23_Majorana (TM : Target.Maker) (M : Model.T) =
Make(Fusion.Mixed23_Majorana)(Fusion.Helac_Mixed23_Majorana)(TM)(M)
module Mixed23_Majorana_vintage (TM : Target.Maker) (M : Model.T) =
Make(Fusion_vintage.Mixed23_Majorana)(Fusion.Helac_Mixed23_Majorana)(TM)(M)
module Bound (M : Model.T) : Tuple.Bound =
struct
(* \begin{dubious}
Above [max_degree = 6], the performance drops \emph{dramatically}!
\end{dubious} *)
let max_arity () =
pred (M.max_degree ())
end
module Nary (TM : Target.Maker) (M : Model.T) =
Make(Fusion.Nary(Bound(M)))(Fusion.Helac(Bound(M)))(TM)(M)
module Nary_Majorana (TM : Target.Maker) (M : Model.T) =
Make(Fusion.Nary_Majorana(Bound(M)))(Fusion.Helac_Majorana(Bound(M)))(TM)(M)
Index: trunk/omega/src/omega_NMSSM_Hgg.ml
===================================================================
--- trunk/omega/src/omega_NMSSM_Hgg.ml (revision 8899)
+++ trunk/omega/src/omega_NMSSM_Hgg.ml (revision 8900)
@@ -1,27 +1,27 @@
(* omega_NMSSM.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
and Felix Braam (parts of this file only)
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23_Majorana_vintage(Targets.Fortran_Majorana)(Modellib_NMSSM.NMSSM_func(Modellib_NMSSM.NMSSM_Hgg))
+module O = Omega.Mixed23_Majorana_vintage(Target_Fortran.Make_Majorana)(Modellib_NMSSM.NMSSM_func(Modellib_NMSSM.NMSSM_Hgg))
let _ = O.main ()
Index: trunk/omega/src/omega_SM_ac.ml
===================================================================
--- trunk/omega/src/omega_SM_ac.ml (revision 8899)
+++ trunk/omega/src/omega_SM_ac.ml (revision 8900)
@@ -1,35 +1,26 @@
(* omega_SM_ac.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.Fortran)
- (Modellib_SM.SM(Modellib_SM.SM_anomalous))
+module O = Omega.Mixed23(Target_Fortran.Make)(Modellib_SM.SM(Modellib_SM.SM_anomalous))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/arrow.ml
===================================================================
--- trunk/omega/src/arrow.ml (revision 0)
+++ trunk/omega/src/arrow.ml (revision 8900)
@@ -0,0 +1,1096 @@
+(* arrow.ml --
+
+ Copyright (C) 2022-2023 by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+ with contributions from
+ Christian Speckner <cnspeckn@googlemail.com>
+
+ 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. *)
+
+(* \newcommand{\setupFourAmp}{%
+ \fmfleft{i1,i2}
+ \fmfright{o1,o2}
+ \fmf{phantom}{i1,v1,i2}
+ \fmf{phantom}{o2,v2,o1}
+ \fmf{phantom}{v1,v2}
+ \fmffreeze}
+ \fmfcmd{%
+ numeric joindiameter;
+ joindiameter := 7thick;}
+ \fmfcmd{%
+ vardef sideways_at (expr d, p, frac) =
+ save len; len = length p;
+ (point frac*len of p) shifted ((d,0) rotated (90 + angle direction frac*len of p))
+ enddef;
+ secondarydef p sideways d =
+ for frac = 0 step 0.01 until 0.99:
+ sideways_at (d, p, frac) ..
+ endfor
+ sideways_at (d, p, 1)
+ enddef;
+ secondarydef p choptail d =
+ subpath (ypart (fullcircle scaled d shifted (point 0 of p) intersectiontimes p), infinity) of p
+ enddef;
+ secondarydef p choptip d =
+ reverse ((reverse p) choptail d)
+ enddef;
+ secondarydef p pointtail d =
+ fullcircle scaled d shifted (point 0 of p) intersectionpoint p
+ enddef;
+ secondarydef p pointtip d =
+ (reverse p) pointtail d
+ enddef;
+ secondarydef pa join pb =
+ pa choptip joindiameter .. pb choptail joindiameter
+ enddef;
+ vardef cyclejoin (expr p) =
+ subpath (0.5*length p, infinity) of p join subpath (0, 0.5*length p) of p .. cycle
+ enddef;}
+ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+ \fmfcmd{%
+ style_def double_line_arrow expr p =
+ save pi, po;
+ path pi, po;
+ pi = reverse (p sideways thick);
+ po = p sideways -thick;
+ cdraw pi;
+ cdraw po;
+ cfill (arrow (subpath (0, 0.9 length pi) of pi));
+ cfill (arrow (subpath (0, 0.9 length po) of po));
+ enddef;}
+ \fmfcmd{%
+ style_def double_line_arrow_beg expr p =
+ save pi, po, pc;
+ path pi, po, pc;
+ pc = p choptail 7thick;
+ pi = reverse (pc sideways thick);
+ po = pc sideways -thick;
+ cdraw pi .. p pointtail 5thick .. po;
+ cfill (arrow pi);
+ cfill (arrow po);
+ enddef;}
+ \fmfcmd{%
+ style_def double_line_arrow_end expr p =
+ save pi, po, pc;
+ path pi, po, pc;
+ pc = p choptip 7thick;
+ pi = reverse (pc sideways thick);
+ po = pc sideways -thick;
+ cdraw po .. p pointtip 5thick .. pi;
+ cfill (arrow pi);
+ cfill (arrow po);
+ enddef;}
+ \fmfcmd{%
+ style_def double_line_arrow_both expr p =
+ save pi, po, pc;
+ path pi, po, pc;
+ pc = p choptip 7thick choptail 7thick;
+ pi = reverse (pc sideways thick);
+ po = pc sideways -thick;
+ cdraw po .. p pointtip 5thick .. pi .. p pointtail 5thick .. cycle;
+ cfill (arrow pi);
+ cfill (arrow po);
+ enddef;}
+ \fmfcmd{%
+ style_def double_arrow_parallel expr p =
+ save pi, po;
+ path pi, po;
+ pi = p sideways thick;
+ po = p sideways -thick;
+ save li, lo;
+ li = length pi;
+ lo = length po;
+ cdraw pi;
+ cdraw po;
+ cfill (arrow pi);
+ cfill (arrow po);
+ enddef;}
+ \fmfcmd{%
+ style_def double_arrow_crossed_beg expr p =
+ save lp; lp = length p;
+ save pi, po;
+ path pi, po;
+ pi = p sideways thick;
+ po = p sideways -thick;
+ save li, lo;
+ li = length pi;
+ lo = length po;
+ cdraw subpath (0, 0.1 li) of pi .. subpath (0.3 lo, lo) of po;
+ cdraw subpath (0, 0.1 lo) of po .. subpath (0.3 li, li) of pi;
+ cfill (arrow pi);
+ cfill (arrow po);
+ enddef;}
+ \fmfcmd{%
+ style_def double_arrow_crossed_end expr p =
+ save lp; lp = length p;
+ save pi, po;
+ path pi, po;
+ pi = p sideways thick;
+ po = p sideways -thick;
+ save li, lo;
+ li = length pi;
+ lo = length po;
+ cdraw subpath (0, 0.7 li) of pi .. subpath (0.9 lo, lo) of po;
+ cdraw subpath (0, 0.7 lo) of po .. subpath (0.9 li, li) of pi;
+ cfill (arrow pi);
+ cfill (arrow po);
+ enddef;} *)
+
+(* \thocwmodulesection{Arrows and Epsilons} *)
+
+type endpoint =
+ | I of int
+ | M of int * int
+
+let position_endpoint = function
+ | I i -> i
+ | M (i, _) -> i
+
+let relocate_endpoint f = function
+ | I i -> I (f i)
+ | M (i, n) -> M (f i, n)
+
+type tip = endpoint
+type tail = endpoint
+type ghost = endpoint
+
+let position_tip = position_endpoint
+let position_tail = position_endpoint
+let position_ghost = position_endpoint
+let relocate_tip = relocate_endpoint
+let relocate_tail = relocate_endpoint
+let relocate_ghost = relocate_endpoint
+
+(* Note that in the case of double lines for the adjoint
+ representation the \emph{same} [endpoint] appears twice:
+ once as a [tip] and once as a [tail]. If we want to
+ multiply two factors by merging arrows with matching
+ [tip] and [tail], we must make sure that the [tip] is from
+ one factor and the [tail] from the other factor. *)
+
+(* The [Free] variant contains positive indices
+ as well as negative indices that don't appear on both sides
+ and will be summed in a later product. [SumL] and [SumR]
+ indices appear on both sides. *)
+type 'a index =
+ | Free of 'a
+ | SumL of 'a
+ | SumR of 'a
+
+let is_free_index = function
+ | Free _ -> true
+ | SumL _ | SumR _ -> false
+
+type ('tail, 'tip, 'ghost) t =
+ | Arrow of 'tail * 'tip
+ | Ghost of 'ghost
+type 'tip eps = 'tip list
+type 'tail eps_bar = 'tail list
+
+type free = (tail, tip, ghost) t
+type free_eps = tip eps
+type factor_eps = tip index eps
+
+type factor = (tail index, tip index, ghost index) t
+type free_eps_bar = tail eps_bar
+type factor_eps_bar = tail index eps_bar
+
+let relocate f = function
+ | Arrow (tail, tip) -> Arrow (relocate_tail f tail, relocate_tip f tip)
+ | Ghost ghost -> Ghost (relocate_ghost f ghost)
+
+let rev = function
+ | Arrow (tail, tip) -> Arrow (tip, tail)
+ | Ghost _ as ghost -> ghost
+let rev_eps tips = tips
+let rev_eps_bar tails = tails
+
+let tips = function
+ | Arrow (_, tip) -> [tip]
+ | Ghost _ -> []
+let tails = function
+ | Arrow (tail, _) -> [tail]
+ | Ghost _ -> []
+let tips_eps tips = tips
+let tails_eps_bar tails = tails
+
+let endpoint_to_string = function
+ | I i -> string_of_int i
+ | M (i, n) -> Printf.sprintf "%d.%d" i n
+
+let index_to_string = function
+ | Free i -> endpoint_to_string i
+ | SumL i -> endpoint_to_string i ^ "L"
+ | SumR i -> endpoint_to_string i ^ "R"
+
+let to_string i2s = function
+ | Arrow (tail, tip) -> Printf.sprintf "%s>%s" (i2s tail) (i2s tip)
+ | Ghost ghost -> Printf.sprintf "{%s}" (i2s ghost)
+let to_string_eps i2s tips = Printf.sprintf ">>>%s" (ThoList.to_string i2s tips)
+let to_string_eps_bar i2s tails = Printf.sprintf "<<<%s" (ThoList.to_string i2s tails)
+
+let free_to_string = to_string endpoint_to_string
+let free_eps_to_string = to_string_eps endpoint_to_string
+let free_eps_bar_to_string = to_string_eps_bar endpoint_to_string
+
+let factor_to_string = to_string index_to_string
+let factor_eps_to_string = to_string_eps index_to_string
+let factor_eps_bar_to_string = to_string_eps_bar index_to_string
+
+let matching_summation i1 i2 =
+ match i1, i2 with
+ | SumL i1, SumR i2 | SumR i1, SumL i2 -> i1 = i2
+ | _ -> false
+
+let map f = function
+ | Arrow (tail, tip) -> Arrow (f tail, f tip)
+ | Ghost ghost -> Ghost (f ghost)
+let map_eps = List.map
+let map_eps_bar = List.map
+
+let free_index = function
+ | Free i -> i
+ | SumL i -> invalid_arg "Arrow.free_index: leftover LHS summation"
+ | SumR i -> invalid_arg "Arrow.free_index: leftover RHS summation"
+
+let to_left_index is_sum i =
+ if is_sum i then
+ SumL i
+ else
+ Free i
+
+let to_right_index is_sum i =
+ if is_sum i then
+ SumR i
+ else
+ Free i
+
+let to_left_factor is_sum = map (to_left_index is_sum)
+let to_right_factor is_sum = map (to_right_index is_sum)
+let of_factor = map free_index
+
+let to_left_factor_eps is_sum = map_eps (to_left_index is_sum)
+let to_right_factor_eps is_sum = map_eps (to_right_index is_sum)
+let of_factor_eps = map_eps free_index
+
+let to_left_factor_eps_bar is_sum = map_eps_bar (to_left_index is_sum)
+let to_right_factor_eps_bar is_sum = map_eps_bar (to_right_index is_sum)
+let of_factor_eps_bar = map_eps_bar free_index
+
+let negatives = function
+ | Arrow (tail, tip) ->
+ if position_tail tail < 0 then
+ if position_tip tip < 0 then
+ [tail; tip]
+ else
+ [tail]
+ else if position_tip tip < 0 then
+ [tip]
+ else
+ []
+ | Ghost ghost ->
+ if position_ghost ghost < 0 then
+ [ghost]
+ else
+ []
+let negatives_eps = List.filter (fun tip -> position_tip tip < 0)
+let negatives_eps_bar = List.filter (fun tail -> position_tail tail < 0)
+
+let is_free = function
+ | Arrow (Free _, Free _) | Ghost (Free _) -> true
+ | Arrow (_, _) | Ghost _ -> false
+let is_free_eps = List.for_all is_free_index
+let is_free_eps_bar = List.for_all is_free_index
+
+let is_ghost = function
+ | Ghost _ -> true
+ | Arrow _ -> false
+
+let single tail tip =
+ Arrow (tail, tip)
+
+let double a b =
+ if a = b then
+ [single a b]
+ else
+ [single a b; single b a]
+
+let ghost g =
+ Ghost g
+
+module Infix =
+ struct
+ let ( => ) i j = single (I i) (I j)
+ let ( ==> ) i j = [i => j]
+ let ( <=> ) i j = double (I i) (I j)
+ let ( >=> ) (i, n) j = single (M (i, n)) (I j)
+ let ( =>> ) i (j, m) = single (I i) (M (j, m))
+ let ( >=>> ) (i, n) (j, m) = single (M (i, n)) (M (j, m))
+ let ( ?? ) i = ghost (I i)
+ end
+
+open Infix
+
+(* Split [a_list] at the first element equal to [a] according
+ to [eq]. Return the reversed first part and the rest as a
+ pair and wrap it in [Some]. Return [None] if there is no match. *)
+let take_first_match_opt ?(eq=(=)) a a_list =
+ let rec take_first_match_opt' rev_head = function
+ | [] -> None
+ | elt :: tail ->
+ if eq elt a then
+ Some (rev_head, tail)
+ else
+ take_first_match_opt' (elt :: rev_head) tail in
+ take_first_match_opt' [] a_list
+
+(* Split [a_list] and [b_list] at the first element equal according
+ to [eq]. Return the reversed first part and the rest of each
+ as a pair of pairs wrap it in [Some].
+ Return [None] if there is no match.
+ \begin{dubious}
+ This function remains from an earlier version and is no longer
+ used.
+ \end{dubious} *)
+let take_first_matching_pair_opt ?(eq=(=)) a_list b_list =
+ let rec take_first_matching_pair_opt' rev_a_head = function
+ | [] -> None
+ | a :: a_tail ->
+ begin match take_first_match_opt ~eq a b_list with
+ | Some (rev_b_head, b_tail) ->
+ Some ((rev_a_head, a_tail), (rev_b_head, b_tail))
+ | None ->
+ take_first_matching_pair_opt' (a :: rev_a_head) a_tail
+ end in
+ take_first_matching_pair_opt' [] a_list
+
+(* Replace the first occurence of an element equal to [a] according
+ to [eq] in [a_list] by [a'] and wrap the new list in [Some].
+ Return [None] if there is no match. *)
+let replace_first_opt ?(eq=(=)) a a' a_list =
+ match take_first_match_opt ~eq a a_list with
+ | Some (rev_head, tail) -> Some (List.rev_append rev_head (a' :: tail))
+ | None -> None
+
+let tee a = function
+ | Arrow (tail, tip) -> [Arrow (tail, I a); Arrow (I a, tip)]
+ | Ghost _ as g -> [g]
+
+let dir i j = function
+ | Arrow (tail, tip) ->
+ let tail = position_tail tail
+ and tip = position_tip tip in
+ if tip = i && tail = j then
+ 1
+ else if tip = j && tail = i then
+ -1
+ else
+ invalid_arg "Arrow.dir"
+ | Ghost _ -> 0
+
+type merge =
+ | Match of factor
+ | Ghost_Match
+ | Loop_Match
+ | Mismatch
+ | No_Match
+
+(* As an optimization, don't attempt to merge if neither of the arrows
+ contains a summation index and return immediately. *)
+
+let merge_arrow_arrow arrow1 arrow2 =
+ if is_free arrow1 || is_free arrow2 then
+ No_Match
+ else
+ match arrow1, arrow2 with
+ | Ghost g1, Ghost g2 ->
+ if matching_summation g1 g2 then
+ Ghost_Match
+ else
+ No_Match
+ | Arrow (tail, tip), Ghost g
+ | Ghost g, Arrow (tail, tip) ->
+ if matching_summation g tail || matching_summation g tip then
+ Mismatch
+ else
+ No_Match
+ | Arrow (tail, tip), Arrow (tail', tip') ->
+ if matching_summation tip tail' then
+ if matching_summation tip' tail then
+ Loop_Match
+ else
+ Match (Arrow (tail, tip'))
+ else if matching_summation tip' tail then
+ Match (Arrow (tail', tip))
+ else
+ No_Match
+
+type 'a merge_eps =
+ | Match_Eps of 'a
+ | Mismatch_Eps
+ | No_Match_Eps
+
+let merge_arrow_eps arrow tips =
+ if is_free_eps tips || is_free arrow then
+ No_Match_Eps
+ else
+ match arrow with
+ | Arrow (tail, tip) ->
+ begin match replace_first_opt ~eq:matching_summation tail tip tips with
+ | None -> No_Match_Eps
+ | Some tips -> Match_Eps tips
+ end
+ | Ghost g ->
+ if List.exists (matching_summation g) tips then
+ Mismatch_Eps
+ else
+ No_Match_Eps
+
+let merge_arrow_eps_bar arrow tails =
+ if is_free_eps_bar tails || is_free arrow then
+ No_Match_Eps
+ else
+ match arrow with
+ | Arrow (tail, tip) ->
+ begin match replace_first_opt ~eq:matching_summation tip tail tails with
+ | None -> No_Match_Eps
+ | Some tails -> Match_Eps tails
+ end
+ | Ghost g ->
+ if List.exists (matching_summation g) tails then
+ Mismatch_Eps
+ else
+ No_Match_Eps
+
+(* \thocwmodulesection{Evaluation Rules for Epsilon Tensors}
+ \label{sec:evaluation-of-epsilon-tensors} *)
+
+(* In the case of matching dimension~$N=\delta_m^m$ and rank~$n$
+ of~$\epsilon$ and $\bar\epsilon$, the tensor algebra of
+ the $\delta_{i}^{j}$, $\epsilon_{i_1i_2\cdots i_n}$
+ and $\bar\epsilon^{j_1j_2\cdots j_n}$ is \emph{not} freely generated.
+ Indeed, introducing the \emph{generalized Kronecker~$\delta$} symbol
+ \begin{equation}
+ \label{eq:generalized-delta}
+ \delta_{i_1i_2\cdots i_n}^{j_1j_2\cdots j_n}
+ = \sum_{\sigma\in S_n} (-1)^{\varepsilon(\sigma)}
+ \delta_{i_1}^{\sigma(j_1)}
+ \delta_{i_2}^{\sigma(j_2)}
+ \cdots
+ \delta_{i_n}^{\sigma(j_n)}
+ = \sum_{\sigma\in S_n} (-1)^{\varepsilon(\sigma)}
+ \delta_{\sigma(i_1)}^{j_1}
+ \delta_{\sigma(i_2)}^{j_2}
+ \cdots
+ \delta_{\sigma(i_n)}^{j_n}
+ = \begin{vmatrix}
+ \delta_{i_1}^{j_1} & \delta_{i_1}^{j_2} & \cdots & \delta_{i_1}^{j_n} \\
+ \delta_{i_2}^{j_1} & \delta_{i_2}^{j_2} & \cdots & \delta_{i_2}^{j_n} \\
+ \vdots & \vdots & \ddots & \vdots \\
+ \delta_{i_n}^{j_1} & \delta_{i_n}^{j_2} & \cdots & \delta_{i_n}^{j_n}
+ \end{vmatrix} \,,
+ \end{equation}
+ there is the relation~$\forall n=N\in\mathbf{N}$ with~$N\ge2$:
+ \begin{equation}
+ \label{eq:epsilon*epsilonbar-0}
+ \epsilon_{i_1i_2\cdots i_n} \bar\epsilon^{j_1j_2\cdots j_n}
+ = \delta_{i_1i_2\cdots i_n}^{j_1j_2\cdots j_n}\,,
+ \end{equation}
+ which follows from anti-symmetry and the choice of normalization
+ $\epsilon_{12\cdots n} = 1 = \bar\epsilon^{12\cdots n}$ alone.
+ Contracting $k$ indices in the relation~\eqref{eq:epsilon*epsilonbar-0},
+ we find~$\forall k, n, N \in \mathbf{N}$ with $0 \le k \le n = N\ge2$:
+ \begin{equation}
+ \label{eq:epsilon*epsilonbar}
+ \epsilon_{m_1\cdots m_ki_{k+1}\cdots i_n}
+ \bar\epsilon^{m_1\cdots m_kj_{k+1}\cdots j_n}
+ = k!\, \delta_{i_{k+1}i_{k+2}\cdots i_n}^{j_{k+1}j_{k+2}\cdots j_n}\,.
+ \end{equation} *)
+
+(* Note that the generalized Kronecker delta~\eqref{eq:generalized-delta}
+ is well defined for arbitrary rank~$n\ge1$, including $n<N$, and
+ vanishes for $n>N$. It satisfies
+ \begin{subequations}
+ \label{eq:delta*delta/epsilon}
+ \begin{align}
+ \label{eq:delta*delta}
+ \delta_{i_1i_2\cdots i_n}^{j_1j_2\cdots j_n}
+ \delta_{j_1j_2\cdots j_n}^{k_1k_2\cdots k_n}
+ &= n!\, \delta_{i_1i_2\cdots i_n}^{k_1k_2\cdots k_n} \\
+ \label{eq:delta*epsilon}
+ \delta_{i_1i_2\cdots i_n}^{j_1j_2\cdots j_n}
+ \epsilon_{j_1j_2\cdots j_n}
+ &= n!\, \epsilon_{i_1i_2\cdots i_n} \\
+ \label{eq:delta*epsilonbar}
+ \delta_{i_1i_2\cdots i_n}^{j_1j_2\cdots j_n}
+ \bar\epsilon^{i_1i_2\cdots i_n}
+ &= n!\, \bar\epsilon^{j_1j_2\cdots j_n}
+ \end{align}
+ \end{subequations}
+ since every $\sigma\in S_n$ gives the same contribution when contracting
+ totally antisymmetric combinations. Note also that the
+ relations~\eqref{eq:delta*delta/epsilon}
+ are independent of the dimension~$N$ and remain valid for rank~$n\not=N$,
+ as long as~$\epsilon_{i_1i_2\cdots i_n}$
+ and~$\bar\epsilon^{j_1j_2\cdots j_n}$ are totally antisymmetric.
+
+ In our birdtrack based evaluator, the condition~$N=n$ is not enforced.
+ Indeed, $N$ is just a variable in Laurent polynomials [Algebra.Laurent.t]
+ and $n$ is the arbitrary length of the lists in [tip Arrow.eps] and
+ [tail Arrow.eps_bar] of colorflows. Therefore, we can use
+ neither~\eqref{eq:epsilon*epsilonbar-0}
+ nor~\eqref{eq:epsilon*epsilonbar} directly to test our evaluator. *)
+
+(* Nevertheless, for the purpose of testing our evaluator,
+ we can \emph{define} a \emph{formal} evaluation rule for
+ birdtracks in the general case~$N\not=n$,
+ that is compatible with anti-symmetry and reduces
+ to~\eqref{eq:epsilon*epsilonbar-0} for $N=n$
+ \begin{equation}
+ \label{eq:epsilon*epsilonbar-generalized}
+%%% \forall 2\le n \le N \in\mathbf{N}:\;
+ \epsilon_{i_1i_2\cdots i_n} \bar\epsilon^{j_1j_2\cdots j_n}
+ \to \delta_{i_1i_2\cdots i_n}^{j_1j_2\cdots j_n}\,,
+ \end{equation}
+ where we use the arrow $\to$ instead of the equal sign to stress
+ that is a rule and not an equation, in contrast to the special
+ case~\eqref{eq:epsilon*epsilonbar-0} for~$n=N$. *)
+
+let merge_eps_eps_bar tips tails =
+ if List.length tails <> List.length tips then
+ None
+ else
+ Some (List.fold_left
+ (fun (even, odd) (eps, tips) ->
+ if eps > 0 then
+ (List.rev_map2 single tails tips :: even, odd)
+ else
+ (even, List.rev_map2 single tails tips :: odd))
+ ([], []) (Combinatorics.permute_signed tips))
+
+(* Contracting one index, we find the equation
+ \begin{multline}
+ \delta_{mi_2\cdots i_n}^{mj_2\cdots j_n}
+ = \delta_m^m
+ \sum_{\substack{\sigma\in S_n\\\sigma(m)=m}}
+ (-1)^{\varepsilon(\sigma)}
+ \delta_{i_2}^{\sigma(j_2)}
+ \cdots
+ \delta_{i_n}^{\sigma(j_n)}
+ + \sum_{\substack{\sigma\in S_n\\\sigma(m)\not=m}}
+ (-1)^{\varepsilon(\sigma)}
+ \delta_{m}^{\sigma(m)}
+ \delta_{i_2}^{\sigma(j_2)}
+ \cdots
+ \delta_{i_n}^{\sigma(j_n)} \\
+ = N \delta_{i_2\cdots i_n}^{j_2\cdots j_n}
+ - (n-1)\, \delta_{i_2\cdots i_n}^{j_2\cdots j_n}
+ = (N - n + 1)\, \delta_{i_2\cdots i_n}^{j_2\cdots j_n}\,,
+ \end{multline}
+ where the~$N=\delta_m^m$ comes from the permutations with~$\sigma(m)=m$
+ that correspond to a loop in the color flow and the~$n-1$ from the
+ permutations with~$\sigma(m)\in\{i_2,\ldots,i_n\}$ that do not
+ lead to a loop. The minus is due to the fact that there is exactly
+ one transposition $m\leftrightarrow\sigma(m)$. Thus the consistent
+ evalution rule for a contracted $\epsilon$-$\bar\epsilon$-pair is
+ \begin{equation}
+ \label{eq:epsilon*epsilonbar-single-contraction}
+%%% \forall 2\le n \le N \in\mathbf{N}:\;
+ \epsilon_{mi_2\cdots i_n} \bar\epsilon^{mj_2\cdots j_n}
+ \to \delta_{mi_2\cdots i_n}^{mj_2\cdots j_n}
+ = (N-n+1)\, \delta_{i_2\cdots i_n}^{j_2\cdots j_n}\,.
+ \end{equation}
+ Note that~$N-n+1=1$ in the special case~$N=n$ when
+ rank and dimension match.
+ Proceeding by induction, we obtain the equation
+ \begin{equation}
+%%% \forall k, n, N \in \mathbf{N}, 2\le n \le N \land 1\le k \le n:\;
+ \delta_{m_1\cdots m_ki_{k+1}\cdots i_n}^{m_1\cdots m_kj_{k+1}\cdots j_n}
+ = \frac{(N-n+k)!}{(N-n)!}\,
+ \delta_{i_{k+1}i_{k+2}\cdots i_n}^{j_{k+1}j_{k+2}\cdots j_n}
+ \end{equation}
+ and the corresponding evaluation rule
+ \begin{equation}
+ \label{eq:epsilon*epsilonbar-generalized-contracted}
+%%% \forall k, n, N \in \mathbf{N}, 2\le n \le N \land 1\le k \le n:\;
+ \epsilon_{m_1\cdots m_ki_{k+1}\cdots i_n}
+ \bar\epsilon^{m_1\cdots m_kj_{k+1}\cdots j_n}
+ \to \delta_{m_1\cdots m_ki_{k+1}\cdots i_n}^{m_1\cdots m_kj_{k+1}\cdots j_n}
+ = \frac{(N-n+k)!}{(N-n)!}\,
+ \delta_{i_{k+1}i_{k+2}\cdots i_n}^{j_{k+1}j_{k+2}\cdots j_n}\,,
+ \end{equation}
+ where
+ \begin{equation}
+ \frac{(N-n+k)!}{(N-n)!} = (N-n+1)(N-n+2)\cdots(N-n+k)\,.
+ \end{equation}
+ In the case~$N=n$, we recover
+ \begin{equation}
+ \frac{(N-n+k)!}{(N-n)!} = k!
+ \end{equation}
+ as in~\eqref{eq:epsilon*epsilonbar}, of course. *)
+
+(* \thocwmodulesubsection{Ambiguities for $n\not=N$} *)
+
+(* While~\eqref{eq:epsilon*epsilonbar-generalized}
+ and~\eqref{eq:epsilon*epsilonbar-generalized-contracted} can be used
+ for a single pair of $\epsilon$ and $\bar\epsilon$, it must be stressed
+ that~\eqref{eq:epsilon*epsilonbar-generalized} is \emph{not}
+ a well defined rule for more general expressions in the case~$n\not=N$,
+ because the result depends on the way pairs of $\epsilon$ and $\bar\epsilon$
+ are chosen for the application of the rule.
+
+ As a simple example
+ consider the complete pairwise contractions of two $\epsilon$
+ and two $\bar\epsilon$
+ \begin{equation}
+ \label{eq:eps2-epsbar2}
+ \epsilon_{i_1i_2\cdots i_n} \bar\epsilon^{i_1i_2\cdots i_n}
+ \epsilon_{j_1j_2\cdots j_n} \bar\epsilon^{j_1j_2\cdots j_n}\,.
+ \end{equation}
+ Using~\eqref{eq:epsilon*epsilonbar-generalized}, this can be evaluated in two ways
+ \begin{subequations}
+ \label{eq:eps2-epsbar2*}
+ \begin{equation}
+ \label{eq:eps2-epsbar2*a}
+ \epsilon_{i_1i_2\cdots i_n} \bar\epsilon^{i_1i_2\cdots i_n}
+ \epsilon_{j_1j_2\cdots j_n} \bar\epsilon^{j_1j_2\cdots j_n}
+ = \left( \epsilon_{i_1i_2\cdots i_n} \bar\epsilon^{i_1i_2\cdots i_n} \right)^2
+ \to \left(\frac{(N-n+n)!}{(N-n)!}\right)^2
+ = \left(\frac{N!}{(N-n)!} \right)^2
+ \end{equation}
+ and
+ \begin{multline}
+ \label{eq:eps2-epsbar2*b}
+ \epsilon_{i_1i_2\cdots i_n} \bar\epsilon^{i_1i_2\cdots i_n}
+ \epsilon_{j_1j_2\cdots j_n} \bar\epsilon^{j_1j_2\cdots j_n}
+ = \left(\epsilon_{i_1i_2\cdots i_n} \bar\epsilon^{j_1j_2\cdots j_n}\right)
+ \left(\epsilon_{j_1j_2\cdots j_n} \bar\epsilon^{i_1i_2\cdots i_n}\right) \\
+ \to \delta^{j_1j_2\cdots j_n}_{i_1i_2\cdots i_n}
+ \delta_{j_1j_2\cdots j_n}^{i_1i_2\cdots i_n}
+ = n!\, \delta^{j_1j_2\cdots j_n}_{i_1i_2\cdots i_n}
+ = n!\, \frac{(N-n+n)!}{(N-n)!}
+ = \frac{N!n!}{(N-n)!}\,,
+ \end{multline}
+ \end{subequations}
+ which agree only for~$N=n$.
+ This observation must be taken into account when interpreting the results
+ of self tests.
+
+ Even if the expressions~\eqref{eq:eps2-epsbar2*a} and~\eqref{eq:eps2-epsbar2*b}
+ agree for~$n=N$, one might wonder if they correspond to two different
+ physical interpretations of the color flows.
+ The expression~\eqref{eq:eps2-epsbar2} appears in the color summed
+ square matrix elements for $2n$~particles that contain
+ color flows of the form
+ \begin{equation}
+ \epsilon_{i_1i_2\cdots i_n}\bar\epsilon^{j_1j_2\cdots j_n} =
+ \parbox{28\unitlength}{%
+ \fmfframe(4,4)(4,4){%
+ \begin{fmfgraph*}(25,15)
+ \fmfleft{i1,i2,i3}
+ \fmfright{j1,j2,j3}
+ \fmfv{label=$\epsilon$,label.angle=0}{e}
+ \fmfv{label=$\bar\epsilon$,label.angle=180}{eb}
+ \fmf{fermion}{i1,e}
+ \fmf{fermion}{i2,e}
+ \fmf{fermion}{i3,e}
+ \fmf{fermion}{eb,j1}
+ \fmf{fermion}{eb,j2}
+ \fmf{fermion}{eb,j3}
+ \fmf{phantom,tension=1.5}{e,eb}
+ \fmfdot{e,eb}
+ \end{fmfgraph*}}}\,.
+ \end{equation}
+ The evaluation~\eqref{eq:eps2-epsbar2*a} corresponds to coupling
+ $n$~particles carrying the flows $\epsilon_{i_1,i_2,\ldots i_n}$
+ to the $n$ particles carrying the flows $\bar\epsilon^{j_1,j_2,\ldots j_n}$
+ via an intermediate color singlet state.
+ On the other hand, the evaluation~\eqref{eq:eps2-epsbar2*b} corresponds to
+ substituting this flow by
+ \begin{equation}
+ \delta_{i_1i_2\cdots i_n}^{j_1j_2\cdots j_n} =
+ \parbox{28\unitlength}{%
+ \fmfframe(4,4)(4,4){%
+ \begin{fmfgraph}(20,10)
+ \fmfleft{i1,i2,i3}
+ \fmfright{j1,j2,j3}
+ \fmf{fermion}{i1,j1}
+ \fmf{fermion}{i2,j2}
+ \fmf{fermion}{i3,j3}
+ \end{fmfgraph}}} -
+ \parbox{28\unitlength}{%
+ \fmfframe(4,4)(4,4){%
+ \begin{fmfgraph}(20,10)
+ \fmfleft{i1,i2,i3}
+ \fmfright{j1,j2,j3}
+ \fmf{plain}{i1,d1}
+ \fmf{plain,rubout}{i2,d2}
+ \fmf{fermion,tension=2}{d1,j2}
+ \fmf{fermion,tension=2}{d2,j1}
+ \fmf{fermion}{i3,j3}
+ \end{fmfgraph}}} +
+ \parbox{28\unitlength}{%
+ \fmfframe(4,4)(4,4){%
+ \begin{fmfgraph}(20,10)
+ \fmfleft{i1,i2,i3}
+ \fmfright{j1,j2,j3}
+ \fmf{fermion}{i1,d1}
+ \fmf{plain,rubout}{i2,d2}
+ \fmf{plain}{d1,j2}
+ \fmf{fermion,rubout}{d2,j3}
+ \fmf{fermion,rubout}{i3,j1}
+ \end{fmfgraph}}} + \ldots\,,
+ \end{equation}
+ which, at first sight, appears to introduce colored intermediate states.
+
+ However,
+ this is not really the case, because the colors cancel out for $n=N=N_C$.
+ This can be seen by looking at the scattering of such a state with a
+ particle in the fundamental representation
+ \begin{equation}
+ \parbox{28\unitlength}{%
+ \fmfframe(4,4)(4,4){%
+ \begin{fmfgraph*}(25,15)
+ \fmfleft{i1,i2}
+ \fmfright{j1,j2}
+ \fmflabel{$A_n$}{i2}
+ \fmflabel{$A_n$}{j2}
+ \fmflabel{$N$}{i1}
+ \fmflabel{$N$}{j1}
+ \fmf{fermion}{i1,v1,j1}
+ \fmf{dbl_plain_arrow}{i2,v2,j2}
+ \fmf{gluon,tension=0.4}{v1,v2}
+ \fmfdot{v1,v2}
+ \end{fmfgraph*}}}
+ \end{equation}
+ and calculating the spin summed squared matrix element
+ \begin{multline}
+ \label{eq:AnS1->AnS1}
+ \sum \left|M_n\right|^2
+ = \tr\left(T^{A_n}_a T^{A_n}_b\right) \tr\left(T_a T_b\right)
+ = \tr\left(T^{A_n}_a T^{A_n}_a\right)
+ = \dim(A_n) C_2(A_n) \\
+%%% = { N \choose n } \frac{n(N-n)(N+1)}{N}
+ = \frac{N!}{n!(N-n)!} \frac{n(N-n)(N+1)}{N}
+ = \frac{N+1}{(n-1)!}\frac{(N-1)!}{(N-n-1)!}
+ \end{multline}
+ where~$T^{A_n}$ denotes the generator,
+ $\dim(A_n)$ the dimension and
+ $C_2(A_n)$ the quadratic Casimir~\eqref{eq:C_2(A_n)}
+ in the totally antisymmetric
+ product of $n$ fundamental representations\footnote{%
+ We can use~\eqref{eq:AnS1->AnS1} to test our
+ evaluator and find agreement, e.\,g.~for $n=2,3,4,5$
+ \begin{subequations}
+ \begin{align}
+ \sum \left|M_2\right|^2
+%% % = \left( N^3 - 2 N^2 - N + 2 \right)
+ &= \left(N+1\right) \left(N-1\right) \left(N-2\right) \\
+ \sum \left|M_3\right|^2
+%% % = \frac{1}{2} \left( N^4 - 5 N^3 + 5 N^2 + 5 N - 6 \right)
+ &= \frac{N+1}{2} \left(N-1\right) \left(N-2\right)
+ \left(N-3\right) \\
+ \sum \left|M_4\right|^2
+%% % = \frac{1}{6} \left( N^5 - 9 N^4 + 25 N^3 - 15 N^2 - 26 N + 24 \right)
+ &= \frac{N+1}{6} \left(N-1\right) \left(N-2\right)
+ \left(N-3\right) \left(N-4\right) \\
+ \sum \left|M_5\right|^2
+ &= \frac{N+1}{24} \left(N-1\right) \left(N-2\right)
+ \left(N-3\right) \left(N-4\right) \left(N-5\right) \,.
+ \end{align}
+ \end{subequations}}.
+ This expression vanishes for $n\ge N$ and is non-zero for
+ $n<N$. The case $n>N$ is obvious from antisymmetry, but
+ the case $n=N$ depends on the fact that the totally antisymmetric
+ product of $N$ fundamental representations corresponds to a singlet.
+ Therefore, we are free to choose arbitrary pairings of
+ $\epsilon$ with $\bar\epsilon$ without affecting the our results for
+ summed squared matrix elements.
+
+ Nevertheless, there appear to remain ambiguities in amplitudes with
+ more than one $\epsilon$ or $\bar\epsilon$. For $n=N=3$, they first appear
+ in amplitudes for 5~particles. These can contain
+ color flows of the form
+ \begin{equation}
+ M_{i_1i_2,j_1j_2}^{k}
+ = \epsilon_{i_1i_2m_1}\epsilon_{j_1j_2m_2} \bar\epsilon^{m_1m_2k}
+ \end{equation}
+ and we have to decide whether to evaluate this as
+ \begin{subequations}
+ \begin{equation}
+ M_{i_1i_2,j_1j_2}^{k}
+ \to M_{i_1i_2,j_1j_2}^{(j)\,k}
+ = \epsilon_{i_1i_2m_1}
+ (N-2)\,\left( \delta_{j_1}^{k}\delta_{j_2}^{m_1}
+ - \delta_{j_1}^{m_1}\delta_{j_2}^{k} \right) \\
+ =
+ (N-2)\,\left( \epsilon_{i_1i_2j_2} \delta_{j_1}^{k}
+ - \epsilon_{i_1i_2j_1} \delta_{j_2}^{k} \right)
+ \end{equation}
+ or
+ \begin{equation}
+ M_{i_1i_2,j_1j_2}^{k}
+ \to M_{i_1i_2,j_1j_2}^{(i)\,k}
+ = \epsilon_{j_1j_2m_2}
+ (N-2)\,\left( \delta_{i_1}^{m_2}\delta_{i_2}^{k}
+ - \delta_{i_1}^{k}\delta_{i_2}^{m_2} \right)
+ = (N-2)\,\left( \epsilon_{j_1j_2i_1}\delta_{i_2}^{k}
+ - \epsilon_{j_1j_2i_2}\delta_{i_1}^{k} \right)\,,
+ \end{equation}
+ \end{subequations}
+ where the superscript denotes which of the $\epsilon$ has been
+ contracted with the $\bar\epsilon$ using~\eqref{eq:epsilon*epsilonbar}.
+ These results are manifestly antisymmetric under the exchange of
+ the elements of each of the two pairs of indices separately, but
+ not under the exchange of the pairs.
+
+ Fortunately, in the case~$n=N$, we can make use of relations
+ of the form
+ \begin{equation}
+ \label{eq:sum(epsilon*delta)=0}
+ \sum_{\sigma\in S_{n+1}} (-1)^{\varepsilon(\sigma)}
+ \epsilon_{\sigma(i_1)\sigma(i_2)\cdots\sigma(i_n)}
+ \delta_{\sigma(i_{n+1})}^j = 0\,,
+ \end{equation}
+ that follow from the fact that there is no totally antisymmetric
+ tensor of rank~$n>N$ in $N$ dimensions. For example
+ \begin{equation}
+ \epsilon_{ijk}\delta_l^m
+ - \epsilon_{lij}\delta_k^m
+ + \epsilon_{kli}\delta_j^m
+ - \epsilon_{jkl}\delta_i^m
+ = 0
+ \end{equation}
+ or
+ \begin{equation}
+ \epsilon_{ijk}\delta_l^m
+ - \epsilon_{ijl}\delta_k^m
+ = - \epsilon_{kli}\delta_j^m
+ + \epsilon_{klj}\delta_i^m
+ \end{equation}
+ proves that
+ \begin{equation}
+ M_{i_1i_2,j_1j_2}^{(j)\,k}
+ = - M_{j_1j_2,i_1i_2}^{(j)\,k}
+ \end{equation}
+ and equivalent relations for~$M^{(k)}$ and~$M^{(i)}$ in the
+ case~$n=N=3$. Therefore the amplitudes satisfy all symmetry
+ requirements in the physical case, just not manifestly.
+
+ Note that we could also observe that
+ \begin{equation}
+ M_{i_1i_2,j_1j_2}^{(i)\,k}
+ = - M_{j_1j_2,i_1i_2}^{(j)\,k}
+ \end{equation}
+ and construct an equivalent amplitude that manifestly satisfies
+ all required antisymmetries
+ \begin{equation}
+ M_{i_1i_2,j_1j_2}^{k}
+ = \frac{1}{2}\left( M_{i_1i_2,j_1j_2}^{(i)\,k}
+ + M_{j_1j_2,i_1i_2}^{(j)\,k} \right)
+ = \frac{N-2}{2} \left(
+ \epsilon_{i_1i_2j_2} \delta_{j_1}^{k}
+ - \epsilon_{i_1i_2j_1} \delta_{j_2}^{k}
+ + \epsilon_{j_1j_2i_1}\delta_{i_2}^{k}
+ - \epsilon_{j_1j_2i_2}\delta_{i_1}^{k}
+ \right)\,.
+ \end{equation}
+ However, this approach conflicts with a recursive construction of the
+ amplitudes, since it would require a consideration of the
+ complete amplitude, using more and more complicated
+ variations on~\eqref{eq:sum(epsilon*delta)=0}. *)
+
+
+(* \thocwmodulesubsection{Evaluation Strategy}
+ \label{sec:epsilon-evaluation-strategy} *)
+
+(* Faced with a non-free tensor algebra, we have to choose
+ an evaluation strategy. If we encounter a pair of $\epsilon$
+ and $\bar\epsilon$ with a joint contracted index, we should
+ use~\eqref{eq:epsilon*epsilonbar-single-contraction} immediately.
+ Note this does not yet resolve all ambiguities because there are
+ cases in which an $\epsilon$
+ (or $\bar\epsilon$) can be contracted with more than one $\bar\epsilon$
+ (or $\epsilon$) and we have to make a choice. However, we will
+ obtain equivalent, if not manifestly equal, results in the case $n=N$.
+
+ In the case of disconnected pairs of~$\epsilon$ and $\bar\epsilon$,
+ we have to decide whether to use~\eqref{eq:epsilon*epsilonbar-generalized}
+ to produce an amplitude that contains \emph{only} $\epsilon$
+ (or $\bar\epsilon$). A disadvantage of this strategy is that
+ each application of~\eqref{eq:epsilon*epsilonbar-generalized} produces
+ $n!$ permutations of Kronecker deltas that have to be evaluated.
+ However, keeping all disconnected $\epsilon$ and $\bar\epsilon$
+ will require to try many more color flows for the complete amplitude
+ since there can be both incoming and outgoing lines that are not
+ continued through the diagram. Therefore we decide to \emph{always
+ apply~\eqref{eq:epsilon*epsilonbar-generalized} as soon as possible}.
+
+ There remains to determine a prescription for consistently selecting
+ the $\epsilon$-$\bar\epsilon$-pairs to be contracted if there is more
+ than one possibility. In particular, we \emph{must not} give in to the
+ temptation of premature optimization: when evaluating the color flows
+ for a 1POW in a fusion (cf.~[Color_Fusion],
+ pages~\pageref{sec:colorflow-fusions}\,f{}f),
+ we know the color flows for all incoming lines.
+ One is therefore tempted to choose a pair with disjoint color flows,
+ since the evaluation for this color flow could be terminated immediately.
+ Unfortunately, this would not be consistent, because a different choice
+ would be made for different color flows. Imagine, for example the fusion
+ of $\bar\epsilon^{123}$ with $\epsilon_{123}\epsilon_{456}$ or
+ $\epsilon_{456}\epsilon_{123}$. In both cases, we will obtain
+ $3!\,\epsilon_{456}$ or~$0$, depending of our choice. If we were to
+ attempt to optimize the evaluation and make the choice that results
+ in~$0$, we would not get the correct result.
+
+ Instead we have to make the \emph{same} choice for every external
+ color flow. This requires ignoring the
+ external color flow indices. For this to work, we must use an ordered
+ data structure for the unprocessed $\epsilon$ and $\bar\epsilon$. In
+ particular, we \emph{must not} use a [Set], where the ordering of the
+ elements will typically depend on the color flow indices. Instead, we
+ should use lists and apply~\eqref{eq:epsilon*epsilonbar-generalized}
+ consequently to the heads of these lists.
+ Note that selecting contracted mutually $\epsilon$-$\bar\epsilon$-pairs
+ does not introduce a dependency on the external color flow indices! *)
+
+let is_tadpole = function
+ | Arrow (tail, tip) -> matching_summation tail tip
+ | Ghost _ -> false
+
+let epsilon = function
+ | [] -> invalid_arg "Arrow.epsilon: rank 0"
+ | [_] -> invalid_arg "Arrow.epsilon: rank 1"
+ | tips -> List.map (fun tip -> I tip) tips
+
+let epsilon_bar = function
+ | [] -> invalid_arg "Arrow.epsilon_bar: rank 0"
+ | [_] -> invalid_arg "Arrow.epsilon_bar: rank 1"
+ | tails -> List.map (fun tail -> I tail) tails
+
+(* Composite Arrows. *)
+
+let rec chain = function
+ | [] -> []
+ | [a] -> [a => a]
+ | [a; b] -> [a => b]
+ | a :: (b :: _ as rest) -> (a => b) :: chain rest
+
+let rec cycle' a = function
+ | [] -> [a => a]
+ | [b] -> [b => a]
+ | b :: (c :: _ as rest) -> (b => c) :: cycle' a rest
+
+let cycle = function
+ | [] -> []
+ | a :: _ as a_list -> cycle' a a_list
+
+module Test =
+ struct
+
+ open OUnit
+
+ let suite_chain =
+ "chain" >:::
+ [ "[]" >:: (fun () -> assert_equal [] (chain []));
+ "[1]" >:: (fun () -> assert_equal [1 => 1] (chain [1]));
+ "[1;2]" >:: (fun () -> assert_equal [1 => 2] (chain [1; 2]));
+ "[1;2;3]" >:: (fun () -> assert_equal [1 => 2; 2 => 3] (chain [1; 2; 3]));
+ "[1;2;3;4]" >:: (fun () -> assert_equal [1 => 2; 2 => 3; 3 => 4] (chain [1; 2; 3; 4])) ]
+
+ let suite_cycle =
+ "cycle" >:::
+ [ "[]" >:: (fun () -> assert_equal [] (cycle []));
+ "[1]" >:: (fun () -> assert_equal [1 => 1] (cycle [1]));
+ "[1;2]" >:: (fun () -> assert_equal [1 => 2; 2 => 1] (cycle [1; 2]));
+ "[1;2;3]" >:: (fun () -> assert_equal [1 => 2; 2 => 3; 3 => 1] (cycle [1; 2; 3]));
+
+ "[1;2;3;4]" >:: (fun () -> assert_equal [1 => 2; 2 => 3; 3 => 4; 4 => 1] (cycle [1; 2; 3; 4])) ]
+
+ let suite_take =
+ "take" >:::
+ [ "1 []" >:: (fun () -> assert_equal None (take_first_match_opt 1 []));
+ "1 [1]" >:: (fun () -> assert_equal (Some ([], [])) (take_first_match_opt 1 [1]));
+ "1 [2;3;4]" >:: (fun () -> assert_equal None (take_first_match_opt 1 [2;3;4]));
+ "1 [1;2;3]" >:: (fun () -> assert_equal (Some ([], [2;3])) (take_first_match_opt 1 [1;2;3]));
+ "2 [1;2;3]" >:: (fun () -> assert_equal (Some ([1], [3])) (take_first_match_opt 2 [1;2;3]));
+ "3 [1;2;3]" >:: (fun () -> assert_equal (Some ([2;1], [])) (take_first_match_opt 3 [1;2;3])) ]
+
+ let suite_take2 =
+ "take2" >:::
+ [ "[] []" >::
+ (fun () -> assert_equal None (take_first_matching_pair_opt [] []));
+
+ "[] [1;2;3]" >::
+ (fun () -> assert_equal None (take_first_matching_pair_opt [] [1;2;3]));
+
+ "[1] [2;3;4]" >::
+ (fun () -> assert_equal None (take_first_matching_pair_opt [1] [2;3;4]));
+
+ "[2;3;4] [1]" >::
+ (fun () -> assert_equal None (take_first_matching_pair_opt [2;3;4] [1]));
+
+ "[1;2;3] [4;5;6;7]" >::
+ (fun () -> assert_equal None (take_first_matching_pair_opt [1;2;3] [4;5;6;7]));
+
+ "[1] [1;2;3]" >::
+ (fun () ->
+ assert_equal
+ (Some (([],[]), ([],[2;3])))
+ (take_first_matching_pair_opt [1] [1;2;3]));
+
+ "[1;2;3] [1;20;30]" >::
+ (fun () ->
+ assert_equal
+ (Some (([],[2;3]), ([],[20;30])))
+ (take_first_matching_pair_opt [1;2;3] [1;20;30]));
+
+ "[1;2;3;4;5;6] [10;20;4;30;40]" >::
+ (fun () ->
+ assert_equal
+ (Some (([3;2;1],[5;6]), ([20;10],[30;40])))
+ (take_first_matching_pair_opt [1;2;3;4;5;6] [10;20;4;30;40])) ]
+
+ let suite_replace =
+ "replace" >:::
+ [ "1 10 []" >:: (fun () -> assert_equal None (replace_first_opt 1 2 []));
+ "1 10 [1]" >:: (fun () -> assert_equal (Some [10]) (replace_first_opt 1 10 [1]));
+ "1 [2;3;4]" >:: (fun () -> assert_equal None (replace_first_opt 1 10 [2;3;4]));
+ "1 [1;2;3]" >:: (fun () -> assert_equal (Some [10;2;3]) (replace_first_opt 1 10 [1;2;3]));
+ "2 [1;2;3]" >:: (fun () -> assert_equal (Some [1;10;3]) (replace_first_opt 2 10 [1;2;3]));
+ "3 [1;2;3]" >:: (fun () -> assert_equal (Some [1;2;10]) (replace_first_opt 3 10 [1;2;3])) ]
+
+ let suite =
+ "Arrow" >:::
+ [suite_chain;
+ suite_cycle;
+ suite_take;
+ suite_take2;
+ suite_replace]
+
+ let suite_long =
+ "Arrow long" >:::
+ []
+
+ end
+
+let pp_free fmt f =
+ Format.fprintf fmt "%s" (free_to_string f)
+
+let pp_factor fmt f =
+ Format.fprintf fmt "%s" (factor_to_string f)
Index: trunk/omega/src/options.ml
===================================================================
--- trunk/omega/src/options.ml (revision 8899)
+++ trunk/omega/src/options.ml (revision 8900)
@@ -1,106 +1,102 @@
(* options.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module A = Map.Make (struct type t = string let compare = compare end)
+module A = Map.Make(String)
type t =
{ actions : Arg.spec A.t;
raw : (string * Arg.spec * string) list }
let empty = { actions = A.empty; raw = [] }
let extend old options =
{ actions = List.fold_left
(fun a (s, f, _) -> A.add s f a) old.actions options;
raw = options @ old.raw }
(*i
let merge o1 o2 =
extend o1 o2.raw
i*)
let create = extend empty
+let exclude f options =
+ { actions = A.filter (fun o _ -> not (f o)) options.actions;
+ raw = List.filter (fun (o, _, _) -> not (f o)) options.raw }
+
let cmdline prefix options =
List.map (fun (o, f, d) -> (prefix ^ o, f, d)) options.raw
(*i
exception Invalid of string * string
let parse options (name, value) =
try
match A.find name options.actions with
| Arg.Unit f -> f ()
| Arg.Set b -> b := true
| Arg.Clear b -> b := false
| Arg.String f -> f value
| Arg.Int f -> f (int_of_string value)
| Arg.Float f -> f (float_of_string value)
| _ -> invalid_arg "Options.parse"
with
| Not_found -> raise (Invalid (name, value))
let list options =
List.map (fun (o, _, d) -> (o, d)) options.raw
i*)
(*i
let parse specs anonymous usage =
let help () =
raise (Arg.Help (Arg.usage_string specs (usage ()))) in
let specs' =
[("-help", Arg.Unit help, "Display this list of options");
("--help", Arg.Unit help, "Display this list of options")] @ specs in
try
Arg.parse_argv Sys.argv specs' anonymous (usage ())
with
| Arg.Bad msg -> Printf.eprintf "%s\n" msg; exit 2;
| Arg.Help msg -> Printf.printf "%s\n" msg; exit 0
i*)
(* \begin{dubious}
Starting with O'Caml version 3.12.1 we can provide a better
\verb*--help* option using [Arg.usage_string]. We can finally
do this!
\end{dubious} *)
-let parse specs anonymous usage =
+let parse ?current ?(argv=Sys.argv) specs anonymous usage =
let help () =
raise (Arg.Help (usage ())) in
- let specs' =
- [("-usage", Arg.Unit help, "Display the external particles");
- ("--usage", Arg.Unit help, "Display the external particles")] @ specs in
+ let specs =
+ [("-usage", Arg.Unit help, " display the external particles");
+ ("--usage", Arg.Unit help, "display the external particles")] @ specs in
try
- Arg.parse_argv Sys.argv specs' anonymous (usage ())
+ Arg.parse_argv ?current argv specs anonymous (usage ())
with
| Arg.Bad msg -> Printf.eprintf "%s\n" msg; exit 2;
| Arg.Help msg -> Printf.printf "%s\n" msg; exit 0
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/omega_SSC.ml
===================================================================
--- trunk/omega/src/omega_SSC.ml (revision 8899)
+++ trunk/omega/src/omega_SSC.ml (revision 8900)
@@ -1,36 +1,27 @@
(* omega_SSC.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@physik.uni-freiburg.de>
with contributions from
Marco Sekulla <marco.sekulla@kit.edu>
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.Fortran)
- (Modellib_BSM.SSC(Modellib_BSM.SSC_kmatrix))
+module O = Omega.Mixed23(Target_Fortran.Make)(Modellib_BSM.SSC(Modellib_BSM.SSC_kmatrix))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/thoMap.mli
===================================================================
--- trunk/omega/src/thoMap.mli (revision 0)
+++ trunk/omega/src/thoMap.mli (revision 8900)
@@ -0,0 +1,60 @@
+(* thoMap.mli --
+
+ Copyright (C) 2023- by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+
+ WHIZARD is free software; you can redistribute it and/or modify it
+ under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ WHIZARD is distributed in the hope that it will be useful, but
+ WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
+
+(* \thocwmodulesection{Maps to Sets} *)
+
+module type Buckets =
+ sig
+
+ type t
+ type key
+ type element
+
+ (* The empty map. *)
+ val empty : t
+
+ (* Add the [element] to the set indexed by [key]. If there is no
+ such set, create it. *)
+ val add : key -> element -> t -> t
+
+ (* Return the sets as lists of [elements], indexed by their [key]. *)
+ val to_lists : t -> (key * element list) list
+
+ (* The prototypical application of this module is
+ group all [element]s with matching [key]s.
+ If all [element]s for a given [key] are different, [factorize] is just
+ a more efficient implementation of [ThoList.factorize] on
+ page~\pageref{ThoList.factorize}, but the latter keeps duplicate
+ [element]s for a [key], while this [factorize] keeps only one copy
+ for each [key]. *)
+ val factorize : (key * element) list -> (key * element list) list
+
+ (* [factorize_batches] is the composition of [factorize] and [List.concat],
+ but doesn't build the intermediate list. *)
+ val factorize_batches : (key * element) list list -> (key * element list) list
+
+ end
+
+module Buckets (Key : Map.OrderedType) (Element : Set.OrderedType) : Buckets
+ with type key = Key.t and type element = Element.t
+
+module Test : sig val suite : OUnit.test end
Index: trunk/omega/src/omega_SM_Higgs_CKM.ml
===================================================================
--- trunk/omega/src/omega_SM_Higgs_CKM.ml (revision 8899)
+++ trunk/omega/src/omega_SM_Higgs_CKM.ml (revision 8900)
@@ -1,35 +1,26 @@
(* omega_SM_Higgs_CKM.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.Fortran)
- (Modellib_SM.SM(Modellib_SM.SM_Higgs_CKM))
+module O = Omega.Mixed23(Target_Fortran.Make)(Modellib_SM.SM(Modellib_SM.SM_Higgs_CKM))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/omegatop
===================================================================
--- trunk/omega/src/omegatop (revision 8899)
+++ trunk/omega/src/omegatop (revision 8900)
@@ -1,15 +1,15 @@
#! /bin/sh
########################################################################
# This script is for developers only and needs not to be portable.
# This script takes TO's directory structure for granted.
########################################################################
# tl;dr : don't try this at home, kids ;)
########################################################################
build_root=/home/ohl/physics/whizard/_build/4.08.1
build_root=/home/ohl/physics/whizard/_build/default
build_dir=$build_root/omega/src
init_file=omega.ocamlinit
-( cd $build_dir; make omega_core.cma ) || exit 1
+( cd $build_dir; make omega_core.cma modellib_SM.cmo) || exit 1
exec utop -init $init_file -I $build_dir omega_core.cma "$@"
Index: trunk/omega/src/targets.ml
===================================================================
--- trunk/omega/src/targets.ml (revision 8899)
+++ trunk/omega/src/targets.ml (revision 8900)
@@ -1,8401 +1,60 @@
(* targets.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
Fabian Bach <fabian.bach@t-online.de> (only parts of this file)
Marco Sekulla <marco.sekulla@kit.edu> (only parts of this file)
Bijan Chokoufe Nejad <bijan.chokoufe@desy.de> (only parts of this file)
So Young Shim <soyoung.shim@desy.de>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
module Dummy (F : Fusion.Maker) (P : Momentum.T) (M : Model.T) =
struct
type amplitudes = Fusion.Multi(F)(P)(M).amplitudes
type diagnostic = All | Arguments | Momenta | Gauge
let options = Options.empty
let amplitudes_to_channel _ _ _ = failwith "Targets.Dummy"
let parameters_to_channel _ = failwith "Targets.Dummy"
end
-(* \thocwmodulesection{O'Mega Virtual Machine with \texttt{Fortran\;90/95}} *)
-
-(* \thocwmodulesubsection{Preliminaries} *)
-
-module VM (Fusion_Maker : Fusion.Maker) (P : Momentum.T) (M : Model.T) =
- struct
-
- open Coupling
- open Format
-
- module CM = Colorize.It(M)
- module F = Fusion_Maker(P)(M)
- module CF = Fusion.Multi(Fusion_Maker)(P)(M)
- module CFlow = Color.Flow
- type amplitudes = CF.amplitudes
-
-(* Options. *)
- type diagnostic = All | Arguments | Momenta | Gauge
-
- let wrapper_module = ref "ovm_wrapper"
- let parameter_module_external = ref "some_external_module_with_model_info"
- let bytecode_file = ref "bytecode.hbc"
- let md5sum = ref None
- let openmp = ref false
- let kind = ref "default"
- let whizard = ref false
-
- let options = Options.create
- [ "wrapper_module", Arg.String (fun s -> wrapper_module := s),
- "name of wrapper module";
- "bytecode_file", Arg.String (fun s -> bytecode_file := s),
- "bytecode file to be used in wrapper";
- "parameter_module_external", Arg.String (fun s ->
- parameter_module_external := s),
- "external parameter module to be used in wrapper";
- "md5sum", Arg.String (fun s -> md5sum := Some s),
- "transfer MD5 checksum in wrapper";
- "whizard", Arg.Set whizard, "include WHIZARD interface in wrapper";
- "openmp", Arg.Set openmp,
- "activate parallel computation of amplitude with OpenMP"]
-
-(* Integers encode the opcodes (operation codes). *)
- let ovm_ADD_MOMENTA = 1
- let ovm_CALC_BRAKET = 2
-
- let ovm_LOAD_SCALAR = 10
- let ovm_LOAD_SPINOR_INC = 11
- let ovm_LOAD_SPINOR_OUT = 12
- let ovm_LOAD_CONJSPINOR_INC = 13
- let ovm_LOAD_CONJSPINOR_OUT = 14
- let ovm_LOAD_MAJORANA_INC = 15
- let ovm_LOAD_MAJORANA_OUT = 16
- let ovm_LOAD_VECTOR_INC = 17
- let ovm_LOAD_VECTOR_OUT = 18
- let ovm_LOAD_VECTORSPINOR_INC = 19
- let ovm_LOAD_VECTORSPINOR_OUT = 20
- let ovm_LOAD_TENSOR2_INC = 21
- let ovm_LOAD_TENSOR2_OUT = 22
- let ovm_LOAD_BRS_SCALAR = 30
- let ovm_LOAD_BRS_SPINOR_INC = 31
- let ovm_LOAD_BRS_SPINOR_OUT = 32
- let ovm_LOAD_BRS_CONJSPINOR_INC = 33
- let ovm_LOAD_BRS_CONJSPINOR_OUT = 34
- let ovm_LOAD_BRS_VECTOR_INC = 37
- let ovm_LOAD_BRS_VECTOR_OUT = 38
- let ovm_LOAD_MAJORANA_GHOST_INC = 23
- let ovm_LOAD_MAJORANA_GHOST_OUT = 24
- let ovm_LOAD_BRS_MAJORANA_INC = 35
- let ovm_LOAD_BRS_MAJORANA_OUT = 36
-
- let ovm_PROPAGATE_SCALAR = 51
- let ovm_PROPAGATE_COL_SCALAR = 52
- let ovm_PROPAGATE_GHOST = 53
- let ovm_PROPAGATE_SPINOR = 54
- let ovm_PROPAGATE_CONJSPINOR = 55
- let ovm_PROPAGATE_MAJORANA = 56
- let ovm_PROPAGATE_COL_MAJORANA = 57
- let ovm_PROPAGATE_UNITARITY = 58
- let ovm_PROPAGATE_COL_UNITARITY = 59
- let ovm_PROPAGATE_FEYNMAN = 60
- let ovm_PROPAGATE_COL_FEYNMAN = 61
- let ovm_PROPAGATE_VECTORSPINOR = 62
- let ovm_PROPAGATE_TENSOR2 = 63
-
-(* \begin{dubious}
- [ovm_PROPAGATE_NONE] has to be split up to different types to work
- in conjunction with color MC \dots
- \end{dubious} *)
- let ovm_PROPAGATE_NONE = 64
-
- let ovm_FUSE_V_FF = -1
- let ovm_FUSE_F_VF = -2
- let ovm_FUSE_F_FV = -3
- let ovm_FUSE_VA_FF = -4
- let ovm_FUSE_F_VAF = -5
- let ovm_FUSE_F_FVA = -6
- let ovm_FUSE_VA2_FF = -7
- let ovm_FUSE_F_VA2F = -8
- let ovm_FUSE_F_FVA2 = -9
- let ovm_FUSE_A_FF = -10
- let ovm_FUSE_F_AF = -11
- let ovm_FUSE_F_FA = -12
- let ovm_FUSE_VL_FF = -13
- let ovm_FUSE_F_VLF = -14
- let ovm_FUSE_F_FVL = -15
- let ovm_FUSE_VR_FF = -16
- let ovm_FUSE_F_VRF = -17
- let ovm_FUSE_F_FVR = -18
- let ovm_FUSE_VLR_FF = -19
- let ovm_FUSE_F_VLRF = -20
- let ovm_FUSE_F_FVLR = -21
- let ovm_FUSE_SP_FF = -22
- let ovm_FUSE_F_SPF = -23
- let ovm_FUSE_F_FSP = -24
- let ovm_FUSE_S_FF = -25
- let ovm_FUSE_F_SF = -26
- let ovm_FUSE_F_FS = -27
- let ovm_FUSE_P_FF = -28
- let ovm_FUSE_F_PF = -29
- let ovm_FUSE_F_FP = -30
- let ovm_FUSE_SL_FF = -31
- let ovm_FUSE_F_SLF = -32
- let ovm_FUSE_F_FSL = -33
- let ovm_FUSE_SR_FF = -34
- let ovm_FUSE_F_SRF = -35
- let ovm_FUSE_F_FSR = -36
- let ovm_FUSE_SLR_FF = -37
- let ovm_FUSE_F_SLRF = -38
- let ovm_FUSE_F_FSLR = -39
-
- let ovm_FUSE_G_GG = -40
- let ovm_FUSE_V_SS = -41
- let ovm_FUSE_S_VV = -42
- let ovm_FUSE_S_VS = -43
- let ovm_FUSE_V_SV = -44
- let ovm_FUSE_S_SS = -45
- let ovm_FUSE_S_SVV = -46
- let ovm_FUSE_V_SSV = -47
- let ovm_FUSE_S_SSS = -48
- let ovm_FUSE_V_VVV = -49
-
- let ovm_FUSE_S_G2 = -50
- let ovm_FUSE_G_SG = -51
- let ovm_FUSE_G_GS = -52
- let ovm_FUSE_S_G2_SKEW = -53
- let ovm_FUSE_G_SG_SKEW = -54
- let ovm_FUSE_G_GS_SKEW = -55
-
- let inst_length = 8
-
-(* Some helper functions. *)
- let printi ~lhs:l ~rhs1:r1 ?coupl:(cp = 0) ?coeff:(co = 0)
- ?rhs2:(r2 = 0) ?rhs3:(r3 = 0) ?rhs4:(r4 = 0) code =
- printf "@\n%d %d %d %d %d %d %d %d" code cp co l r1 r2 r3 r4
-
- let nl () = printf "@\n"
-
- let print_int_lst lst = nl (); lst |> List.iter (printf "%d ")
-
- let print_str_lst lst = nl (); lst |> List.iter (printf "%s ")
-
- let break () = printi ~lhs:0 ~rhs1:0 0
-
-(* Copied from below. Needed for header. *)
-(* \begin{dubious}
- Could be fused with [lorentz_ordering].
- \end{dubious} *)
- type declarations =
- { scalars : F.wf list;
- spinors : F.wf list;
- conjspinors : F.wf list;
- realspinors : F.wf list;
- ghostspinors : F.wf list;
- vectorspinors : F.wf list;
- vectors : F.wf list;
- ward_vectors : F.wf list;
- massive_vectors : F.wf list;
- tensors_1 : F.wf list;
- tensors_2 : F.wf list;
- brs_scalars : F.wf list;
- brs_spinors : F.wf list;
- brs_conjspinors : F.wf list;
- brs_realspinors : F.wf list;
- brs_vectorspinors : F.wf list;
- brs_vectors : F.wf list;
- brs_massive_vectors : F.wf list }
-
- let rec classify_wfs' acc = function
- | [] -> acc
- | wf :: rest ->
- classify_wfs'
- (match CM.lorentz (F.flavor wf) with
- | Scalar -> {acc with scalars = wf :: acc.scalars}
- | Spinor -> {acc with spinors = wf :: acc.spinors}
- | ConjSpinor -> {acc with conjspinors = wf :: acc.conjspinors}
- | Majorana -> {acc with realspinors = wf :: acc.realspinors}
- | Maj_Ghost -> {acc with ghostspinors = wf :: acc.ghostspinors}
- | Vectorspinor ->
- {acc with vectorspinors = wf :: acc.vectorspinors}
- | Vector -> {acc with vectors = wf :: acc.vectors}
- | Massive_Vector ->
- {acc with massive_vectors = wf :: acc.massive_vectors}
- | Tensor_1 -> {acc with tensors_1 = wf :: acc.tensors_1}
- | Tensor_2 -> {acc with tensors_2 = wf :: acc.tensors_2}
- | BRS Scalar -> {acc with brs_scalars = wf :: acc.brs_scalars}
- | BRS Spinor -> {acc with brs_spinors = wf :: acc.brs_spinors}
- | BRS ConjSpinor -> {acc with brs_conjspinors =
- wf :: acc.brs_conjspinors}
- | BRS Majorana -> {acc with brs_realspinors =
- wf :: acc.brs_realspinors}
- | BRS Vectorspinor -> {acc with brs_vectorspinors =
- wf :: acc.brs_vectorspinors}
- | BRS Vector -> {acc with brs_vectors = wf :: acc.brs_vectors}
- | BRS Massive_Vector -> {acc with brs_massive_vectors =
- wf :: acc.brs_massive_vectors}
- | BRS _ -> invalid_arg "Targets.classify_wfs': not needed here")
- rest
-
- let classify_wfs wfs = classify_wfs'
- { scalars = [];
- spinors = [];
- conjspinors = [];
- realspinors = [];
- ghostspinors = [];
- vectorspinors = [];
- vectors = [];
- ward_vectors = [];
- massive_vectors = [];
- tensors_1 = [];
- tensors_2 = [];
- brs_scalars = [];
- brs_spinors = [];
- brs_conjspinors = [];
- brs_realspinors = [];
- brs_vectorspinors = [];
- brs_vectors = [];
- brs_massive_vectors = [] } wfs
-
-(* \thocwmodulesubsection{Sets and maps} *)
-
-(* The OVM identifies all objects via integers. Therefore, we need maps
- which assign the abstract object a unique ID. *)
-
-(* I want [int list]s with less elements to come first. Used in conjunction
- with the int list representation of momenta, this will set the outer
- particles at first position and allows the OVM to set them without further
- instructions. *)
-
-(* \begin{dubious}
- Using the Momentum module might give better performance than integer lists?
- \end{dubious} *)
- let rec int_lst_compare (e1 : int list) (e2 : int list) =
- match e1,e2 with
- | [], [] -> 0
- | _, [] -> +1
- | [], _ -> -1
- | [_;_], [_] -> +1
- | [_], [_;_] -> -1
- | hd1 :: tl1, hd2 :: tl2 ->
- let c = compare hd1 hd2 in
- if (c != 0 && List.length tl1 = List.length tl2) then
- c
- else
- int_lst_compare tl1 tl2
-
-(* We need a canonical ordering for the different types
- of wfs. Copied, and slightly modified to order [wf]s, from
- \texttt{fusion.ml}. *)
-
- let lorentz_ordering wf =
- match CM.lorentz (F.flavor wf) with
- | Scalar -> 0
- | Spinor -> 1
- | ConjSpinor -> 2
- | Majorana -> 3
- | Vector -> 4
- | Massive_Vector -> 5
- | Tensor_2 -> 6
- | Tensor_1 -> 7
- | Vectorspinor -> 8
- | BRS Scalar -> 9
- | BRS Spinor -> 10
- | BRS ConjSpinor -> 11
- | BRS Majorana -> 12
- | BRS Vector -> 13
- | BRS Massive_Vector -> 14
- | BRS Tensor_2 -> 15
- | BRS Tensor_1 -> 16
- | BRS Vectorspinor -> 17
- | Maj_Ghost -> invalid_arg "lorentz_ordering: not implemented"
- | BRS _ -> invalid_arg "lorentz_ordering: not needed"
-
- let wf_compare (wf1, mult1) (wf2, mult2) =
- let c1 = compare (lorentz_ordering wf1) (lorentz_ordering wf2) in
- if c1 <> 0 then
- c1
- else
- let c2 = compare wf1 wf2 in
- if c2 <> 0 then
- c2
- else
- compare mult1 mult2
-
- let amp_compare amp1 amp2 =
- let cflow a = CM.flow (F.incoming a) (F.outgoing a) in
- let c1 = compare (cflow amp1) (cflow amp2) in
- if c1 <> 0 then
- c1
- else
- let process_sans_color a =
- (List.map CM.flavor_sans_color (F.incoming a),
- List.map CM.flavor_sans_color (F.outgoing a)) in
- compare (process_sans_color amp1) (process_sans_color amp2)
-
- let level_compare (f1, amp1) (f2, amp2) =
- let p1 = F.momentum_list (F.lhs f1)
- and p2 = F.momentum_list (F.lhs f2) in
- let c1 = int_lst_compare p1 p2 in
- if c1 <> 0 then
- c1
- else
- let c2 = compare f1 f2 in
- if c2 <> 0 then
- c2
- else
- amp_compare amp1 amp2
-
- module ISet = Set.Make (struct type t = int list
- let compare = int_lst_compare end)
-
- module WFSet = Set.Make (struct type t = CF.wf * int
- let compare = wf_compare end)
-
- module CSet = Set.Make (struct type t = CM.constant
- let compare = compare end)
-
- module FSet = Set.Make (struct type t = F.fusion * F.amplitude
- let compare = level_compare end)
-
-(* \begin{dubious}
- It might be preferable to use a [PMap] which maps mom to int, instead of
- this way. More standard functions like [mem] could be used. Also, [get_ID]
- would be faster, $\mathcal{O}(\log N)$ instead of $\mathcal{O}(N)$, and
- simpler. For 8 gluons: N=127 momenta. Minor performance issue.
- \end{dubious} *)
-
- module IMap = Map.Make (struct type t = int let compare = compare end)
-
-(* For [wf]s it is crucial for the performance to use a different type of
- [Map]s. *)
-
- module WFMap = Map.Make (struct type t = CF.wf * int
- let compare = wf_compare end)
-
- type lookups = { pmap : int list IMap.t;
- wfmap : int WFMap.t;
- cmap : CM.constant IMap.t * CM.constant IMap.t;
- amap : F.amplitude IMap.t;
- n_wfs : int list;
- amplitudes : CF.amplitudes;
- dict : F.amplitude -> F.wf -> int }
-
- let largest_key imap =
- if (IMap.is_empty imap) then
- failwith "largest_key: Map is empty!"
- else
- fst (IMap.max_binding imap)
-
-(* OCaml's [compare] from pervasives cannot compare functional types, e.g.
- for type [amplitude], if no specific equality function is given ("equal:
- functional value"). Therefore, we allow to specify the ordering. *)
-
- let get_ID' comp map elt : int =
- let smallmap = IMap.filter (fun _ x -> (comp x elt) = 0 ) map in
- if IMap.is_empty smallmap then
- raise Not_found
- else
- fst (IMap.min_binding smallmap)
-
-(* \begin{dubious}
- Trying to curry [map] here leads to type errors of the
- polymorphic function [get_ID]?
- \end{dubious} *)
-
- let get_ID map = match map with
- | map -> get_ID' compare map
-
- let get_const_ID map x = match map with
- | (map1, map2) -> try get_ID' compare map1 x with
- _ -> try get_ID' compare map2 x with
- _ -> failwith "Impossible"
-
-(* Creating an integer map of a list with an optional argument that
- indicates where the map should start counting. *)
-
- let map_of_list ?start:(st=1) lst =
- let g (ind, map) wf = (succ ind, IMap.add ind wf map) in
- lst |> List.fold_left g (st, IMap.empty) |> snd
-
- let wf_map_of_list ?start:(st=1) lst =
- let g (ind, map) wf = (succ ind, WFMap.add wf ind map) in
- lst |> List.fold_left g (st, WFMap.empty) |> snd
-
-(* \thocwmodulesubsection{Header} *)
-
-(* \begin{dubious}
- [Bijan:]
- It would be nice to save the creation date as comment. However, the Unix
- module doesn't seem to be loaded on default.
- \end{dubious} *)
-
- let version =
- String.concat " " [Config.version; Config.status; Config.date]
- let model_name =
- let basename = Filename.basename Sys.executable_name in
- try
- Filename.chop_extension basename
- with
- | _ -> basename
-
-
- let print_description cmdline =
- printf "Model %s\n" model_name;
- printf "OVM %s\n" version;
- printf "@\nBytecode file generated automatically by O'Mega for OVM";
- printf "@\nDo not delete any lines. You called O'Mega with";
- printf "@\n %s" cmdline;
- (*i
- let t = Unix.localtime (Unix.time() ) in
- printf "@\n on %5d %5d %5d" (succ t.Unix.tm_mon) t.Unix.tm_mday
- t.Unix.tm_year;
- i*)
- printf "@\n"
-
- let num_classified_wfs wfs =
- let wfs' = classify_wfs wfs in
- List.map List.length
- [ wfs'.scalars @ wfs'.brs_scalars;
- wfs'.spinors @ wfs'.brs_spinors;
- wfs'.conjspinors @ wfs'.brs_conjspinors;
- wfs'.realspinors @ wfs'.brs_realspinors @ wfs'.ghostspinors;
- wfs'.vectors @ wfs'.massive_vectors @ wfs'.brs_vectors
- @ wfs'.brs_massive_vectors @ wfs'.ward_vectors;
- wfs'.tensors_2;
- wfs'.tensors_1;
- wfs'.vectorspinors ]
-
- let description_classified_wfs =
- [ "N_scalars";
- "N_spinors";
- "N_conjspinors";
- "N_bispinors";
- "N_vectors";
- "N_tensors_2";
- "N_tensors_1";
- "N_vectorspinors" ]
-
- let num_particles_in amp =
- match CF.flavors amp with
- | [] -> 0
- | (fin, _) :: _ -> List.length fin
-
- let num_particles_out amp =
- match CF.flavors amp with
- | [] -> 0
- | (_, fout) :: _ -> List.length fout
-
- let num_particles amp =
- match CF.flavors amp with
- | [] -> 0
- | (fin, fout) :: _ -> List.length fin + List.length fout
-
- let num_color_indices_default = 2 (* Standard model and non-color-exotica *)
-
- let num_color_indices amp =
- try CFlow.rank (List.hd (CF.color_flows amp)) with
- _ -> num_color_indices_default
-
- let num_color_factors amp =
- let table = CF.color_factors amp in
- let n_cflow = Array.length table
- and n_cfactors = ref 0 in
- for c1 = 0 to pred n_cflow do
- for c2 = 0 to pred n_cflow do
- if c1 <= c2 then begin
- match table.(c1).(c2) with
- | [] -> ()
- | _ -> incr n_cfactors
- end
- done
- done;
- !n_cfactors
-
- let num_helicities amp = amp |> CF.helicities |> List.length
-
- let num_flavors amp = amp |> CF.flavors |> List.length
-
- let num_ks amp = amp |> CF.processes |> List.length
-
- let num_color_flows amp = amp |> CF.color_flows |> List.length
-
-(* Use [fst] since [WFSet.t = F.wf * int]. *)
- let num_wfs wfset = wfset |> WFSet.elements |> List.map fst
- |> num_classified_wfs
-
-(* [largest_key] gives the number of momenta if applied to [pmap]. *)
-
- let num_lst lookups wfset =
- [ largest_key lookups.pmap;
- num_particles lookups.amplitudes;
- num_particles_in lookups.amplitudes;
- num_particles_out lookups.amplitudes;
- num_ks lookups.amplitudes;
- num_helicities lookups.amplitudes;
- num_color_flows lookups.amplitudes;
- num_color_indices lookups.amplitudes;
- num_flavors lookups.amplitudes;
- num_color_factors lookups.amplitudes ] @ num_wfs wfset
-
- let description_lst =
- [ "N_momenta";
- "N_particles";
- "N_prt_in";
- "N_prt_out";
- "N_amplitudes";
- "N_helicities";
- "N_col_flows";
- "N_col_indices";
- "N_flavors";
- "N_col_factors" ] @ description_classified_wfs
-
- let print_header' numbers =
- let chopped_num_lst = ThoList.chopn inst_length numbers
- and chopped_desc_lst = ThoList.chopn inst_length description_lst
- and printer a b = print_str_lst a; print_int_lst b in
- List.iter2 printer chopped_desc_lst chopped_num_lst
-
- let print_header lookups wfset = print_header' (num_lst lookups wfset)
-
- let print_zero_header () =
- let rec zero_list' j =
- if j < 1 then []
- else 0 :: zero_list' (j - 1) in
- let zero_list i = zero_list' (i + 1) in
- description_lst |> List.length |> zero_list |> print_header'
-
-(* \thocwmodulesubsection{Tables} *)
-
- let print_spin_table' tuples =
- match tuples with
- | [] -> ()
- | _ -> tuples |> List.iter ( fun (tuple1, tuple2) ->
- tuple1 @ tuple2 |> List.map (Printf.sprintf "%d ")
- |> String.concat "" |> printf "@\n%s" )
-
- let print_spin_table amplitudes =
- printf "@\nSpin states table";
- print_spin_table' @@ CF.helicities amplitudes
-
- let print_flavor_table tuples =
- match tuples with
- | [] -> ()
- | _ -> List.iter ( fun tuple -> tuple
- |> List.map (fun f -> Printf.sprintf "%d " @@ M.pdg f)
- |> String.concat "" |> printf "@\n%s"
- ) tuples
-
- let print_flavor_tables amplitudes =
- printf "@\nFlavor states table";
- print_flavor_table @@ List.map (fun (fin, fout) -> fin @ fout)
- @@ CF.flavors amplitudes
-
- let print_color_flows_table' tuple =
- match CFlow.to_lists tuple with
- | [] -> ()
- | cfs -> printf "@\n%s" @@ String.concat "" @@ List.map
- ( fun cf -> cf |> List.map (Printf.sprintf "%d ")
- |> String.concat ""
- ) cfs
-
- let print_color_flows_table tuples =
- match tuples with
- | [] -> ()
- | _ -> List.iter print_color_flows_table' tuples
-
- let print_ghost_flags_table tuples =
- match tuples with
- | [] -> ()
- | _ ->
- List.iter (fun tuple ->
- match CFlow.ghost_flags tuple with
- | [] -> ()
- | gfs -> printf "@\n"; List.iter (fun gf -> printf "%s "
- (if gf then "1" else "0") ) gfs
- ) tuples
-
- let format_power
- { CFlow.num = num; CFlow.den = den; CFlow.power = pwr } =
- match num, den, pwr with
- | _, 0, _ -> invalid_arg "targets.format_power: zero denominator"
- | n, d, p -> [n; d; p]
-
- let format_powers = function
- | [] -> [0]
- | powers -> List.flatten (List.map format_power powers)
-
- (*i
- (* We go through the array line by line and collect all colorfactors which
- * are nonzero because their corresponding color flows match.
- * With the gained intset, we would be able to print only the necessary
- * coefficients of the symmetric matrix and indicate from where the OVM
- * can copy the rest. However, this approach gets really slow for many
- * gluons and we can save at most 3 numbers per line.*)
-
- let print_color_factor_table_funct table =
- let n_cflow = Array.length table in
- let (intset, _, _ ) =
- let rec fold_array (set, cf1, cf2) =
- if cf1 > pred n_cflow then (set, 0, 0)
- else
- let returnset =
- match table.(cf1).(cf2) with
- | [] -> set
- | cf ->
- ISet.add ([succ cf1; succ cf2] @ (format_powers cf)) set
- in
- if cf2 < pred n_cflow then
- fold_array (returnset, cf1, succ cf2) else
- fold_array (returnset, succ cf1, 0)
- in
- fold_array (ISet.empty, 0, 0)
- in
- let map = map_of_list (ISet.elements intset) in
- List.iter (fun x -> printf "@\n"; let xth = List.nth x in
- if (xth 0 <= xth 1) then List.iter (printf "%d ") x
- else printf "%d %d" 0 (get_ID map x))
- (ISet.elements intset)
-
- let print_color_factor_table_old table =
- let n_cflow = Array.length table in
- let (intlsts, _, _ ) =
- let rec fold_array (lsts, cf1, cf2) =
- if cf1 > pred n_cflow then (lsts, 0, 0)
- else
- let returnlsts =
- match table.(cf1).(cf2) with
- | [] -> lsts
- | cf -> ([succ cf1; succ cf2] @ (format_powers cf)) :: lsts
- in
- if cf2 < pred n_cflow then
- fold_array (returnlsts, cf1, succ cf2) else
- fold_array (returnlsts, succ cf1, 0)
- in
- fold_array ([], 0, 0)
- in
- let intlsts = List.rev intlsts in
- List.iter (fun x -> printf "@\n"; List.iter (printf "%d ") x ) intlsts
- i*)
-
-(* Straightforward iteration gives a great speedup compared to the fancier
- approach which only collects nonzero colorfactors. *)
-
- let print_color_factor_table table =
- let n_cflow = Array.length table in
- if n_cflow > 0 then begin
- for c1 = 0 to pred n_cflow do
- for c2 = 0 to pred n_cflow do
- if c1 <= c2 then begin
- match table.(c1).(c2) with
- | [] -> ()
- | cf -> printf "@\n"; List.iter (printf "%9d")
- ([succ c1; succ c2] @ (format_powers cf));
- end
- done
- done
- end
-
- let option_to_binary = function
- | Some _ -> "1"
- | None -> "0"
-
- let print_flavor_color_table n_flv n_cflow table =
- if n_flv > 0 then begin
- for c = 0 to pred n_cflow do
- printf "@\n";
- for f = 0 to pred n_flv do
- printf "%s " (option_to_binary table.(f).(c))
- done;
- done;
- end
-
- let print_color_tables amplitudes =
- let cflows = CF.color_flows amplitudes
- and cfactors = CF.color_factors amplitudes in
- printf "@\nColor flows table: [ (i, j) (k, l) -> (m, n) ...]";
- print_color_flows_table cflows;
- printf "@\nColor ghost flags table:";
- print_ghost_flags_table cflows;
- printf "@\nColor factors table: [ i, j: num den power], %s"
- "i, j are indexed color flows";
- print_color_factor_table cfactors;
- printf "@\nFlavor color combination is allowed:";
- print_flavor_color_table (num_flavors amplitudes) (List.length
- (CF.color_flows amplitudes)) (CF.process_table amplitudes)
-
-(* \thocwmodulesubsection{Momenta} *)
-
-(* Add the momenta of a WFSet to a Iset. For now, we are throwing away the
- information to which amplitude the momentum belongs. This could be optimized
- for random color flow computations. *)
-
- let momenta_set wfset =
- let get_mom wf = wf |> fst |> F.momentum_list in
- let momenta = List.map get_mom (WFSet.elements wfset) in
- momenta |> List.fold_left (fun set x -> set |> ISet.add x) ISet.empty
-
- let chop_in_3 lst =
- let ceil_div i j = if (i mod j = 0) then i/j else i/j + 1 in
- ThoList.chopn (ceil_div (List.length lst) 3) lst
-
-(* Assign momenta via instruction code. External momenta [[_]] are already
- set by the OVM. To avoid unnecessary look-ups of IDs we seperate two cases.
- If we have more, we split up in two or three parts. *)
-
- let add_mom p pmap =
- let print_mom lhs rhs1 rhs2 rhs3 = if (rhs1!= 0) then
- printi ~lhs:lhs ~rhs1:rhs1 ~rhs2:rhs2 ~rhs3:rhs3 ovm_ADD_MOMENTA in
- let get_p_ID = get_ID pmap in
- match p with
- | [] | [_] -> print_mom 0 0 0 0
- | [rhs1;rhs2] -> print_mom (get_p_ID [rhs1;rhs2]) rhs1 rhs2 0
- | [rhs1;rhs2;rhs3] -> print_mom (get_p_ID [rhs1;rhs2;rhs3]) rhs1 rhs2 rhs3
- | more ->
- let ids = List.map get_p_ID (chop_in_3 more) in
- if (List.length ids = 3) then
- print_mom (get_p_ID more) (List.nth ids 0) (List.nth ids 1)
- (List.nth ids 2)
- else
- print_mom (get_p_ID more) (List.nth ids 0) (List.nth ids 1) 0
-
-(* Hand through the current level and print level seperators if necessary. *)
-
- let add_all_mom lookups pset =
- let add_all' level p =
- let level' = List.length p in
- if (level' > level && level' > 3) then break ();
- add_mom p lookups.pmap; level'
- in
- ignore (pset |> ISet.elements |> List.fold_left add_all' 1)
-
-(* Expand a set of momenta to contain all needed momenta for the computation
- in the OVM. For this, we create a list of sets which contains the chopped
- momenta and unify them afterwards. If the set has become larger, we
- expand again. *)
-
- let rec expand_pset p =
- let momlst = ISet.elements p in
- let pset_of lst = List.fold_left (fun s x -> ISet.add x s) ISet.empty
- lst in
- let sets = List.map (fun x -> pset_of (chop_in_3 x) ) momlst in
- let bigset = List.fold_left ISet.union ISet.empty sets in
- let biggerset = ISet.union bigset p in
- if (List.length momlst < List.length (ISet.elements biggerset) ) then
- expand_pset biggerset
- else
- biggerset
-
- let mom_ID pmap wf = get_ID pmap (F.momentum_list wf)
-
-(* \thocwmodulesubsection{Wavefunctions and externals} *)
-
-(* [mult_wf] is needed because the [wf] with same combination of flavor and
- momentum can have different dependencies and content. *)
-
- let mult_wf dict amplitude wf =
- try
- wf, dict amplitude wf
- with
- | Not_found -> wf, 0
-
-(* Build the union of all [wf]s of all amplitudes and a map of the amplitudes. *)
-
- let wfset_amps amplitudes =
- let amap = amplitudes |> CF.processes |> List.sort amp_compare
- |> map_of_list
- and dict = CF.dictionary amplitudes in
- let wfset_amp amp =
- let f = mult_wf dict amp in
- let lst = List.map f ((F.externals amp) @ (F.variables amp)) in
- lst |> List.fold_left (fun s x -> WFSet.add x s) WFSet.empty in
- let list_of_sets = amplitudes |> CF.processes |> List.map wfset_amp in
- List.fold_left WFSet.union WFSet.empty list_of_sets, amap
-
-(* To obtain the Fortran index, we substract the number of precedent wave
- functions. *)
-
- let lorentz_ordering_reduced wf =
- match CM.lorentz (F.flavor wf) with
- | Scalar | BRS Scalar -> 0
- | Spinor | BRS Spinor -> 1
- | ConjSpinor | BRS ConjSpinor -> 2
- | Majorana | BRS Majorana -> 3
- | Vector | BRS Vector | Massive_Vector | BRS Massive_Vector -> 4
- | Tensor_2 | BRS Tensor_2 -> 5
- | Tensor_1 | BRS Tensor_1 -> 6
- | Vectorspinor | BRS Vectorspinor -> 7
- | Maj_Ghost -> invalid_arg "lorentz_ordering: not implemented"
- | BRS _ -> invalid_arg "lorentz_ordering: not needed"
-
- let wf_index wfmap num_lst (wf, i) =
- let wf_ID = WFMap.find (wf, i) wfmap
- and sum lst = List.fold_left (fun x y -> x+y) 0 lst in
- wf_ID - sum (ThoList.hdn (lorentz_ordering_reduced wf) num_lst)
-
- let print_ext lookups amp_ID inc (wf, i) =
- let mom = (F.momentum_list wf) in
- let outer_index = if List.length mom = 1 then List.hd mom else
- failwith "targets.print_ext: called with non-external particle"
- and f = F.flavor wf in
- let pdg = CM.pdg f
- and wf_code =
- match CM.lorentz f with
- | Scalar -> ovm_LOAD_SCALAR
- | BRS Scalar -> ovm_LOAD_BRS_SCALAR
- | Spinor ->
- if inc then ovm_LOAD_SPINOR_INC
- else ovm_LOAD_SPINOR_OUT
- | BRS Spinor ->
- if inc then ovm_LOAD_BRS_SPINOR_INC
- else ovm_LOAD_BRS_SPINOR_OUT
- | ConjSpinor ->
- if inc then ovm_LOAD_CONJSPINOR_INC
- else ovm_LOAD_CONJSPINOR_OUT
- | BRS ConjSpinor ->
- if inc then ovm_LOAD_BRS_CONJSPINOR_INC
- else ovm_LOAD_BRS_CONJSPINOR_OUT
- | Vector | Massive_Vector ->
- if inc then ovm_LOAD_VECTOR_INC
- else ovm_LOAD_VECTOR_OUT
- | BRS Vector | BRS Massive_Vector ->
- if inc then ovm_LOAD_BRS_VECTOR_INC
- else ovm_LOAD_BRS_VECTOR_OUT
- | Tensor_2 ->
- if inc then ovm_LOAD_TENSOR2_INC
- else ovm_LOAD_TENSOR2_OUT
- | Vectorspinor | BRS Vectorspinor ->
- if inc then ovm_LOAD_VECTORSPINOR_INC
- else ovm_LOAD_VECTORSPINOR_OUT
- | Majorana ->
- if inc then ovm_LOAD_MAJORANA_INC
- else ovm_LOAD_MAJORANA_OUT
- | BRS Majorana ->
- if inc then ovm_LOAD_BRS_MAJORANA_INC
- else ovm_LOAD_BRS_MAJORANA_OUT
- | Maj_Ghost ->
- if inc then ovm_LOAD_MAJORANA_GHOST_INC
- else ovm_LOAD_MAJORANA_GHOST_OUT
- | Tensor_1 ->
- invalid_arg "targets.print_ext: Tensor_1 only internal"
- | BRS _ ->
- failwith "targets.print_ext: Not implemented"
- and wf_ind = wf_index lookups.wfmap lookups.n_wfs (wf, i)
- in
- printi wf_code ~lhs:wf_ind ~coupl:(abs(pdg)) ~rhs1:outer_index ~rhs4:amp_ID
-
- let print_ext_amp lookups amplitude =
- let incoming = (List.map (fun _ -> true) (F.incoming amplitude) @
- List.map (fun _ -> false) (F.outgoing amplitude))
- and amp_ID = get_ID' amp_compare lookups.amap amplitude in
- let wf_tpl wf = mult_wf lookups.dict amplitude wf in
- let print_ext_wf inc wf = wf |> wf_tpl |> print_ext lookups amp_ID inc in
- List.iter2 print_ext_wf incoming (F.externals amplitude)
-
- let print_externals lookups seen_wfs amplitude =
- let externals =
- List.combine
- (F.externals amplitude)
- (List.map (fun _ -> true) (F.incoming amplitude) @
- List.map (fun _ -> false) (F.outgoing amplitude)) in
- List.fold_left (fun seen (wf, incoming) ->
- let amp_ID = get_ID' amp_compare lookups.amap amplitude in
- let wf_tpl = mult_wf lookups.dict amplitude wf in
- if not (WFSet.mem wf_tpl seen) then begin
- wf_tpl |> print_ext lookups amp_ID incoming
- end;
- WFSet.add wf_tpl seen) seen_wfs externals
-
-(* [print_externals] and [print_ext_amp] do in principle the same thing but
- [print_externals] filters out dublicate external wave functions. Even with
- [print_externals] the same (numerically) external wave function will be
- loaded if it belongs to a different color flow, just as in the native Fortran
- code. For color MC, [print_ext_amp] has to be used (redundant instructions
- but only one flow is computed) and the filtering of duplicate fusions has to
- be disabled. *)
-
- let print_ext_amps lookups =
- let print_external_amp s x = print_externals lookups s x in
- ignore (
- List.fold_left print_external_amp WFSet.empty
- (CF.processes lookups.amplitudes)
- )
- (*i
- List.iter (print_ext_amp lookups) (CF.processes lookups.amplitudes)
- i*)
-
-(* \thocwmodulesubsection{Currents} *)
-
-(* Parallelization issues: All fusions have to be completed before the
- propagation takes place. Preferably each fusion and propagation is done
- by one thread. Solution: All fusions are subinstructions, i.e. if
- they are read by the main loop they are skipped. If a propagation
- occurs, all fusions have to be computed first. The additional control
- bit is the sign of the first int of an instruction. *)
-
- (*i TODO: (bcn 2014-07-21) Majorana support will come some day maybe i*)
- let print_fermion_current code_a code_b code_c coeff lhs c wf1 wf2 fusion =
- let printc code r1 r2 = printi code ~lhs:lhs ~coupl:c ~coeff:coeff
- ~rhs1:r1 ~rhs2:r2 in
- match fusion with
- | F13 -> printc code_a wf1 wf2
- | F31 -> printc code_a wf2 wf1
- | F23 -> printc code_b wf1 wf2
- | F32 -> printc code_b wf2 wf1
- | F12 -> printc code_c wf1 wf2
- | F21 -> printc code_c wf2 wf1
-
- let ferm_print_current = function
- | coeff, Psibar, V, Psi -> print_fermion_current
- ovm_FUSE_V_FF ovm_FUSE_F_VF ovm_FUSE_F_FV coeff
- | coeff, Psibar, VA, Psi -> print_fermion_current
- ovm_FUSE_VA_FF ovm_FUSE_F_VAF ovm_FUSE_F_FVA coeff
- | coeff, Psibar, VA2, Psi -> print_fermion_current
- ovm_FUSE_VA2_FF ovm_FUSE_F_VA2F ovm_FUSE_F_FVA2 coeff
- | coeff, Psibar, A, Psi -> print_fermion_current
- ovm_FUSE_A_FF ovm_FUSE_F_AF ovm_FUSE_F_FA coeff
- | coeff, Psibar, VL, Psi -> print_fermion_current
- ovm_FUSE_VL_FF ovm_FUSE_F_VLF ovm_FUSE_F_FVL coeff
- | coeff, Psibar, VR, Psi -> print_fermion_current
- ovm_FUSE_VR_FF ovm_FUSE_F_VRF ovm_FUSE_F_FVR coeff
- | coeff, Psibar, VLR, Psi -> print_fermion_current
- ovm_FUSE_VLR_FF ovm_FUSE_F_VLRF ovm_FUSE_F_FVLR coeff
- | coeff, Psibar, SP, Psi -> print_fermion_current
- ovm_FUSE_SP_FF ovm_FUSE_F_SPF ovm_FUSE_F_FSP coeff
- | coeff, Psibar, S, Psi -> print_fermion_current
- ovm_FUSE_S_FF ovm_FUSE_F_SF ovm_FUSE_F_FS coeff
- | coeff, Psibar, P, Psi -> print_fermion_current
- ovm_FUSE_P_FF ovm_FUSE_F_PF ovm_FUSE_F_FP coeff
- | coeff, Psibar, SL, Psi -> print_fermion_current
- ovm_FUSE_SL_FF ovm_FUSE_F_SLF ovm_FUSE_F_FSL coeff
- | coeff, Psibar, SR, Psi -> print_fermion_current
- ovm_FUSE_SR_FF ovm_FUSE_F_SRF ovm_FUSE_F_FSR coeff
- | coeff, Psibar, SLR, Psi -> print_fermion_current
- ovm_FUSE_SLR_FF ovm_FUSE_F_SLRF ovm_FUSE_F_FSLR coeff
- | _, Psibar, _, Psi -> invalid_arg
- "Targets.Fortran.VM: no superpotential here"
- | _, Chibar, _, _ | _, _, _, Chi -> invalid_arg
- "Targets.Fortran.VM: Majorana spinors not handled"
- | _, Gravbar, _, _ | _, _, _, Grav -> invalid_arg
- "Targets.Fortran.VM: Gravitinos not handled"
-
- let children2 rhs =
- match F.children rhs with
- | [wf1; wf2] -> (wf1, wf2)
- | _ -> failwith "Targets.children2: can't happen"
-
- let children3 rhs =
- match F.children rhs with
- | [wf1; wf2; wf3] -> (wf1, wf2, wf3)
- | _ -> invalid_arg "Targets.children3: can't happen"
-
- let print_vector4 c lhs wf1 wf2 wf3 fusion (coeff, contraction) =
- let printc r1 r2 r3 = printi ovm_FUSE_V_VVV ~lhs:lhs ~coupl:c
- ~coeff:coeff ~rhs1:r1 ~rhs2:r2 ~rhs3:r3 in
- match contraction, fusion with
- | C_12_34, (F341|F431|F342|F432|F123|F213|F124|F214)
- | C_13_42, (F241|F421|F243|F423|F132|F312|F134|F314)
- | C_14_23, (F231|F321|F234|F324|F142|F412|F143|F413) ->
- printc wf1 wf2 wf3
- | C_12_34, (F134|F143|F234|F243|F312|F321|F412|F421)
- | C_13_42, (F124|F142|F324|F342|F213|F231|F413|F431)
- | C_14_23, (F123|F132|F423|F432|F214|F241|F314|F341) ->
- printc wf2 wf3 wf1
- | C_12_34, (F314|F413|F324|F423|F132|F231|F142|F241)
- | C_13_42, (F214|F412|F234|F432|F123|F321|F143|F341)
- | C_14_23, (F213|F312|F243|F342|F124|F421|F134|F431) ->
- printc wf1 wf3 wf2
-
- let print_current lookups lhs amplitude rhs =
- let f = mult_wf lookups.dict amplitude in
- match F.coupling rhs with
- | V3 (vertex, fusion, constant) ->
- let ch1, ch2 = children2 rhs in
- let wf1 = wf_index lookups.wfmap lookups.n_wfs (f ch1)
- and wf2 = wf_index lookups.wfmap lookups.n_wfs (f ch2)
- and p1 = mom_ID lookups.pmap ch1
- and p2 = mom_ID lookups.pmap ch2
- and const_ID = get_const_ID lookups.cmap constant in
- let c = if (F.sign rhs) < 0 then - const_ID else const_ID in
- begin match vertex with
- | FBF (coeff, fb, b, f) ->
- begin match coeff, fb, b, f with
- | _, Psibar, VLRM, Psi | _, Psibar, SPM, Psi
- | _, Psibar, TVA, Psi | _, Psibar, TVAM, Psi
- | _, Psibar, TLR, Psi | _, Psibar, TLRM, Psi
- | _, Psibar, TRL, Psi | _, Psibar, TRLM, Psi -> failwith
- "print_current: V3: Momentum dependent fermion couplings not implemented"
- | _, _, _, _ ->
- ferm_print_current (coeff, fb, b, f) lhs c wf1 wf2 fusion
- end
- | PBP (_, _, _, _) ->
- failwith "print_current: V3: PBP not implemented"
- | BBB (_, _, _, _) ->
- failwith "print_current: V3: BBB not implemented"
- | GBG (_, _, _, _) ->
- failwith "print_current: V3: GBG not implemented"
-
- | Gauge_Gauge_Gauge coeff ->
- let printc r1 r2 r3 r4 = printi ovm_FUSE_G_GG
- ~lhs:lhs ~coupl:c ~coeff:coeff ~rhs1:r1 ~rhs2:r2 ~rhs3:r3
- ~rhs4:r4 in
- begin match fusion with
- | (F23|F31|F12) -> printc wf1 p1 wf2 p2
- | (F32|F13|F21) -> printc wf2 p2 wf1 p1
- end
-
- | I_Gauge_Gauge_Gauge _ ->
- failwith "print_current: I_Gauge_Gauge_Gauge: not implemented"
-
- | Scalar_Vector_Vector coeff ->
- let printc code r1 r2 = printi code
- ~lhs:lhs ~coupl:c ~coeff:coeff ~rhs1:r1 ~rhs2:r2 in
- begin match fusion with
- | (F23|F32) -> printc ovm_FUSE_S_VV wf1 wf2
- | (F12|F13) -> printc ovm_FUSE_V_SV wf1 wf2
- | (F21|F31) -> printc ovm_FUSE_V_SV wf2 wf1
- end
-
- | Scalar_Scalar_Scalar coeff ->
- printi ovm_FUSE_S_SS ~lhs:lhs ~coupl:c ~coeff:coeff ~rhs1:wf1 ~rhs2:wf2
-
- | Vector_Scalar_Scalar coeff ->
- let printc code ?flip:(f = 1) r1 r2 r3 r4 = printi code
- ~lhs:lhs ~coupl:(c*f) ~coeff:coeff ~rhs1:r1 ~rhs2:r2 ~rhs3:r3
- ~rhs4:r4 in
- begin match fusion with
- | F23 -> printc ovm_FUSE_V_SS wf1 p1 wf2 p2
- | F32 -> printc ovm_FUSE_V_SS wf2 p2 wf1 p1
- | F12 -> printc ovm_FUSE_S_VS wf1 p1 wf2 p2
- | F21 -> printc ovm_FUSE_S_VS wf2 p2 wf1 p1
- | F13 -> printc ovm_FUSE_S_VS wf1 p1 wf2 p2 ~flip:(-1)
- | F31 -> printc ovm_FUSE_S_VS wf2 p2 wf1 p1 ~flip:(-1)
- end
-
- | Aux_Vector_Vector _ ->
- failwith "print_current: V3: not implemented"
-
- | Aux_Scalar_Scalar _ ->
- failwith "print_current: V3: not implemented"
-
- | Aux_Scalar_Vector _ ->
- failwith "print_current: V3: not implemented"
-
- | Graviton_Scalar_Scalar _ ->
- failwith "print_current: V3: not implemented"
-
- | Graviton_Vector_Vector _ ->
- failwith "print_current: V3: not implemented"
-
- | Graviton_Spinor_Spinor _ ->
- failwith "print_current: V3: not implemented"
-
- | Dim4_Vector_Vector_Vector_T _ ->
- failwith "print_current: V3: not implemented"
-
- | Dim4_Vector_Vector_Vector_L _ ->
- failwith "print_current: V3: not implemented"
-
- | Dim6_Gauge_Gauge_Gauge _ ->
- failwith "print_current: V3: not implemented"
-
- | Dim4_Vector_Vector_Vector_T5 _ ->
- failwith "print_current: V3: not implemented"
-
- | Dim4_Vector_Vector_Vector_L5 _ ->
- failwith "print_current: V3: not implemented"
-
- | Dim6_Gauge_Gauge_Gauge_5 _ ->
- failwith "print_current: V3: not implemented"
-
- | Aux_DScalar_DScalar _ ->
- failwith "print_current: V3: not implemented"
-
- | Aux_Vector_DScalar _ ->
- failwith "print_current: V3: not implemented"
-
- | Dim5_Scalar_Gauge2 coeff ->
- let printc code r1 r2 r3 r4 = printi code
- ~lhs:lhs ~coupl:c ~coeff:coeff ~rhs1:r1 ~rhs2:r2 ~rhs3:r3
- ~rhs4:r4 in
- begin match fusion with
- | (F23|F32) -> printc ovm_FUSE_S_G2 wf1 p1 wf2 p2
- | (F12|F13) -> printc ovm_FUSE_G_SG wf1 p1 wf2 p2
- | (F21|F31) -> printc ovm_FUSE_G_GS wf2 p2 wf1 p1
- end
-
- | Dim5_Scalar_Gauge2_Skew coeff ->
- let printc code ?flip:(f = 1) r1 r2 r3 r4 = printi code
- ~lhs:lhs ~coupl:(c*f) ~coeff:coeff ~rhs1:r1 ~rhs2:r2 ~rhs3:r3
- ~rhs4:r4 in
- begin match fusion with
- | (F23|F32) -> printc ovm_FUSE_S_G2_SKEW wf1 p1 wf2 p2
- | (F12|F13) -> printc ovm_FUSE_G_SG_SKEW wf1 p1 wf2 p2
- | (F21|F31) -> printc ovm_FUSE_G_GS_SKEW wf2 p1 wf1 p2 ~flip:(-1)
- end
-
- | Dim5_Scalar_Vector_Vector_T _ ->
- failwith "print_current: V3: not implemented"
-
- | Dim5_Scalar_Vector_Vector_U _ ->
- failwith "print_current: V3: not implemented"
-
- | Dim5_Scalar_Scalar2 _ ->
- failwith "print_current: V3: not implemented"
-
- | Dim6_Vector_Vector_Vector_T _ ->
- failwith "print_current: V3: not implemented"
-
- | Tensor_2_Vector_Vector _ ->
- failwith "print_current: V3: not implemented"
-
- | Tensor_2_Scalar_Scalar _ ->
- failwith "print_current: V3: not implemented"
-
- | Dim5_Tensor_2_Vector_Vector_1 _ ->
- failwith "print_current: V3: not implemented"
-
- | Dim5_Tensor_2_Vector_Vector_2 _ ->
- failwith "print_current: V3: not implemented"
-
- | Dim7_Tensor_2_Vector_Vector_T _ ->
- failwith "print_current: V3: not implemented"
-
- | Dim5_Scalar_Vector_Vector_TU _ ->
- failwith "print_current: V3: not implemented"
-
- | Scalar_Vector_Vector_t _ ->
- failwith "print_current: V3: not implemented"
-
- | Tensor_2_Vector_Vector_cf _ ->
- failwith "print_current: V3: not implemented"
-
- | Tensor_2_Scalar_Scalar_cf _ ->
- failwith "print_current: V3: not implemented"
-
- | Tensor_2_Vector_Vector_1 _ ->
- failwith "print_current: V3: not implemented"
-
- | Tensor_2_Vector_Vector_t _ ->
- failwith "print_current: V3: not implemented"
-
- | TensorVector_Vector_Vector _ ->
- failwith "print_current: V3: not implemented"
-
- | TensorVector_Vector_Vector_cf _ ->
- failwith "print_current: V3: not implemented"
-
- | TensorVector_Scalar_Scalar _ ->
- failwith "print_current: V3: not implemented"
-
- | TensorVector_Scalar_Scalar_cf _ ->
- failwith "print_current: V3: not implemented"
-
- | TensorScalar_Vector_Vector _ ->
- failwith "print_current: V3: not implemented"
-
- | TensorScalar_Vector_Vector_cf _ ->
- failwith "print_current: V3: not implemented"
-
- | TensorScalar_Scalar_Scalar _ ->
- failwith "print_current: V3: not implemented"
-
- | TensorScalar_Scalar_Scalar_cf _ ->
- failwith "print_current: V3: not implemented"
-
- | Dim6_Scalar_Vector_Vector_D _ ->
- failwith "print_current: V3: not implemented"
-
- | Dim6_Scalar_Vector_Vector_DP _ ->
- failwith "print_current: V3: not implemented"
-
- | Dim6_HAZ_D _ ->
- failwith "print_current: V3: not implemented"
-
- | Dim6_HAZ_DP _ ->
- failwith "print_current: V3: not implemented"
-
- | Dim6_HHH _ ->
- failwith "print_current: V3: not implemented"
-
- | Dim6_Gauge_Gauge_Gauge_i _ ->
- failwith "print_current: V3: not implemented"
-
- | Gauge_Gauge_Gauge_i _ ->
- failwith "print_current: V3: not implemented"
-
- | Dim6_GGG _ ->
- failwith "print_current: V3: not implemented"
-
- | Dim6_AWW_DP _ ->
- failwith "print_current: V3: not implemented"
-
- | Dim6_AWW_DW _ ->
- failwith "print_current: V3: not implemented"
-
- | Dim6_WWZ_DPWDW _ ->
- failwith "print_current: V3: not implemented"
-
- | Dim6_WWZ_DW _ ->
- failwith "print_current: V3: not implemented"
-
- | Dim6_WWZ_D _ ->
- failwith "print_current: V3: not implemented"
-
- | Aux_Gauge_Gauge _ ->
- failwith "print_current: V3 (Aux_Gauge_Gauge): not implemented"
-
- end
-
-(* Flip the sign in [c] to account for the~$\mathrm{i}^2$ relative to diagrams
- with only cubic couplings. *)
- | V4 (vertex, fusion, constant) ->
- let ch1, ch2, ch3 = children3 rhs in
- let wf1 = wf_index lookups.wfmap lookups.n_wfs (f ch1)
- and wf2 = wf_index lookups.wfmap lookups.n_wfs (f ch2)
- and wf3 = wf_index lookups.wfmap lookups.n_wfs (f ch3)
- (*i
- (*and p1 = mom_ID lookups.pmap ch1*)
- (*and p2 = mom_ID lookups.pmap ch2*)
- (*and p3 = mom_ID lookups.pmap ch2*)
- i*)
- and const_ID = get_const_ID lookups.cmap constant in
- let c =
- if (F.sign rhs) < 0 then const_ID else - const_ID in
- begin match vertex with
- | Scalar4 coeff ->
- printi ovm_FUSE_S_SSS ~lhs:lhs ~coupl:c ~coeff:coeff ~rhs1:wf1
- ~rhs2:wf2 ~rhs3:wf3
- | Scalar2_Vector2 coeff ->
- let printc code r1 r2 r3 = printi code
- ~lhs:lhs ~coupl:c ~coeff:coeff ~rhs1:r1 ~rhs2:r2 ~rhs3:r3 in
- begin match fusion with
- | F134 | F143 | F234 | F243 ->
- printc ovm_FUSE_S_SVV wf1 wf2 wf3
- | F314 | F413 | F324 | F423 ->
- printc ovm_FUSE_S_SVV wf2 wf1 wf3
- | F341 | F431 | F342 | F432 ->
- printc ovm_FUSE_S_SVV wf3 wf1 wf2
- | F312 | F321 | F412 | F421 ->
- printc ovm_FUSE_V_SSV wf2 wf3 wf1
- | F231 | F132 | F241 | F142 ->
- printc ovm_FUSE_V_SSV wf1 wf3 wf2
- | F123 | F213 | F124 | F214 ->
- printc ovm_FUSE_V_SSV wf1 wf2 wf3
- end
-
- | Vector4 contractions ->
- List.iter (print_vector4 c lhs wf1 wf2 wf3 fusion) contractions
-
- | Vector4_K_Matrix_tho _
- | Vector4_K_Matrix_jr _
- | Vector4_K_Matrix_cf_t0 _
- | Vector4_K_Matrix_cf_t1 _
- | Vector4_K_Matrix_cf_t2 _
- | Vector4_K_Matrix_cf_t_rsi _
- | Vector4_K_Matrix_cf_m0 _
- | Vector4_K_Matrix_cf_m1 _
- | Vector4_K_Matrix_cf_m7 _
- | DScalar2_Vector2_K_Matrix_ms _
- | DScalar2_Vector2_m_0_K_Matrix_cf _
- | DScalar2_Vector2_m_1_K_Matrix_cf _
- | DScalar2_Vector2_m_7_K_Matrix_cf _
- | DScalar4_K_Matrix_ms _ ->
- failwith "print_current: V4: K_Matrix not implemented"
- | Dim8_Scalar2_Vector2_1 _
- | Dim8_Scalar2_Vector2_2 _
- | Dim8_Scalar2_Vector2_m_0 _
- | Dim8_Scalar2_Vector2_m_1 _
- | Dim8_Scalar2_Vector2_m_7 _
- | Dim8_Scalar4 _ ->
- failwith "print_current: V4: not implemented"
- | Dim8_Vector4_t_0 _ ->
- failwith "print_current: V4: not implemented"
- | Dim8_Vector4_t_1 _ ->
- failwith "print_current: V4: not implemented"
- | Dim8_Vector4_t_2 _ ->
- failwith "print_current: V4: not implemented"
- | Dim8_Vector4_m_0 _ ->
- failwith "print_current: V4: not implemented"
- | Dim8_Vector4_m_1 _ ->
- failwith "print_current: V4: not implemented"
- | Dim8_Vector4_m_7 _ ->
- failwith "print_current: V4: not implemented"
- | GBBG _ ->
- failwith "print_current: V4: GBBG not implemented"
- | DScalar4 _
- | DScalar2_Vector2 _ ->
- failwith "print_current: V4: DScalars not implemented"
- | Dim6_H4_P2 _ ->
- failwith "print_current: V4: not implemented"
- | Dim6_AHWW_DPB _ ->
- failwith "print_current: V4: not implemented"
- | Dim6_AHWW_DPW _ ->
- failwith "print_current: V4: not implemented"
- | Dim6_AHWW_DW _ ->
- failwith "print_current: V4: not implemented"
- | Dim6_Vector4_DW _ ->
- failwith "print_current: V4: not implemented"
- | Dim6_Vector4_W _ ->
- failwith "print_current: V4: not implemented"
- | Dim6_Scalar2_Vector2_D _ ->
- failwith "print_current: V4: not implemented"
- | Dim6_Scalar2_Vector2_DP _ ->
- failwith "print_current: V4: not implemented"
- | Dim6_HWWZ_DW _ ->
- failwith "print_current: V4: not implemented"
- | Dim6_HWWZ_DPB _ ->
- failwith "print_current: V4: not implemented"
- | Dim6_HWWZ_DDPW _ ->
- failwith "print_current: V4: not implemented"
- | Dim6_HWWZ_DPW _ ->
- failwith "print_current: V4: not implemented"
- | Dim6_AHHZ_D _ ->
- failwith "print_current: V4: not implemented"
- | Dim6_AHHZ_DP _ ->
- failwith "print_current: V4: not implemented"
- | Dim6_AHHZ_PB _ ->
- failwith "print_current: V4: not implemented"
- | Dim6_Scalar2_Vector2_PB _ ->
- failwith "print_current: V4: not implemented"
- | Dim6_HHZZ_T _ ->
- failwith "print_current: V4: not implemented"
-
- end
-
- | Vn (_, _, _) -> invalid_arg "Targets.print_current: n-ary fusion."
-
-(* \thocwmodulesubsection{Fusions} *)
-
- let print_fusion lookups lhs_momID fusion amplitude =
- if F.on_shell amplitude (F.lhs fusion) then
- failwith "print_fusion: on_shell projectors not implemented!";
- if F.is_gauss amplitude (F.lhs fusion) then
- failwith "print_fusion: gauss amplitudes not implemented!";
- let lhs_wf = mult_wf lookups.dict amplitude (F.lhs fusion) in
- let lhs_wfID = wf_index lookups.wfmap lookups.n_wfs lhs_wf in
- let f = F.flavor (F.lhs fusion) in
- let pdg = CM.pdg f in
- let w =
- begin match CM.width f with
- | Vanishing | Fudged -> 0
- | Constant -> 1
- | Timelike -> 2
- | Complex_Mass -> 3
- | Running -> 4
- | Custom _ -> failwith "Targets.VM: custom width not available"
- end
- in
- let propagate code = printi code ~lhs:lhs_wfID ~rhs1:lhs_momID
- ~coupl:(abs(pdg)) ~coeff:w ~rhs4:(get_ID' amp_compare lookups.amap amplitude)
- in
- begin match CM.propagator f with
- | Prop_Scalar ->
- propagate ovm_PROPAGATE_SCALAR
- | Prop_Col_Scalar ->
- propagate ovm_PROPAGATE_COL_SCALAR
- | Prop_Ghost ->
- propagate ovm_PROPAGATE_GHOST
- | Prop_Spinor ->
- propagate ovm_PROPAGATE_SPINOR
- | Prop_ConjSpinor ->
- propagate ovm_PROPAGATE_CONJSPINOR
- | Prop_Majorana ->
- propagate ovm_PROPAGATE_MAJORANA
- | Prop_Col_Majorana ->
- propagate ovm_PROPAGATE_COL_MAJORANA
- | Prop_Unitarity ->
- propagate ovm_PROPAGATE_UNITARITY
- | Prop_Col_Unitarity ->
- propagate ovm_PROPAGATE_COL_UNITARITY
- | Prop_Feynman ->
- propagate ovm_PROPAGATE_FEYNMAN
- | Prop_Col_Feynman ->
- propagate ovm_PROPAGATE_COL_FEYNMAN
- | Prop_Vectorspinor ->
- propagate ovm_PROPAGATE_VECTORSPINOR
- | Prop_Tensor_2 ->
- propagate ovm_PROPAGATE_TENSOR2
- | Aux_Col_Scalar | Aux_Col_Vector | Aux_Col_Tensor_1 ->
- failwith "print_fusion: Aux_Col_* not implemented!"
- | Aux_Vector | Aux_Tensor_1 | Aux_Scalar | Aux_Spinor | Aux_ConjSpinor
- | Aux_Majorana | Only_Insertion ->
- propagate ovm_PROPAGATE_NONE
- | Prop_Gauge _ ->
- failwith "print_fusion: Prop_Gauge not implemented!"
- | Prop_Tensor_pure ->
- failwith "print_fusion: Prop_Tensor_pure not implemented!"
- | Prop_Vector_pure ->
- failwith "print_fusion: Prop_Vector_pure not implemented!"
- | Prop_Rxi _ ->
- failwith "print_fusion: Prop_Rxi not implemented!"
- | Prop_UFO _ ->
- failwith "print_fusion: Prop_UFO not implemented!"
- end;
-
-(* Since the OVM knows that we want to propagate a wf, we can send the
- necessary fusions now. *)
-
- List.iter (print_current lookups lhs_wfID amplitude) (F.rhs fusion)
-
- let print_all_fusions lookups =
- let fusions = CF.fusions lookups.amplitudes in
- let fset = List.fold_left (fun s x -> FSet.add x s) FSet.empty fusions in
- ignore (List.fold_left (fun level (f, amplitude) ->
- let wf = F.lhs f in
- let lhs_momID = mom_ID lookups.pmap wf in
- let level' = List.length (F.momentum_list wf) in
- if (level' > level && level' > 2) then break ();
- print_fusion lookups lhs_momID f amplitude;
- level')
- 1 (FSet.elements fset) )
-
-(* \thocwmodulesubsection{Brakets} *)
-
- let print_braket lookups amplitude braket =
- let bra = F.bra braket
- and ket = F.ket braket in
- let braID = wf_index lookups.wfmap lookups.n_wfs
- (mult_wf lookups.dict amplitude bra) in
- List.iter (print_current lookups braID amplitude) ket
-
-(* \begin{equation}
- \ii T = \ii^{\#\text{vertices}}\ii^{\#\text{propagators}} \cdots
- = \ii^{n-2}\ii^{n-3} \cdots
- = -\ii(-1)^n \cdots
- \end{equation} *)
-
-(* All brakets for one cflow amplitude should be calculated by one
- thread to avoid multiple access on the same memory (amplitude).*)
-
- let print_brakets lookups (amplitude, i) =
- let n = List.length (F.externals amplitude) in
- let sign = if n mod 2 = 0 then -1 else 1
- and sym = F.symmetry amplitude in
- printi ovm_CALC_BRAKET ~lhs:i ~rhs1:sym ~coupl:sign;
- amplitude |> F.brakets |> List.iter (print_braket lookups amplitude)
-
-(* Fortran arrays/OCaml lists start on 1/0. The amplitude list is sorted by
- [amp_compare] according to their color flows. In this way the amp array
- is sorted in the same way as [table_color_factors]. *)
-
- let print_all_brakets lookups =
- let g i elt = print_brakets lookups (elt, i+1) in
- lookups.amplitudes |> CF.processes |> List.sort amp_compare
- |> ThoList.iteri g 0
-
-(* \thocwmodulesubsection{Couplings} *)
-
-(* For now we only care to catch the arrays [gncneu], [gnclep], [gncup] and
- [gncdown] of the SM. This will need an overhaul when it is clear how we store
- the type information of coupling constants. *)
-
- let strip_array_tag = function
- | Real_Array x -> x
- | Complex_Array x -> x
-
- let array_constants_list =
- let params = M.parameters()
- and strip_to_constant (lhs, _) = strip_array_tag lhs in
- List.map strip_to_constant params.derived_arrays
-
- let is_array x = List.mem x array_constants_list
-
- let constants_map =
- let first = fun (x, _, _) -> x in
- let second = fun (_, y, _) -> y in
- let third = fun (_, _, z) -> z in
- let v3 = List.map third (first (M.vertices () ))
- and v4 = List.map third (second (M.vertices () )) in
- let set = List.fold_left (fun s x -> CSet.add x s) CSet.empty (v3 @ v4) in
- let (arrays, singles) = CSet.partition is_array set in
- (singles |> CSet.elements |> map_of_list,
- arrays |> CSet.elements |> map_of_list)
-
-(* \thocwmodulesubsection{Output calls} *)
-
- let amplitudes_to_channel (cmdline : string) (oc : out_channel)
- (diagnostics : (diagnostic * bool) list ) (amplitudes : CF.amplitudes) =
-
- set_formatter_out_channel oc;
- if (num_particles amplitudes = 0) then begin
- print_description cmdline;
- print_zero_header (); nl ()
- end else begin
- let (wfset, amap) = wfset_amps amplitudes in
- let pset = expand_pset (momenta_set wfset)
- and n_wfs = num_wfs wfset in
- let wfmap = wf_map_of_list (WFSet.elements wfset)
- and pmap = map_of_list (ISet.elements pset)
- and cmap = constants_map in
-
- let lookups = {pmap = pmap; wfmap = wfmap; cmap = cmap; amap = amap;
- n_wfs = n_wfs; amplitudes = amplitudes;
- dict = CF.dictionary amplitudes} in
-
- print_description cmdline;
- print_header lookups wfset;
- print_spin_table amplitudes;
- print_flavor_tables amplitudes;
- print_color_tables amplitudes;
- printf "@\n%s" ("OVM instructions for momenta addition," ^
- " fusions and brakets start here: ");
- break ();
- add_all_mom lookups pset;
- print_ext_amps lookups;
- break ();
- print_all_fusions lookups;
- break ();
- print_all_brakets lookups;
- break (); nl ();
- print_flush ()
- end
-
- let parameters_to_fortran oc _ =
- (*i The -params options is used as wrapper between OVM and Whizard. Most
- * trouble for the OVM comes from the array dimensionalities of couplings
- * but O'Mega should also know whether a constant is real or complex.
- * Hopefully all will be clearer with the fully general Lorentz structures
- * and UFO support. For now, we stick with this brute-force solution. i*)
- set_formatter_out_channel oc;
- let arrays_to_set = not (IMap.is_empty (snd constants_map)) in
- let set_coupl ty dim cmap = IMap.iter (fun key elt ->
- printf " %s(%s%d) = %s" ty dim key (M.constant_symbol elt);
- nl () ) cmap in
- let declarations () =
- printf " complex(%s), dimension(%d) :: ovm_coupl_cmplx"
- !kind (constants_map |> fst |> largest_key); nl ();
- if arrays_to_set then
- printf " complex(%s), dimension(2, %d) :: ovm_coupl_cmplx2"
- !kind (constants_map |> snd |> largest_key); nl () in
- let print_line str = printf "%s" str; nl() in
- let print_md5sum = function
- | Some s ->
- print_line " function md5sum ()";
- print_line " character(len=32) :: md5sum";
- print_line (" bytecode_file = '" ^ !bytecode_file ^ "'");
- print_line " call initialize_vm (vm, bytecode_file)";
- print_line " ! DON'T EVEN THINK of modifying the following line!";
- print_line (" md5sum = '" ^ s ^ "'");
- print_line " end function md5sum";
- | None -> ()
- in
- let print_inquiry_function_openmp () = begin
- print_line " pure function openmp_supported () result (status)";
- print_line " logical :: status";
- print_line (" status = " ^ (if !openmp then ".true." else ".false."));
- print_line " end function openmp_supported";
- nl ()
- end in
- let print_interface whizard =
- if whizard then begin
- print_line " subroutine init (par, scheme)";
- print_line " real(kind=default), dimension(*), intent(in) :: par";
- print_line " integer, intent(in) :: scheme";
- print_line (" bytecode_file = '" ^ !bytecode_file ^ "'");
- print_line " call import_from_whizard (par, scheme)";
- print_line " call initialize_vm (vm, bytecode_file)";
- print_line " end subroutine init";
- nl ();
- print_line " subroutine final ()";
- print_line " call vm%final ()";
- print_line " end subroutine final";
- nl ();
- print_line " subroutine update_alpha_s (alpha_s)";
- print_line (" real(kind=" ^ !kind ^ "), intent(in) :: alpha_s");
- print_line " call model_update_alpha_s (alpha_s)";
- print_line " end subroutine update_alpha_s";
- nl ()
- end
- else begin
- print_line " subroutine init ()";
- print_line (" bytecode_file = '" ^ !bytecode_file ^ "'");
- print_line " call init_parameters ()";
- print_line " call initialize_vm (vm, bytecode_file)";
- print_line " end subroutine"
- end in
- let print_lookup_functions () = begin
- print_line " pure function number_particles_in () result (n)";
- print_line " integer :: n";
- print_line " n = vm%number_particles_in ()";
- print_line " end function number_particles_in";
- nl();
- print_line " pure function number_particles_out () result (n)";
- print_line " integer :: n";
- print_line " n = vm%number_particles_out ()";
- print_line " end function number_particles_out";
- nl();
- print_line " pure function number_spin_states () result (n)";
- print_line " integer :: n";
- print_line " n = vm%number_spin_states ()";
- print_line " end function number_spin_states";
- nl();
- print_line " pure subroutine spin_states (a)";
- print_line " integer, dimension(:,:), intent(out) :: a";
- print_line " call vm%spin_states (a)";
- print_line " end subroutine spin_states";
- nl();
- print_line " pure function number_flavor_states () result (n)";
- print_line " integer :: n";
- print_line " n = vm%number_flavor_states ()";
- print_line " end function number_flavor_states";
- nl();
- print_line " pure subroutine flavor_states (a)";
- print_line " integer, dimension(:,:), intent(out) :: a";
- print_line " call vm%flavor_states (a)";
- print_line " end subroutine flavor_states";
- nl();
- print_line " pure function number_color_indices () result (n)";
- print_line " integer :: n";
- print_line " n = vm%number_color_indices ()";
- print_line " end function number_color_indices";
- nl();
- print_line " pure function number_color_flows () result (n)";
- print_line " integer :: n";
- print_line " n = vm%number_color_flows ()";
- print_line " end function number_color_flows";
- nl();
- print_line " pure subroutine color_flows (a, g)";
- print_line " integer, dimension(:,:,:), intent(out) :: a";
- print_line " logical, dimension(:,:), intent(out) :: g";
- print_line " call vm%color_flows (a, g)";
- print_line " end subroutine color_flows";
- nl();
- print_line " pure function number_color_factors () result (n)";
- print_line " integer :: n";
- print_line " n = vm%number_color_factors ()";
- print_line " end function number_color_factors";
- nl();
- print_line " pure subroutine color_factors (cf)";
- print_line " use omega_color";
- print_line " type(omega_color_factor), dimension(:), intent(out) :: cf";
- print_line " call vm%color_factors (cf)";
- print_line " end subroutine color_factors";
- nl();
- print_line " !pure unless OpenMP";
- print_line " !pure function color_sum (flv, hel) result (amp2)";
- print_line " function color_sum (flv, hel) result (amp2)";
- print_line " use kinds";
- print_line " integer, intent(in) :: flv, hel";
- print_line " real(kind=default) :: amp2";
- print_line " amp2 = vm%color_sum (flv, hel)";
- print_line " end function color_sum";
- nl();
- print_line " subroutine new_event (p)";
- print_line " use kinds";
- print_line " real(kind=default), dimension(0:3,*), intent(in) :: p";
- print_line " call vm%new_event (p)";
- print_line " end subroutine new_event";
- nl();
- print_line " subroutine reset_helicity_selection (threshold, cutoff)";
- print_line " use kinds";
- print_line " real(kind=default), intent(in) :: threshold";
- print_line " integer, intent(in) :: cutoff";
- print_line " call vm%reset_helicity_selection (threshold, cutoff)";
- print_line " end subroutine reset_helicity_selection";
- nl();
- print_line " pure function is_allowed (flv, hel, col) result (yorn)";
- print_line " logical :: yorn";
- print_line " integer, intent(in) :: flv, hel, col";
- print_line " yorn = vm%is_allowed (flv, hel, col)";
- print_line " end function is_allowed";
- nl();
- print_line " pure function get_amplitude (flv, hel, col) result (amp_result)";
- print_line " use kinds";
- print_line " complex(kind=default) :: amp_result";
- print_line " integer, intent(in) :: flv, hel, col";
- print_line " amp_result = vm%get_amplitude(flv, hel, col)";
- print_line " end function get_amplitude";
- nl();
- end in
- print_line ("module " ^ !wrapper_module);
- print_line (" use " ^ !parameter_module_external);
- print_line " use iso_varying_string, string_t => varying_string";
- print_line " use kinds";
- print_line " use omegavm95";
- print_line " implicit none";
- print_line " private";
- print_line " type(vm_t) :: vm";
- print_line " type(string_t) :: bytecode_file";
- print_line (" public :: number_particles_in, number_particles_out," ^
- " number_spin_states, &");
- print_line (" spin_states, number_flavor_states, flavor_states," ^
- " number_color_indices, &");
- print_line (" number_color_flows, color_flows," ^
- " number_color_factors, color_factors, &");
- print_line (" color_sum, new_event, reset_helicity_selection," ^
- " is_allowed, get_amplitude, &");
- print_line (" init, " ^
- (match !md5sum with Some _ -> "md5sum, "
- | None -> "") ^ "openmp_supported");
- if !whizard then
- print_line (" public :: final, update_alpha_s")
- else
- print_line (" public :: initialize_vm");
- declarations ();
- print_line "contains";
-
- print_line " subroutine setup_couplings ()";
- set_coupl "ovm_coupl_cmplx" "" (fst constants_map);
- if arrays_to_set then
- set_coupl "ovm_coupl_cmplx2" ":," (snd constants_map);
- print_line " end subroutine setup_couplings";
- print_line " subroutine initialize_vm (vm, bytecode_file)";
- print_line " class(vm_t), intent(out) :: vm";
- print_line " type(string_t), intent(in) :: bytecode_file";
- print_line " type(string_t) :: version";
- print_line " type(string_t) :: model";
- print_line (" version = 'OVM " ^ version ^ "'");
- print_line (" model = 'Model " ^ model_name ^ "'");
- print_line " call setup_couplings ()";
- print_line " call vm%init (bytecode_file, version, model, verbose=.False., &";
- print_line " coupl_cmplx=ovm_coupl_cmplx, &";
- if arrays_to_set then
- print_line " coupl_cmplx2=ovm_coupl_cmplx2, &";
- print_line (" mass=mass, width=width, openmp=" ^ (if !openmp then
- ".true." else ".false.") ^ ")");
- print_line " end subroutine initialize_vm";
- nl();
- print_md5sum !md5sum;
- print_inquiry_function_openmp ();
- print_interface !whizard;
- print_lookup_functions ();
-
- print_line ("end module " ^ !wrapper_module)
-
- let parameters_to_channel oc =
- parameters_to_fortran oc (CM.parameters ())
-
- end
-
-(* \thocwmodulesection{\texttt{Fortran\,90/95}} *)
-
-(* \thocwmodulesubsection{Dirac Fermions}
- We factor out the code for fermions so that we can use the simpler
- implementation for Dirac fermions if the model contains no Majorana
- fermions. *)
-
-module type Fermions =
- sig
- open Coupling
- val psi_type : string
- val psibar_type : string
- val chi_type : string
- val grav_type : string
- val psi_incoming : string
- val brs_psi_incoming : string
- val psibar_incoming : string
- val brs_psibar_incoming : string
- val chi_incoming : string
- val brs_chi_incoming : string
- val grav_incoming : string
- val psi_outgoing : string
- val brs_psi_outgoing : string
- val psibar_outgoing : string
- val brs_psibar_outgoing : string
- val chi_outgoing : string
- val brs_chi_outgoing : string
- val grav_outgoing : string
- val psi_propagator : string
- val psibar_propagator : string
- val chi_propagator : string
- val grav_propagator : string
- val psi_projector : string
- val psibar_projector : string
- val chi_projector : string
- val grav_projector : string
- val psi_gauss : string
- val psibar_gauss : string
- val chi_gauss : string
- val grav_gauss : string
- val print_current : int * fermionbar * boson * fermion ->
- string -> string -> string -> fuse2 -> unit
- val print_current_mom : int * fermionbar * boson * fermion ->
- string -> string -> string -> string -> string -> string
- -> fuse2 -> unit
- val print_current_p : int * fermion * boson * fermion ->
- string -> string -> string -> fuse2 -> unit
- val print_current_b : int * fermionbar * boson * fermionbar ->
- string -> string -> string -> fuse2 -> unit
- val print_current_g : int * fermionbar * boson * fermion ->
- string -> string -> string -> string -> string -> string
- -> fuse2 -> unit
- val print_current_g4 : int * fermionbar * boson2 * fermion ->
- string -> string -> string -> string -> fuse3 -> unit
- val reverse_braket : bool -> lorentz -> lorentz list -> bool
- val use_module : string
- val require_library : string list
- end
-
-module Fortran_Fermions : Fermions =
- struct
- open Coupling
- open Format
-
- let psi_type = "spinor"
- let psibar_type = "conjspinor"
- let chi_type = "???"
- let grav_type = "???"
-
- let psi_incoming = "u"
- let brs_psi_incoming = "brs_u"
- let psibar_incoming = "vbar"
- let brs_psibar_incoming = "brs_vbar"
- let chi_incoming = "???"
- let brs_chi_incoming = "???"
- let grav_incoming = "???"
- let psi_outgoing = "v"
- let brs_psi_outgoing = "brs_v"
- let psibar_outgoing = "ubar"
- let brs_psibar_outgoing = "brs_ubar"
- let chi_outgoing = "???"
- let brs_chi_outgoing = "???"
- let grav_outgoing = "???"
-
- let psi_propagator = "pr_psi"
- let psibar_propagator = "pr_psibar"
- let chi_propagator = "???"
- let grav_propagator = "???"
-
- let psi_projector = "pj_psi"
- let psibar_projector = "pj_psibar"
- let chi_projector = "???"
- let grav_projector = "???"
-
- let psi_gauss = "pg_psi"
- let psibar_gauss = "pg_psibar"
- let chi_gauss = "???"
- let grav_gauss = "???"
-
- let format_coupling coeff c =
- match coeff with
- | 1 -> c
- | -1 -> "(-" ^ c ^")"
- | coeff -> string_of_int coeff ^ "*" ^ c
-
- let format_coupling_2 coeff c =
- match coeff with
- | 1 -> c
- | -1 -> "-" ^ c
- | coeff -> string_of_int coeff ^ "*" ^ c
-
-(* \begin{dubious}
- JR's coupling constant HACK, necessitated by tho's bad design descition.
- \end{dubious} *)
-
- let fastener s i ?p ?q () =
- try
- let offset = (String.index s '(') in
- if ((String.get s (String.length s - 1)) != ')') then
- failwith "fastener: wrong usage of parentheses"
- else
- let func_name = (String.sub s 0 offset) and
- tail =
- (String.sub s (succ offset) (String.length s - offset - 2)) in
- if (String.contains func_name ')') ||
- (String.contains tail '(') ||
- (String.contains tail ')') then
- failwith "fastener: wrong usage of parentheses"
- else
- func_name ^ "(" ^ string_of_int i ^ "," ^ tail ^ ")"
- with
- | Not_found ->
- if (String.contains s ')') then
- failwith "fastener: wrong usage of parentheses"
- else
- match p with
- | None -> s ^ "(" ^ string_of_int i ^ ")"
- | Some p ->
- match q with
- | None -> s ^ "(" ^ p ^ "*" ^ p ^ "," ^ string_of_int i ^ ")"
- | Some q -> s ^ "(" ^ p ^ "," ^ q ^ "," ^ string_of_int i ^ ")"
-
- let print_fermion_current coeff f c wf1 wf2 fusion =
- let c = format_coupling coeff c in
- match fusion with
- | F13 -> printf "%s_ff(%s,%s,%s)" f c wf1 wf2
- | F31 -> printf "%s_ff(%s,%s,%s)" f c wf2 wf1
- | F23 -> printf "f_%sf(%s,%s,%s)" f c wf1 wf2
- | F32 -> printf "f_%sf(%s,%s,%s)" f c wf2 wf1
- | F12 -> printf "f_f%s(%s,%s,%s)" f c wf1 wf2
- | F21 -> printf "f_f%s(%s,%s,%s)" f c wf2 wf1
-
-(* \begin{dubious}
- Using a two element array for the combined vector-axial and scalar-pseudo
- couplings helps to support HELAS as well. Since we will probably never
- support general boson couplings with HELAS, it might be retired in favor
- of two separate variables. For this [Model.constant_symbol] has to be
- generalized.
- \end{dubious} *)
-
-(* \begin{dubious}
- NB: passing the array instead of two separate constants would be a
- \emph{bad} idea, because the support for Majorana spinors below will
- have to flip signs!
- \end{dubious} *)
-
- let print_fermion_current2 coeff f c wf1 wf2 fusion =
- let c = format_coupling_2 coeff c in
- let c1 = fastener c 1 ()
- and c2 = fastener c 2 () in
- match fusion with
- | F13 -> printf "%s_ff(%s,%s,%s,%s)" f c1 c2 wf1 wf2
- | F31 -> printf "%s_ff(%s,%s,%s,%s)" f c1 c2 wf2 wf1
- | F23 -> printf "f_%sf(%s,%s,%s,%s)" f c1 c2 wf1 wf2
- | F32 -> printf "f_%sf(%s,%s,%s,%s)" f c1 c2 wf2 wf1
- | F12 -> printf "f_f%s(%s,%s,%s,%s)" f c1 c2 wf1 wf2
- | F21 -> printf "f_f%s(%s,%s,%s,%s)" f c1 c2 wf2 wf1
-
- let print_fermion_current_mom_v1 coeff f c wf1 wf2 p1 p2 p12 fusion =
- let c = format_coupling coeff c in
- let c1 = fastener c 1 and
- c2 = fastener c 2 in
- match fusion with
- | F13 -> printf "%s_ff(%s,%s,%s,%s)" f (c1 ~p:p12 ()) (c2 ~p:p12 ()) wf1 wf2
- | F31 -> printf "%s_ff(%s,%s,%s,%s)" f (c1 ~p:p12 ()) (c2 ~p:p12 ()) wf2 wf1
- | F23 -> printf "f_%sf(%s,%s,%s,%s)" f (c1 ~p:p1 ()) (c2 ~p:p1 ()) wf1 wf2
- | F32 -> printf "f_%sf(%s,%s,%s,%s)" f (c1 ~p:p2 ()) (c2 ~p:p2 ()) wf2 wf1
- | F12 -> printf "f_f%s(%s,%s,%s,%s)" f (c1 ~p:p2 ()) (c2 ~p:p2 ()) wf1 wf2
- | F21 -> printf "f_f%s(%s,%s,%s,%s)" f (c1 ~p:p1 ()) (c2 ~p:p1 ()) wf2 wf1
-
- let print_fermion_current_mom_v2 coeff f c wf1 wf2 p1 p2 p12 fusion =
- let c = format_coupling coeff c in
- let c1 = fastener c 1 and
- c2 = fastener c 2 in
- match fusion with
- | F13 -> printf "%s_ff(%s,%s,@,%s,%s,%s)" f (c1 ~p:p12 ()) (c2 ~p:p12 ()) wf1 wf2 p12
- | F31 -> printf "%s_ff(%s,%s,@,%s,%s,%s)" f (c1 ~p:p12 ()) (c2 ~p:p12 ()) wf2 wf1 p12
- | F23 -> printf "f_%sf(%s,%s,@,%s,%s,%s)" f (c1 ~p:p1 ()) (c2 ~p:p1 ()) wf1 wf2 p1
- | F32 -> printf "f_%sf(%s,%s,@,%s,%s,%s)" f (c1 ~p:p2 ()) (c2 ~p:p2 ()) wf2 wf1 p2
- | F12 -> printf "f_f%s(%s,%s,@,%s,%s,%s)" f (c1 ~p:p2 ()) (c2 ~p:p2 ()) wf1 wf2 p2
- | F21 -> printf "f_f%s(%s,%s,@,%s,%s,%s)" f (c1 ~p:p1 ()) (c2 ~p:p1 ()) wf2 wf1 p1
-
- let print_fermion_current_mom_ff coeff f c wf1 wf2 p1 p2 p12 fusion =
- let c = format_coupling coeff c in
- let c1 = fastener c 1 and
- c2 = fastener c 2 in
- match fusion with
- | F13 -> printf "%s_ff(%s,%s,%s,%s)" f (c1 ~p:p1 ~q:p2 ()) (c2 ~p:p1 ~q:p2 ()) wf1 wf2
- | F31 -> printf "%s_ff(%s,%s,%s,%s)" f (c1 ~p:p1 ~q:p2 ()) (c2 ~p:p1 ~q:p2 ()) wf2 wf1
- | F23 -> printf "f_%sf(%s,%s,%s,%s)" f (c1 ~p:p12 ~q:p2 ()) (c2 ~p:p12 ~q:p2 ()) wf1 wf2
- | F32 -> printf "f_%sf(%s,%s,%s,%s)" f (c1 ~p:p12 ~q:p1 ()) (c2 ~p:p12 ~q:p1 ()) wf2 wf1
- | F12 -> printf "f_f%s(%s,%s,%s,%s)" f (c1 ~p:p12 ~q:p1 ()) (c2 ~p:p12 ~q:p1 ()) wf1 wf2
- | F21 -> printf "f_f%s(%s,%s,%s,%s)" f (c1 ~p:p12 ~q:p2 ()) (c2 ~p:p12 ~q:p2 ()) wf2 wf1
-
- let print_current = function
- | coeff, Psibar, VA, Psi -> print_fermion_current2 coeff "va"
- | coeff, Psibar, VA2, Psi -> print_fermion_current coeff "va2"
- | coeff, Psibar, VA3, Psi -> print_fermion_current coeff "va3"
- | coeff, Psibar, V, Psi -> print_fermion_current coeff "v"
- | coeff, Psibar, A, Psi -> print_fermion_current coeff "a"
- | coeff, Psibar, VL, Psi -> print_fermion_current coeff "vl"
- | coeff, Psibar, VR, Psi -> print_fermion_current coeff "vr"
- | coeff, Psibar, VLR, Psi -> print_fermion_current2 coeff "vlr"
- | coeff, Psibar, SP, Psi -> print_fermion_current2 coeff "sp"
- | coeff, Psibar, S, Psi -> print_fermion_current coeff "s"
- | coeff, Psibar, P, Psi -> print_fermion_current coeff "p"
- | coeff, Psibar, SL, Psi -> print_fermion_current coeff "sl"
- | coeff, Psibar, SR, Psi -> print_fermion_current coeff "sr"
- | coeff, Psibar, SLR, Psi -> print_fermion_current2 coeff "slr"
- | _, Psibar, _, Psi -> invalid_arg
- "Targets.Fortran_Fermions: no superpotential here"
- | _, Chibar, _, _ | _, _, _, Chi -> invalid_arg
- "Targets.Fortran_Fermions: Majorana spinors not handled"
- | _, Gravbar, _, _ | _, _, _, Grav -> invalid_arg
- "Targets.Fortran_Fermions: Gravitinos not handled"
-
- let print_current_mom = function
- | coeff, Psibar, VLRM, Psi -> print_fermion_current_mom_v1 coeff "vlr"
- | coeff, Psibar, VAM, Psi -> print_fermion_current_mom_ff coeff "va"
- | coeff, Psibar, VA3M, Psi -> print_fermion_current_mom_ff coeff "va3"
- | coeff, Psibar, SPM, Psi -> print_fermion_current_mom_v1 coeff "sp"
- | coeff, Psibar, TVA, Psi -> print_fermion_current_mom_v1 coeff "tva"
- | coeff, Psibar, TVAM, Psi -> print_fermion_current_mom_v2 coeff "tvam"
- | coeff, Psibar, TLR, Psi -> print_fermion_current_mom_v1 coeff "tlr"
- | coeff, Psibar, TLRM, Psi -> print_fermion_current_mom_v2 coeff "tlrm"
- | coeff, Psibar, TRL, Psi -> print_fermion_current_mom_v1 coeff "trl"
- | coeff, Psibar, TRLM, Psi -> print_fermion_current_mom_v2 coeff "trlm"
- | _, Psibar, _, Psi -> invalid_arg
- "Targets.Fortran_Fermions: only sigma tensor coupling here"
- | _, Chibar, _, _ | _, _, _, Chi -> invalid_arg
- "Targets.Fortran_Fermions: Majorana spinors not handled"
- | _, Gravbar, _, _ | _, _, _, Grav -> invalid_arg
- "Targets.Fortran_Fermions: Gravitinos not handled"
-
- let print_current_p = function
- | _, _, _, _ -> invalid_arg
- "Targets.Fortran_Fermions: No clashing arrows here"
-
- let print_current_b = function
- | _, _, _, _ -> invalid_arg
- "Targets.Fortran_Fermions: No clashing arrows here"
-
- let print_current_g = function
- | _, _, _, _ -> invalid_arg
- "Targets.Fortran_Fermions: No gravitinos here"
-
- let print_current_g4 = function
- | _, _, _, _ -> invalid_arg
- "Targets.Fortran_Fermions: No gravitinos here"
-
- let reverse_braket vintage bra ket =
- match bra with
- | Spinor -> true
- | _ -> false
-
- let use_module = "omega95"
- let require_library =
- ["omega_spinors_2010_01_A"; "omega_spinor_cpls_2010_01_A"]
- end
-
-(* \thocwmodulesubsection{Main Functor} *)
-
-module Make_Fortran (Fermions : Fermions)
- (Fusion_Maker : Fusion.Maker) (P : Momentum.T) (M : Model.T) =
- struct
-
- let require_library =
- Fermions.require_library @
- [ "omega_vectors_2010_01_A"; "omega_polarizations_2010_01_A";
- "omega_couplings_2010_01_A"; "omega_color_2010_01_A";
- "omega_utils_2010_01_A" ]
-
- module CM = Colorize.It(M)
- module F = Fusion_Maker(P)(M)
-
- module CF = Fusion.Multi(Fusion_Maker)(P)(M)
- type amplitudes = CF.amplitudes
-
- open Coupling
- open Format
-
- type output_mode =
- | Single_Function
- | Single_Module of int
- | Single_File of int
- | Multi_File of int
-
- let line_length = ref 80
- let continuation_lines = ref (-1) (* 255 *)
- let kind = ref "default"
- let fortran95 = ref true
- let module_name = ref "omega_amplitude"
- let output_mode = ref (Single_Module 10)
- let use_modules = ref []
- let whizard = ref false
- let amp_triv = ref false
- let parameter_module = ref ""
- let md5sum = ref None
- let no_write = ref false
- let km_write = ref false
- let km_pure = ref false
- let km_2_write = ref false
- let km_2_pure = ref false
- let openmp = ref false
- let pure_unless_openmp = false
-
- let options = Options.create
- [ "90", Arg.Clear fortran95,
- "don't use Fortran95 features that are not in Fortran90";
- "kind", Arg.String (fun s -> kind := s),
- "real and complex kind (default: " ^ !kind ^ ")";
- "width", Arg.Int (fun w -> line_length := w), "maximum line length";
- "continuation", Arg.Int (fun l -> continuation_lines := l),
- "maximum # of continuation lines";
- "module", Arg.String (fun s -> module_name := s), "module name";
- "single_function", Arg.Unit (fun () -> output_mode := Single_Function),
- "compute the matrix element(s) in a monolithic function";
- "split_function", Arg.Int (fun n -> output_mode := Single_Module n),
- "split the matrix element(s) into small functions [default, size = 10]";
- "split_module", Arg.Int (fun n -> output_mode := Single_File n),
- "split the matrix element(s) into small modules";
- "split_file", Arg.Int (fun n -> output_mode := Multi_File n),
- "split the matrix element(s) into small files";
- "use", Arg.String (fun s -> use_modules := s :: !use_modules),
- "use module";
- "parameter_module", Arg.String (fun s -> parameter_module := s),
- "parameter_module";
- "md5sum", Arg.String (fun s -> md5sum := Some s),
- "transfer MD5 checksum";
- "whizard", Arg.Set whizard, "include WHIZARD interface";
- "amp_triv", Arg.Set amp_triv, "only print trivial amplitude";
- "no_write", Arg.Set no_write, "no 'write' statements";
- "kmatrix_write", Arg.Set km_2_write, "write K matrix functions";
- "kmatrix_2_write", Arg.Set km_write, "write K matrix 2 functions";
- "kmatrix_write_pure", Arg.Set km_pure, "write K matrix pure functions";
- "kmatrix_2_write_pure", Arg.Set km_2_pure, "write Kmatrix2pure functions";
- "openmp", Arg.Set openmp, "activate OpenMP support in generated code"]
-
-(* Fortran style line continuation: *)
- let nl = Format_Fortran.newline
-
- let print_list = function
- | [] -> ()
- | a :: rest ->
- print_string a;
- List.iter (fun s -> printf ",@ %s" s) rest
-
-(* \thocwmodulesubsection{Variables and Declarations} *)
-
- (* ["NC"] is already used up in the module ["constants"]: *)
- let nc_parameter = "N_"
- let omega_color_factor_abbrev = "OCF"
- let openmp_tld_type = "thread_local_data"
- let openmp_tld = "tld"
-
- let flavors_symbol ?(decl = false) flavors =
- (if !openmp && not decl then openmp_tld ^ "%" else "" ) ^
- "oks_" ^ String.concat "" (List.map CM.flavor_symbol flavors)
-
- let p2s p =
- if p >= 0 && p <= 9 then
- string_of_int p
- else if p <= 36 then
- String.make 1 (Char.chr (Char.code 'A' + p - 10))
- else
- "_"
-
- let format_momentum p =
- "p" ^ String.concat "" (List.map p2s p)
-
- let format_p wf =
- String.concat "" (List.map p2s (F.momentum_list wf))
-
- let ext_momentum wf =
- match F.momentum_list wf with
- | [n] -> n
- | _ -> invalid_arg "Targets.Fortran.ext_momentum"
-
- module PSet = Set.Make (struct type t = int list let compare = compare end)
- module WFSet = Set.Make (struct type t = F.wf let compare = compare end)
-
- let add_tag wf name =
- match F.wf_tag wf with
- | None -> name
- | Some tag -> name ^ "_" ^ tag
-
- let variable ?(decl = false) wf =
- (if !openmp && not decl then openmp_tld ^ "%" else "")
- ^ add_tag wf ("owf_" ^ CM.flavor_symbol (F.flavor wf) ^ "_" ^ format_p wf)
-
- let momentum wf = "p" ^ format_p wf
- let spin wf = "s(" ^ string_of_int (ext_momentum wf) ^ ")"
-
- let format_multiple_variable ?(decl = false) wf i =
- variable ~decl wf ^ "_X" ^ string_of_int i
-
- let multiple_variable ?(decl = false) amplitude dictionary wf =
- try
- format_multiple_variable ~decl wf (dictionary amplitude wf)
- with
- | Not_found -> variable wf
-
- let multiple_variables ?(decl = false) multiplicity wf =
- try
- List.map
- (format_multiple_variable ~decl wf)
- (ThoList.range 1 (multiplicity wf))
- with
- | Not_found -> [variable ~decl wf]
-
- let declaration_chunk_size = 64
-
- let declare_list_chunk multiplicity t = function
- | [] -> ()
- | wfs ->
- printf " @[<2>%s :: " t;
- print_list (ThoList.flatmap (multiple_variables ~decl:true multiplicity) wfs); nl ()
-
- let declare_list multiplicity t = function
- | [] -> ()
- | wfs ->
- List.iter
- (declare_list_chunk multiplicity t)
- (ThoList.chopn declaration_chunk_size wfs)
-
- type declarations =
- { scalars : F.wf list;
- spinors : F.wf list;
- conjspinors : F.wf list;
- realspinors : F.wf list;
- ghostspinors : F.wf list;
- vectorspinors : F.wf list;
- vectors : F.wf list;
- ward_vectors : F.wf list;
- massive_vectors : F.wf list;
- tensors_1 : F.wf list;
- tensors_2 : F.wf list;
- brs_scalars : F.wf list;
- brs_spinors : F.wf list;
- brs_conjspinors : F.wf list;
- brs_realspinors : F.wf list;
- brs_vectorspinors : F.wf list;
- brs_vectors : F.wf list;
- brs_massive_vectors : F.wf list }
-
- let rec classify_wfs' acc = function
- | [] -> acc
- | wf :: rest ->
- classify_wfs'
- (match CM.lorentz (F.flavor wf) with
- | Scalar -> {acc with scalars = wf :: acc.scalars}
- | Spinor -> {acc with spinors = wf :: acc.spinors}
- | ConjSpinor -> {acc with conjspinors = wf :: acc.conjspinors}
- | Majorana -> {acc with realspinors = wf :: acc.realspinors}
- | Maj_Ghost -> {acc with ghostspinors = wf :: acc.ghostspinors}
- | Vectorspinor ->
- {acc with vectorspinors = wf :: acc.vectorspinors}
- | Vector -> {acc with vectors = wf :: acc.vectors}
-(*i | Ward_Vector -> {acc with ward_vectors = wf :: acc.ward_vectors}
-i*)
- | Massive_Vector ->
- {acc with massive_vectors = wf :: acc.massive_vectors}
- | Tensor_1 -> {acc with tensors_1 = wf :: acc.tensors_1}
- | Tensor_2 -> {acc with tensors_2 = wf :: acc.tensors_2}
- | BRS Scalar -> {acc with brs_scalars = wf :: acc.brs_scalars}
- | BRS Spinor -> {acc with brs_spinors = wf :: acc.brs_spinors}
- | BRS ConjSpinor -> {acc with brs_conjspinors =
- wf :: acc.brs_conjspinors}
- | BRS Majorana -> {acc with brs_realspinors =
- wf :: acc.brs_realspinors}
- | BRS Vectorspinor -> {acc with brs_vectorspinors =
- wf :: acc.brs_vectorspinors}
- | BRS Vector -> {acc with brs_vectors = wf :: acc.brs_vectors}
- | BRS Massive_Vector -> {acc with brs_massive_vectors =
- wf :: acc.brs_massive_vectors}
- | BRS _ -> invalid_arg "Targets.wfs_classify': not needed here")
- rest
-
- let classify_wfs wfs = classify_wfs'
- { scalars = []; spinors = []; conjspinors = []; realspinors = [];
- ghostspinors = []; vectorspinors = []; vectors = [];
- ward_vectors = [];
- massive_vectors = []; tensors_1 = []; tensors_2 = [];
- brs_scalars = [] ; brs_spinors = []; brs_conjspinors = [];
- brs_realspinors = []; brs_vectorspinors = [];
- brs_vectors = []; brs_massive_vectors = []}
- wfs
-
-(* \thocwmodulesubsection{Parameters} *)
-
- type 'a parameters =
- { real_singles : 'a list;
- real_arrays : ('a * int) list;
- complex_singles : 'a list;
- complex_arrays : ('a * int) list }
-
- let rec classify_singles acc = function
- | [] -> acc
- | Real p :: rest -> classify_singles
- { acc with real_singles = p :: acc.real_singles } rest
- | Complex p :: rest -> classify_singles
- { acc with complex_singles = p :: acc.complex_singles } rest
-
- let rec classify_arrays acc = function
- | [] -> acc
- | (Real_Array p, rhs) :: rest -> classify_arrays
- { acc with real_arrays =
- (p, List.length rhs) :: acc.real_arrays } rest
- | (Complex_Array p, rhs) :: rest -> classify_arrays
- { acc with complex_arrays =
- (p, List.length rhs) :: acc.complex_arrays } rest
-
- let classify_parameters params =
- classify_arrays
- (classify_singles
- { real_singles = [];
- real_arrays = [];
- complex_singles = [];
- complex_arrays = [] }
- (List.map fst params.derived)) params.derived_arrays
-
- let schisma = ThoList.chopn
-
- let schisma_num i n l =
- ThoList.enumerate i (schisma n l)
-
- let declare_parameters' t = function
- | [] -> ()
- | plist ->
- printf " @[<2>%s(kind=%s), public, save :: " t !kind;
- print_list (List.map CM.constant_symbol plist); nl ()
-
- let declare_parameters t plist =
- List.iter (declare_parameters' t) plist
-
- let declare_parameter_array t (p, n) =
- printf " @[<2>%s(kind=%s), dimension(%d), public, save :: %s"
- t !kind n (CM.constant_symbol p); nl ()
-
- (* NB: we use [string_of_float] to make sure that a decimal
- point is included to make Fortran compilers happy. *)
- let default_parameter (x, v) =
- printf "@ %s = %s_%s" (CM.constant_symbol x) (string_of_float v) !kind
-
- let declare_default_parameters t = function
- | [] -> ()
- | p :: plist ->
- printf " @[<2>%s(kind=%s), public, save ::" t !kind;
- default_parameter p;
- List.iter (fun p' -> printf ","; default_parameter p') plist;
- nl ()
-
- let format_constant = function
- | I -> "(0,1)"
- | Integer c ->
- if c < 0 then
- sprintf "(%d.0_%s)" c !kind
- else
- sprintf "%d.0_%s" c !kind
- | Float x ->
- if x < 0. then
- "(" ^ string_of_float x ^ "_" ^ !kind ^ ")"
- else
- string_of_float x ^ "_" ^ !kind
- | _ -> invalid_arg "format_constant"
-
- let rec eval_parameter' = function
- | (I | Integer _ | Float _) as c ->
- printf "%s" (format_constant c)
- | Atom x -> printf "%s" (CM.constant_symbol x)
- | Sum [] -> printf "0.0_%s" !kind
- | Sum [x] -> eval_parameter' x
- | Sum (x :: xs) ->
- printf "@,("; eval_parameter' x;
- List.iter (fun x -> printf "@, + "; eval_parameter' x) xs;
- printf ")"
- | Diff (x, y) ->
- printf "@,("; eval_parameter' x;
- printf " - "; eval_parameter' y; printf ")"
- | Neg x -> printf "@,( - "; eval_parameter' x; printf ")"
- | Prod [] -> printf "1.0_%s" !kind
- | Prod [x] -> eval_parameter' x
- | Prod (x :: xs) ->
- printf "@,("; eval_parameter' x;
- List.iter (fun x -> printf " * "; eval_parameter' x) xs;
- printf ")"
- | Quot (x, y) ->
- printf "@,("; eval_parameter' x;
- printf " / "; eval_parameter' y; printf ")"
- | Rec x ->
- printf "@, (1.0_%s / " !kind; eval_parameter' x; printf ")"
- | Pow (x, n) ->
- printf "@,("; eval_parameter' x;
- if n < 0 then
- printf "**(%d)" n
- else
- printf "**%d" n;
- printf ")"
- | PowX (x, y) ->
- printf "@,("; eval_parameter' x;
- printf "**"; eval_parameter' y; printf ")"
- | Sqrt x -> printf "@,sqrt ("; eval_parameter' x; printf ")"
- | Sin x -> printf "@,sin ("; eval_parameter' x; printf ")"
- | Cos x -> printf "@,cos ("; eval_parameter' x; printf ")"
- | Tan x -> printf "@,tan ("; eval_parameter' x; printf ")"
- | Cot x -> printf "@,cot ("; eval_parameter' x; printf ")"
- | Asin x -> printf "@,asin ("; eval_parameter' x; printf ")"
- | Acos x -> printf "@,acos ("; eval_parameter' x; printf ")"
- | Atan x -> printf "@,atan ("; eval_parameter' x; printf ")"
- | Atan2 (y, x) -> printf "@,atan2 ("; eval_parameter' y;
- printf ",@ "; eval_parameter' x; printf ")"
- | Sinh x -> printf "@,sinh ("; eval_parameter' x; printf ")"
- | Cosh x -> printf "@,cosh ("; eval_parameter' x; printf ")"
- | Tanh x -> printf "@,tanh ("; eval_parameter' x; printf ")"
- | Exp x -> printf "@,exp ("; eval_parameter' x; printf ")"
- | Log x -> printf "@,log ("; eval_parameter' x; printf ")"
- | Log10 x -> printf "@,log10 ("; eval_parameter' x; printf ")"
- | Conj (Integer _ | Float _ as x) -> eval_parameter' x
- | Conj x -> printf "@,cconjg ("; eval_parameter' x; printf ")"
- | Abs x -> printf "@,abs ("; eval_parameter' x; printf ")"
-
- let strip_single_tag = function
- | Real x -> x
- | Complex x -> x
-
- let strip_array_tag = function
- | Real_Array x -> x
- | Complex_Array x -> x
-
- let eval_parameter (lhs, rhs) =
- let x = CM.constant_symbol (strip_single_tag lhs) in
- printf " @[<2>%s = " x; eval_parameter' rhs; nl ()
-
- let eval_para_list n l =
- printf " subroutine setup_parameters_%03d ()" n; nl ();
- List.iter eval_parameter l;
- printf " end subroutine setup_parameters_%03d" n; nl ()
-
- let eval_parameter_pair (lhs, rhs) =
- let x = CM.constant_symbol (strip_array_tag lhs) in
- let _ = List.fold_left (fun i rhs' ->
- printf " @[<2>%s(%d) = " x i; eval_parameter' rhs'; nl ();
- succ i) 1 rhs in
- ()
-
- let eval_para_pair_list n l =
- printf " subroutine setup_parameters_%03d ()" n; nl ();
- List.iter eval_parameter_pair l;
- printf " end subroutine setup_parameters_%03d" n; nl ()
-
- let print_echo fmt p =
- let s = CM.constant_symbol p in
- printf " write (unit = *, fmt = fmt_%s) \"%s\", %s"
- fmt s s; nl ()
-
- let print_echo_array fmt (p, n) =
- let s = CM.constant_symbol p in
- for i = 1 to n do
- printf " write (unit = *, fmt = fmt_%s_array) " fmt ;
- printf "\"%s\", %d, %s(%d)" s i s i; nl ()
- done
-
- let contains params couplings =
- List.exists
- (fun (name, _) -> List.mem (CM.constant_symbol name) params)
- couplings.input
-
- let rec depends_on params = function
- | I | Integer _ | Float _ -> false
- | Atom name -> List.mem (CM.constant_symbol name) params
- | Sum es | Prod es ->
- List.exists (depends_on params) es
- | Diff (e1, e2) | Quot (e1, e2) | PowX (e1, e2) ->
- depends_on params e1 || depends_on params e2
- | Neg e | Rec e | Pow (e, _) ->
- depends_on params e
- | Sqrt e | Exp e | Log e | Log10 e
- | Sin e | Cos e | Tan e | Cot e
- | Asin e | Acos e | Atan e
- | Sinh e | Cosh e | Tanh e
- | Conj e | Abs e ->
- depends_on params e
- | Atan2 (e1, e2) ->
- depends_on params e1 || depends_on params e2
-
- let dependencies params couplings =
- if contains params couplings then
- List.rev
- (fst (List.fold_left
- (fun (deps, plist) (param, v) ->
- match param with
- | Real name | Complex name ->
- if depends_on plist v then
- ((param, v) :: deps, CM.constant_symbol name :: plist)
- else
- (deps, plist))
- ([], params) couplings.derived))
- else
- []
-
- let dependencies_arrays params couplings =
- if contains params couplings then
- List.rev
- (fst (List.fold_left
- (fun (deps, plist) (param, vlist) ->
- match param with
- | Real_Array name | Complex_Array name ->
- if List.exists (depends_on plist) vlist then
- ((param, vlist) :: deps,
- CM.constant_symbol name :: plist)
- else
- (deps, plist))
- ([], params) couplings.derived_arrays))
- else
- []
-
- let parameters_to_fortran oc params =
- Format_Fortran.set_formatter_out_channel ~width:!line_length oc;
- let declarations = classify_parameters params in
- printf "module %s" !parameter_module; nl ();
- printf " use kinds"; nl ();
- printf " use constants"; nl ();
- printf " implicit none"; nl ();
- printf " private"; nl ();
- printf " @[<2>public :: setup_parameters";
- printf ",@ import_from_whizard";
- printf ",@ model_update_alpha_s";
- if !no_write then begin
- printf "! No print_parameters";
- end else begin
- printf ",@ print_parameters";
- end; nl ();
- declare_default_parameters "real" params.input;
- declare_parameters "real" (schisma 69 declarations.real_singles);
- List.iter (declare_parameter_array "real") declarations.real_arrays;
- declare_parameters "complex" (schisma 69 declarations.complex_singles);
- List.iter (declare_parameter_array "complex") declarations.complex_arrays;
- printf " interface cconjg"; nl ();
- printf " module procedure cconjg_real, cconjg_complex"; nl ();
- printf " end interface"; nl ();
- printf " private :: cconjg_real, cconjg_complex"; nl ();
- printf "contains"; nl ();
- printf " function cconjg_real (x) result (xc)"; nl ();
- printf " real(kind=default), intent(in) :: x"; nl ();
- printf " real(kind=default) :: xc"; nl ();
- printf " xc = x"; nl ();
- printf " end function cconjg_real"; nl ();
- printf " function cconjg_complex (z) result (zc)"; nl ();
- printf " complex(kind=default), intent(in) :: z"; nl ();
- printf " complex(kind=default) :: zc"; nl ();
- printf " zc = conjg (z)"; nl ();
- printf " end function cconjg_complex"; nl ();
- printf " ! derived parameters:"; nl ();
- let shredded = schisma_num 1 120 params.derived in
- let shredded_arrays = schisma_num 1 120 params.derived_arrays in
- let num_sub = List.length shredded in
- let num_sub_arrays = List.length shredded_arrays in
- List.iter (fun (i,l) -> eval_para_list i l) shredded;
- List.iter (fun (i,l) -> eval_para_pair_list (num_sub + i) l)
- shredded_arrays;
- printf " subroutine setup_parameters ()"; nl ();
- for i = 1 to num_sub + num_sub_arrays do
- printf " call setup_parameters_%03d ()" i; nl ();
- done;
- printf " end subroutine setup_parameters"; nl ();
- printf " subroutine import_from_whizard (par_array, scheme)"; nl ();
- printf
- " real(%s), dimension(%d), intent(in) :: par_array"
- !kind (List.length params.input); nl ();
- printf " integer, intent(in) :: scheme"; nl ();
- let i = ref 1 in
- List.iter
- (fun (p, _) ->
- printf " %s = par_array(%d)" (CM.constant_symbol p) !i; nl ();
- incr i)
- params.input;
- printf " call setup_parameters ()"; nl ();
- printf " end subroutine import_from_whizard"; nl ();
- printf " subroutine model_update_alpha_s (alpha_s)"; nl ();
- printf " real(%s), intent(in) :: alpha_s" !kind; nl ();
- begin match (dependencies ["aS"] params,
- dependencies_arrays ["aS"] params) with
- | [], [] ->
- printf " ! 'aS' not among the input parameters"; nl ();
- | deps, deps_arrays ->
- printf " aS = alpha_s"; nl ();
- List.iter eval_parameter deps;
- List.iter eval_parameter_pair deps_arrays
- end;
- printf " end subroutine model_update_alpha_s"; nl ();
- if !no_write then begin
- printf "! No print_parameters"; nl ();
- end else begin
- printf " subroutine print_parameters ()"; nl ();
- printf " @[<2>character(len=*), parameter ::";
- printf "@ fmt_real = \"(A12,4X,' = ',E25.18)\",";
- printf "@ fmt_complex = \"(A12,4X,' = ',E25.18,' + i*',E25.18)\",";
- printf "@ fmt_real_array = \"(A12,'(',I2.2,')',' = ',E25.18)\",";
- printf "@ fmt_complex_array = ";
- printf "\"(A12,'(',I2.2,')',' = ',E25.18,' + i*',E25.18)\""; nl ();
- printf " @[<2>write (unit = *, fmt = \"(A)\") @,";
- printf "\"default values for the input parameters:\""; nl ();
- List.iter (fun (p, _) -> print_echo "real" p) params.input;
- printf " @[<2>write (unit = *, fmt = \"(A)\") @,";
- printf "\"derived parameters:\""; nl ();
- List.iter (print_echo "real") declarations.real_singles;
- List.iter (print_echo "complex") declarations.complex_singles;
- List.iter (print_echo_array "real") declarations.real_arrays;
- List.iter (print_echo_array "complex") declarations.complex_arrays;
- printf " end subroutine print_parameters"; nl ();
- end;
- printf "end module %s" !parameter_module; nl ()
-
-(* \thocwmodulesubsection{Run-Time Diagnostics} *)
-
- type diagnostic = All | Arguments | Momenta | Gauge
-
- type diagnostic_mode = Off | Warn | Panic
-
- let warn mode =
- match !mode with
- | Off -> false
- | Warn -> true
- | Panic -> true
-
- let panic mode =
- match !mode with
- | Off -> false
- | Warn -> false
- | Panic -> true
-
- let suffix mode =
- if panic mode then
- "panic"
- else
- "warn"
-
- let diagnose_arguments = ref Off
- let diagnose_momenta = ref Off
- let diagnose_gauge = ref Off
-
- let rec parse_diagnostic = function
- | All, panic ->
- parse_diagnostic (Arguments, panic);
- parse_diagnostic (Momenta, panic);
- parse_diagnostic (Gauge, panic)
- | Arguments, panic ->
- diagnose_arguments := if panic then Panic else Warn
- | Momenta, panic ->
- diagnose_momenta := if panic then Panic else Warn
- | Gauge, panic ->
- diagnose_gauge := if panic then Panic else Warn
-
-(* If diagnostics are required, we have to switch off
- Fortran95 features like pure functions. *)
-
- let parse_diagnostics = function
- | [] -> ()
- | diagnostics ->
- fortran95 := false;
- List.iter parse_diagnostic diagnostics
-
-(* \thocwmodulesubsection{Amplitude} *)
-
- let declare_momenta_chunk = function
- | [] -> ()
- | momenta ->
- printf " @[<2>type(momentum) :: ";
- print_list (List.map format_momentum momenta); nl ()
-
- let declare_momenta = function
- | [] -> ()
- | momenta ->
- List.iter
- declare_momenta_chunk
- (ThoList.chopn declaration_chunk_size momenta)
-
- let declare_wavefunctions multiplicity wfs =
- let wfs' = classify_wfs wfs in
- declare_list multiplicity ("complex(kind=" ^ !kind ^ ")")
- (wfs'.scalars @ wfs'.brs_scalars);
- declare_list multiplicity ("type(" ^ Fermions.psi_type ^ ")")
- (wfs'.spinors @ wfs'.brs_spinors);
- declare_list multiplicity ("type(" ^ Fermions.psibar_type ^ ")")
- (wfs'.conjspinors @ wfs'.brs_conjspinors);
- declare_list multiplicity ("type(" ^ Fermions.chi_type ^ ")")
- (wfs'.realspinors @ wfs'.brs_realspinors @ wfs'.ghostspinors);
- declare_list multiplicity ("type(" ^ Fermions.grav_type ^ ")") wfs'.vectorspinors;
- declare_list multiplicity "type(vector)" (wfs'.vectors @ wfs'.massive_vectors @
- wfs'.brs_vectors @ wfs'.brs_massive_vectors @ wfs'.ward_vectors);
- declare_list multiplicity "type(tensor2odd)" wfs'.tensors_1;
- declare_list multiplicity "type(tensor)" wfs'.tensors_2
-
- let flavors a = F.incoming a @ F.outgoing a
-
- let declare_brakets_chunk = function
- | [] -> ()
- | amplitudes ->
- printf " @[<2>complex(kind=%s) :: " !kind;
- print_list (List.map (fun a -> flavors_symbol ~decl:true (flavors a)) amplitudes); nl ()
-
- let declare_brakets = function
- | [] -> ()
- | amplitudes ->
- List.iter
- declare_brakets_chunk
- (ThoList.chopn declaration_chunk_size amplitudes)
-
- let print_variable_declarations amplitudes =
- let multiplicity = CF.multiplicity amplitudes
- and processes = CF.processes amplitudes in
- if not !amp_triv then begin
- declare_momenta
- (PSet.elements
- (List.fold_left
- (fun set a ->
- PSet.union set (List.fold_right
- (fun wf -> PSet.add (F.momentum_list wf))
- (F.externals a) PSet.empty))
- PSet.empty processes));
- declare_momenta
- (PSet.elements
- (List.fold_left
- (fun set a ->
- PSet.union set (List.fold_right
- (fun wf -> PSet.add (F.momentum_list wf))
- (F.variables a) PSet.empty))
- PSet.empty processes));
- if !openmp then begin
- printf " type %s@[<2>" openmp_tld_type;
- nl ();
- end ;
- declare_wavefunctions multiplicity
- (WFSet.elements
- (List.fold_left
- (fun set a ->
- WFSet.union set (List.fold_right WFSet.add (F.externals a) WFSet.empty))
- WFSet.empty processes));
- declare_wavefunctions multiplicity
- (WFSet.elements
- (List.fold_left
- (fun set a ->
- WFSet.union set (List.fold_right WFSet.add (F.variables a) WFSet.empty))
- WFSet.empty processes));
- declare_brakets processes;
- if !openmp then begin
- printf "@] end type %s\n" openmp_tld_type;
- printf " type(%s) :: %s" openmp_tld_type openmp_tld;
- nl ();
- end;
- end
-
-(* [print_current] is the most important function that has to match the functions
- in \verb+omega95+ (see appendix~\ref{sec:fortran}). It offers plentiful
- opportunities for making mistakes, in particular those related to signs.
- We start with a few auxiliary functions: *)
-
- let children2 rhs =
- match F.children rhs with
- | [wf1; wf2] -> (wf1, wf2)
- | _ -> failwith "Targets.children2: can't happen"
-
- let children3 rhs =
- match F.children rhs with
- | [wf1; wf2; wf3] -> (wf1, wf2, wf3)
- | _ -> invalid_arg "Targets.children3: can't happen"
-
-(* Note that it is (marginally) faster to multiply the two scalar products
- with the coupling constant than the four vector components.
- \begin{dubious}
- This could be part of \verb+omegalib+ as well \ldots
- \end{dubious} *)
-
- let format_coeff = function
- | 1 -> ""
- | -1 -> "-"
- | coeff -> "(" ^ string_of_int coeff ^ ")*"
-
- let format_coupling coeff c =
- match coeff with
- | 1 -> c
- | -1 -> "(-" ^ c ^")"
- | coeff -> string_of_int coeff ^ "*" ^ c
-
-(* \begin{dubious}
- The following is error prone and should be generated automagically.
- \end{dubious} *)
-
- let print_vector4 c wf1 wf2 wf3 fusion (coeff, contraction) =
- match contraction, fusion with
- | C_12_34, (F341|F431|F342|F432|F123|F213|F124|F214)
- | C_13_42, (F241|F421|F243|F423|F132|F312|F134|F314)
- | C_14_23, (F231|F321|F234|F324|F142|F412|F143|F413) ->
- printf "((%s%s)*(%s*%s))*%s" (format_coeff coeff) c wf1 wf2 wf3
- | C_12_34, (F134|F143|F234|F243|F312|F321|F412|F421)
- | C_13_42, (F124|F142|F324|F342|F213|F231|F413|F431)
- | C_14_23, (F123|F132|F423|F432|F214|F241|F314|F341) ->
- printf "((%s%s)*(%s*%s))*%s" (format_coeff coeff) c wf2 wf3 wf1
- | C_12_34, (F314|F413|F324|F423|F132|F231|F142|F241)
- | C_13_42, (F214|F412|F234|F432|F123|F321|F143|F341)
- | C_14_23, (F213|F312|F243|F342|F124|F421|F134|F431) ->
- printf "((%s%s)*(%s*%s))*%s" (format_coeff coeff) c wf1 wf3 wf2
-
- let print_vector4_t_0 c wf1 p1 wf2 p2 wf3 p3 fusion (coeff, contraction) =
- match contraction, fusion with
- | C_12_34, (F234|F243|F134|F143|F421|F321|F412|F312)
- | C_13_42, (F324|F342|F124|F142|F431|F231|F413|F213)
- | C_14_23, (F423|F432|F123|F132|F341|F241|F314|F214) ->
- printf "g_dim8g3_t_0(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
- | C_12_34, (F324|F314|F423|F413|F142|F132|F241|F231)
- | C_13_42, (F234|F214|F432|F412|F143|F123|F341|F321)
- | C_14_23, (F243|F213|F342|F312|F134|F124|F431|F421) ->
- printf "g_dim8g3_t_0(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
- | C_12_34, (F342|F341|F432|F431|F124|F123|F214|F213)
- | C_13_42, (F243|F241|F423|F421|F134|F132|F314|F312)
- | C_14_23, (F234|F231|F324|F321|F143|F142|F413|F412) ->
- printf "g_dim8g3_t_0(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
-
- let print_vector4_t_1 c wf1 p1 wf2 p2 wf3 p3 fusion (coeff, contraction) =
- match contraction, fusion with
- | C_12_34, (F234|F243|F134|F143|F421|F321|F412|F312)
- | C_13_42, (F324|F342|F124|F142|F431|F231|F413|F213)
- | C_14_23, (F423|F432|F123|F132|F341|F241|F314|F214) ->
- printf "g_dim8g3_t_1(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
- | C_12_34, (F324|F314|F423|F413|F142|F132|F241|F231)
- | C_13_42, (F234|F214|F432|F412|F143|F123|F341|F321)
- | C_14_23, (F243|F213|F342|F312|F134|F124|F431|F421) ->
- printf "g_dim8g3_t_1(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
- | C_12_34, (F342|F341|F432|F431|F124|F123|F214|F213)
- | C_13_42, (F243|F241|F423|F421|F134|F132|F314|F312)
- | C_14_23, (F234|F231|F324|F321|F143|F142|F413|F412) ->
- printf "g_dim8g3_t_1(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
-
- let print_vector4_t_2 c wf1 p1 wf2 p2 wf3 p3 fusion (coeff, contraction) =
- match contraction, fusion with
- | C_12_34, (F234|F243|F134|F143|F421|F321|F412|F312)
- | C_13_42, (F324|F342|F124|F142|F431|F231|F413|F213)
- | C_14_23, (F423|F432|F123|F132|F341|F241|F314|F214) ->
- printf "g_dim8g3_t_2(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
- | C_12_34, (F324|F314|F423|F413|F142|F132|F241|F231)
- | C_13_42, (F234|F214|F432|F412|F143|F123|F341|F321)
- | C_14_23, (F243|F213|F342|F312|F134|F124|F431|F421) ->
- printf "g_dim8g3_t_2(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
- | C_12_34, (F342|F341|F432|F431|F124|F123|F214|F213)
- | C_13_42, (F243|F241|F423|F421|F134|F132|F314|F312)
- | C_14_23, (F234|F231|F324|F321|F143|F142|F413|F412) ->
- printf "g_dim8g3_t_2(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
-
- let print_vector4_m_0 c wf1 p1 wf2 p2 wf3 p3 fusion (coeff, contraction) =
- match contraction, fusion with
- | C_12_34, (F234|F243|F134|F143|F421|F321|F412|F312)
- | C_13_42, (F324|F342|F124|F142|F431|F231|F413|F213)
- | C_14_23, (F423|F432|F123|F132|F341|F241|F314|F214) ->
- printf "g_dim8g3_m_0(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
- | C_12_34, (F324|F314|F423|F413|F142|F132|F241|F231)
- | C_13_42, (F234|F214|F432|F412|F143|F123|F341|F321)
- | C_14_23, (F243|F213|F342|F312|F134|F124|F431|F421) ->
- printf "g_dim8g3_m_0(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
- | C_12_34, (F342|F341|F432|F431|F124|F123|F214|F213)
- | C_13_42, (F243|F241|F423|F421|F134|F132|F314|F312)
- | C_14_23, (F234|F231|F324|F321|F143|F142|F413|F412) ->
- printf "g_dim8g3_m_0(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
-
- let print_vector4_m_1 c wf1 p1 wf2 p2 wf3 p3 fusion (coeff, contraction) =
- match contraction, fusion with
- | C_12_34, (F234|F243|F134|F143|F421|F321|F412|F312)
- | C_13_42, (F324|F342|F124|F142|F431|F231|F413|F213)
- | C_14_23, (F423|F432|F123|F132|F341|F241|F314|F214) ->
- printf "g_dim8g3_m_1(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
- | C_12_34, (F324|F314|F423|F413|F142|F132|F241|F231)
- | C_13_42, (F234|F214|F432|F412|F143|F123|F341|F321)
- | C_14_23, (F243|F213|F342|F312|F134|F124|F431|F421) ->
- printf "g_dim8g3_m_1(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
- | C_12_34, (F342|F341|F432|F431|F124|F123|F214|F213)
- | C_13_42, (F243|F241|F423|F421|F134|F132|F314|F312)
- | C_14_23, (F234|F231|F324|F321|F143|F142|F413|F412) ->
- printf "g_dim8g3_m_1(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
-
- let print_vector4_m_7 c wf1 p1 wf2 p2 wf3 p3 fusion (coeff, contraction) =
- match contraction, fusion with
- | C_12_34, (F234|F243|F134|F143|F421|F321|F412|F312)
- | C_13_42, (F324|F342|F124|F142|F431|F231|F413|F213)
- | C_14_23, (F423|F432|F123|F132|F341|F241|F314|F214) ->
- printf "g_dim8g3_m_7(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
- | C_12_34, (F324|F314|F423|F413|F142|F132|F241|F231)
- | C_13_42, (F234|F214|F432|F412|F143|F123|F341|F321)
- | C_14_23, (F243|F213|F342|F312|F134|F124|F431|F421) ->
- printf "g_dim8g3_m_7(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
- | C_12_34, (F342|F341|F432|F431|F124|F123|F214|F213)
- | C_13_42, (F243|F241|F423|F421|F134|F132|F314|F312)
- | C_14_23, (F234|F231|F324|F321|F143|F142|F413|F412) ->
- printf "g_dim8g3_m_7(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
-
- let print_add_vector4 c wf1 wf2 wf3 fusion (coeff, contraction) =
- printf "@ + ";
- print_vector4 c wf1 wf2 wf3 fusion (coeff, contraction)
-
- let print_vector4_km c pa pb wf1 wf2 wf3 fusion (coeff, contraction) =
- match contraction, fusion with
- | C_12_34, (F341|F431|F342|F432|F123|F213|F124|F214)
- | C_13_42, (F241|F421|F243|F423|F132|F312|F134|F314)
- | C_14_23, (F231|F321|F234|F324|F142|F412|F143|F413) ->
- printf "((%s%s%s+%s))*(%s*%s))*%s"
- (format_coeff coeff) c pa pb wf1 wf2 wf3
- | C_12_34, (F134|F143|F234|F243|F312|F321|F412|F421)
- | C_13_42, (F124|F142|F324|F342|F213|F231|F413|F431)
- | C_14_23, (F123|F132|F423|F432|F214|F241|F314|F341) ->
- printf "((%s%s%s+%s))*(%s*%s))*%s"
- (format_coeff coeff) c pa pb wf2 wf3 wf1
- | C_12_34, (F314|F413|F324|F423|F132|F231|F142|F241)
- | C_13_42, (F214|F412|F234|F432|F123|F321|F143|F341)
- | C_14_23, (F213|F312|F243|F342|F124|F421|F134|F431) ->
- printf "((%s%s%s+%s))*(%s*%s))*%s"
- (format_coeff coeff) c pa pb wf1 wf3 wf2
-
- let print_vector4_km_t_0 c pa pb wf1 p1 wf2 p2 wf3 p3 fusion (coeff, contraction) =
- match contraction, fusion with
- | C_12_34, (F234|F243|F134|F143|F421|F321|F412|F312)
- | C_13_42, (F324|F342|F124|F142|F431|F231|F413|F213)
- | C_14_23, (F423|F432|F123|F132|F341|F241|F314|F214) ->
- printf "@[(%s%s%s+%s)*g_dim8g3_t_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf1 p1 wf2 p2 wf3 p3
- | C_12_34, (F324|F314|F423|F413|F142|F132|F241|F231)
- | C_13_42, (F234|F214|F432|F412|F143|F123|F341|F321)
- | C_14_23, (F243|F213|F342|F312|F134|F124|F431|F421) ->
- printf "@[(%s%s%s+%s)*g_dim8g3_t_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf2 p2 wf1 p1 wf3 p3
- | C_12_34, (F342|F341|F432|F431|F124|F123|F214|F213)
- | C_13_42, (F243|F241|F423|F421|F134|F132|F314|F312)
- | C_14_23, (F234|F231|F324|F321|F143|F142|F413|F412) ->
- printf "@[(%s%s%s+%s)*g_dim8g3_t_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf3 p3 wf1 p1 wf2 p2
-
- let print_vector4_km_t_1 c pa pb wf1 p1 wf2 p2 wf3 p3 fusion (coeff, contraction) =
- match contraction, fusion with
- | C_12_34, (F234|F243|F134|F143|F421|F321|F412|F312)
- | C_13_42, (F324|F342|F124|F142|F431|F231|F413|F213)
- | C_14_23, (F423|F432|F123|F132|F341|F241|F314|F214) ->
- printf "@[(%s%s%s+%s)*g_dim8g3_t_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf1 p1 wf2 p2 wf3 p3
- | C_12_34, (F324|F314|F423|F413|F142|F132|F241|F231)
- | C_13_42, (F234|F214|F432|F412|F143|F123|F341|F321)
- | C_14_23, (F243|F213|F342|F312|F134|F124|F431|F421) ->
- printf "@[(%s%s%s+%s)*g_dim8g3_t_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf2 p2 wf1 p1 wf3 p3
- | C_12_34, (F342|F341|F432|F431|F124|F123|F214|F213)
- | C_13_42, (F243|F241|F423|F421|F134|F132|F314|F312)
- | C_14_23, (F234|F231|F324|F321|F143|F142|F413|F412) ->
- printf "@[(%s%s%s+%s)*g_dim8g3_t_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf3 p3 wf1 p1 wf2 p2
-
- let print_vector4_km_t_2 c pa pb wf1 p1 wf2 p2 wf3 p3 fusion (coeff, contraction) =
- match contraction, fusion with
- | C_12_34, (F234|F243|F134|F143|F421|F321|F412|F312)
- | C_13_42, (F324|F342|F124|F142|F431|F231|F413|F213)
- | C_14_23, (F423|F432|F123|F132|F341|F241|F314|F214) ->
- printf "@[(%s%s%s+%s)*g_dim8g3_t_2(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf1 p1 wf2 p2 wf3 p3
- | C_12_34, (F324|F314|F423|F413|F142|F132|F241|F231)
- | C_13_42, (F234|F214|F432|F412|F143|F123|F341|F321)
- | C_14_23, (F243|F213|F342|F312|F134|F124|F431|F421) ->
- printf "@[(%s%s%s+%s)*g_dim8g3_t_2(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf2 p2 wf1 p1 wf3 p3
- | C_12_34, (F342|F341|F432|F431|F124|F123|F214|F213)
- | C_13_42, (F243|F241|F423|F421|F134|F132|F314|F312)
- | C_14_23, (F234|F231|F324|F321|F143|F142|F413|F412) ->
- printf "@[(%s%s%s+%s)*g_dim8g3_t_2(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf3 p3 wf1 p1 wf2 p2
-
- let print_vector4_km_t_rsi c pa pb pc wf1 p1 wf2 p2 wf3 p3 fusion (coeff, contraction) =
- match contraction, fusion with
- | C_12_34, (F234|F243|F134|F143|F421|F321|F412|F312)
- | C_13_42, (F324|F342|F124|F142|F431|F231|F413|F213)
- | C_14_23, (F423|F432|F123|F132|F341|F241|F314|F214) ->
- printf "@[(%s%s%s+%s)*g_dim8g3_t_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf1 p1 wf2 p2 wf3 p3
- | C_12_34, (F324|F314|F423|F413|F142|F132|F241|F231)
- | C_13_42, (F234|F214|F432|F412|F143|F123|F341|F321)
- | C_14_23, (F243|F213|F342|F312|F134|F124|F431|F421) ->
- printf "@[(%s%s%s+%s)*g_dim8g3_t_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))*((%s+%s)*(%s+%s)/((%s+%s)*(%s+%s)))@]"
- (format_coeff coeff) c pa pb wf2 p2 wf1 p1 wf3 p3 pa pb pa pb pb pc pb pc
- | C_12_34, (F342|F341|F432|F431|F124|F123|F214|F213)
- | C_13_42, (F243|F241|F423|F421|F134|F132|F314|F312)
- | C_14_23, (F234|F231|F324|F321|F143|F142|F413|F412) ->
- printf "@[(%s%s%s+%s)*g_dim8g3_t_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))*((%s+%s)*(%s+%s)/((%s+%s)*(%s+%s)))@]"
- (format_coeff coeff) c pa pb wf3 p3 wf1 p1 wf2 p2 pa pb pa pb pa pc pa pc
-
- let print_vector4_km_m_0 c pa pb wf1 p1 wf2 p2 wf3 p3 fusion (coeff, contraction) =
- match contraction, fusion with
- | C_12_34, (F234|F243|F134|F143|F421|F321|F412|F312)
- | C_13_42, (F324|F342|F124|F142|F431|F231|F413|F213)
- | C_14_23, (F423|F432|F123|F132|F341|F241|F314|F214) ->
- if (String.contains c 'w' || String.contains c '4') then
- printf "@[(%s%s%s+%s)*g_dim8g3_m_0(cmplx(1,kind=default),cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf1 p1 wf2 p2 wf3 p3
- else
- printf "@[((%s%s%s+%s))*g_dim8g3_m_0(cmplx(costhw**(-2),kind=default),cmplx(costhw**2,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf1 p1 wf2 p2 wf3 p3
- | C_12_34, (F324|F314|F423|F413|F142|F132|F241|F231)
- | C_13_42, (F234|F214|F432|F412|F143|F123|F341|F321)
- | C_14_23, (F243|F213|F342|F312|F134|F124|F431|F421) ->
- if (String.contains c 'w' || String.contains c '4') then
- printf "@[(%s%s%s+%s)*g_dim8g3_m_0(cmplx(1,kind=default),cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf2 p2 wf1 p1 wf3 p3
- else
- printf "@[(%s%s%s+%s)*g_dim8g3_m_0(cmplx(costhw**(-2),kind=default),cmplx(costhw**2,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf2 p2 wf1 p1 wf3 p3
- | C_12_34, (F342|F341|F432|F431|F124|F123|F214|F213)
- | C_13_42, (F243|F241|F423|F421|F134|F132|F314|F312)
- | C_14_23, (F234|F231|F324|F321|F143|F142|F413|F412) ->
- if (String.contains c 'w' || String.contains c '4') then
- printf "@[(%s%s%s+%s)*g_dim8g3_m_0(cmplx(1,kind=default),cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf3 p3 wf1 p1 wf2 p2
- else
- printf "@[(%s%s%s+%s)*g_dim8g3_m_0(cmplx(costhw**(-2),kind=default),cmplx(costhw**2,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf3 p3 wf1 p1 wf2 p2
-
- let print_vector4_km_m_1 c pa pb wf1 p1 wf2 p2 wf3 p3 fusion (coeff, contraction) =
- match contraction, fusion with
- | C_12_34, (F234|F243|F134|F143|F421|F321|F412|F312)
- | C_13_42, (F324|F342|F124|F142|F431|F231|F413|F213)
- | C_14_23, (F423|F432|F123|F132|F341|F241|F314|F214) ->
- if (String.contains c 'w' || String.contains c '4') then
- printf "@[(%s%s%s+%s)*g_dim8g3_m_1(cmplx(1,kind=default),cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf1 p1 wf2 p2 wf3 p3
- else
- printf "@[(%s%s%s+%s)*g_dim8g3_m_1(cmplx(costhw**(-2),kind=default),cmplx(costhw**2,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf1 p1 wf2 p2 wf3 p3
- | C_12_34, (F324|F314|F423|F413|F142|F132|F241|F231)
- | C_13_42, (F234|F214|F432|F412|F143|F123|F341|F321)
- | C_14_23, (F243|F213|F342|F312|F134|F124|F431|F421) ->
- if (String.contains c 'w' || String.contains c '4') then
- printf "@[(%s%s%s+%s)*g_dim8g3_m_1(cmplx(1,kind=default),cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf2 p2 wf1 p1 wf3 p3
- else
- printf "@[(%s%s%s+%s)*g_dim8g3_m_1(cmplx(costhw**(-2),kind=default),cmplx(costhw**2,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf2 p2 wf1 p1 wf3 p3
- | C_12_34, (F342|F341|F432|F431|F124|F123|F214|F213)
- | C_13_42, (F243|F241|F423|F421|F134|F132|F314|F312)
- | C_14_23, (F234|F231|F324|F321|F143|F142|F413|F412) ->
- if (String.contains c 'w' || String.contains c '4') then
- printf "@[(%s%s%s+%s)*g_dim8g3_m_1(cmplx(1,kind=default),cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf3 p3 wf1 p1 wf2 p2
- else
- printf "@[(%s%s%s+%s)*g_dim8g3_m_1(cmplx(costhw**(-2),kind=default),cmplx(costhw**2,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf3 p3 wf1 p1 wf2 p2
-
- let print_vector4_km_m_7 c pa pb wf1 p1 wf2 p2 wf3 p3 fusion (coeff, contraction) =
- match contraction, fusion with
- | C_12_34, (F234|F243|F134|F143|F421|F321|F412|F312)
- | C_13_42, (F324|F342|F124|F142|F431|F231|F413|F213)
- | C_14_23, (F423|F432|F123|F132|F341|F241|F314|F214) ->
- if (String.contains c 'w' || String.contains c '4') then
- printf "@[(%s%s%s+%s)*@ g_dim8g3_m_7(cmplx(1,kind=default),cmplx(1,kind=default),cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf1 p1 wf2 p2 wf3 p3
- else
- printf "@[(%s%s%s+%s)*@ g_dim8g3_m_7(cmplx(costhw**(-2),kind=default),cmplx(1,kind=default),cmplx(costhw**2,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf1 p1 wf2 p2 wf3 p3
- | C_12_34, (F324|F314|F423|F413|F142|F132|F241|F231)
- | C_13_42, (F234|F214|F432|F412|F143|F123|F341|F321)
- | C_14_23, (F243|F213|F342|F312|F134|F124|F431|F421) ->
- if (String.contains c 'w' || String.contains c '4') then
- printf "@[(%s%s%s+%s)*@ g_dim8g3_m_7(cmplx(1,kind=default),cmplx(1,kind=default),cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf2 p2 wf1 p1 wf3 p3
- else
- printf "@[(%s%s%s+%s)*@ g_dim8g3_m_7(cmplx(costhw**(-2),kind=default),cmplx(1,kind=default),cmplx(costhw**2,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf2 p2 wf1 p1 wf3 p3
- | C_12_34, (F342|F341|F432|F431|F124|F123|F214|F213)
- | C_13_42, (F243|F241|F423|F421|F134|F132|F314|F312)
- | C_14_23, (F234|F231|F324|F321|F143|F142|F413|F412) ->
- if (String.contains c 'w' || String.contains c '4') then
- printf "@[(%s%s%s+%s)*@ g_dim8g3_m_7(cmplx(1,kind=default),cmplx(1,kind=default),cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf3 p3 wf1 p1 wf2 p2
- else
- printf "@[(%s%s%s+%s)*@ g_dim8g3_m_7(cmplx(costhw**(-2),kind=default),cmplx(1,kind=default),cmplx(costhw**2,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf3 p3 wf1 p1 wf2 p2
-
- let print_add_vector4_km c pa pb wf1 wf2 wf3 fusion (coeff, contraction) =
- printf "@ + ";
- print_vector4_km c pa pb wf1 wf2 wf3 fusion (coeff, contraction)
-
- let print_dscalar4 c wf1 wf2 wf3 p1 p2 p3 p123
- fusion (coeff, contraction) =
- match contraction, fusion with
- | C_12_34, (F341|F431|F342|F432|F123|F213|F124|F214)
- | C_13_42, (F241|F421|F243|F423|F132|F312|F134|F314)
- | C_14_23, (F231|F321|F234|F324|F142|F412|F143|F413) ->
- printf "((%s%s)*(%s*%s)*(%s*%s)*%s*%s*%s)"
- (format_coeff coeff) c p1 p2 p3 p123 wf1 wf2 wf3
- | C_12_34, (F134|F143|F234|F243|F312|F321|F412|F421)
- | C_13_42, (F124|F142|F324|F342|F213|F231|F413|F431)
- | C_14_23, (F123|F132|F423|F432|F214|F241|F314|F341) ->
- printf "((%s%s)*(%s*%s)*(%s*%s)*%s*%s*%s)"
- (format_coeff coeff) c p2 p3 p1 p123 wf1 wf2 wf3
- | C_12_34, (F314|F413|F324|F423|F132|F231|F142|F241)
- | C_13_42, (F214|F412|F234|F432|F123|F321|F143|F341)
- | C_14_23, (F213|F312|F243|F342|F124|F421|F134|F431) ->
- printf "((%s%s)*(%s*%s)*(%s*%s)*%s*%s*%s)"
- (format_coeff coeff) c p1 p3 p2 p123 wf1 wf2 wf3
-
- let print_add_dscalar4 c wf1 wf2 wf3 p1 p2 p3 p123
- fusion (coeff, contraction) =
- printf "@ + ";
- print_dscalar4 c wf1 wf2 wf3 p1 p2 p3 p123 fusion (coeff, contraction)
-
- let print_dscalar2_vector2 c wf1 wf2 wf3 p1 p2 p3 p123 fusion (coeff, contraction) =
- match contraction, fusion with
- | C_12_34, (F123|F213|F124|F214) ->
- printf "(%s%s)*(%s*%s)*(%s*%s)*%s"
- (format_coeff coeff) c p1 p2 wf1 wf2 wf3
- | C_12_34, (F134|F143|F234|F243) ->
- printf "(%s%s)*(%s*%s)*(%s*%s)*%s"
- (format_coeff coeff) c p1 p123 wf2 wf3 wf1
- | C_12_34, (F132|F231|F142|F241) ->
- printf "(%s%s)*(%s*%s)*(%s*%s)*%s"
- (format_coeff coeff) c p1 p3 wf1 wf3 wf2
- | C_12_34, (F312|F321|F412|F421) ->
- printf "(%s%s)*(%s*%s)*(%s*%s)*%s"
- (format_coeff coeff) c p2 p3 wf2 wf3 wf1
- | C_12_34, (F314|F413|F324|F423) ->
- printf "(%s%s)*(%s*%s)*(%s*%s)*%s"
- (format_coeff coeff) c p2 p123 wf1 wf3 wf2
- | C_12_34, (F341|F431|F342|F432) ->
- printf "(%s%s)*(%s*%s)*(%s*%s)*%s"
- (format_coeff coeff) c p3 p123 wf1 wf2 wf3
- | C_13_42, (F123|F214)
- | C_14_23, (F124|F213) ->
- printf "((%s%s)*(%s*%s*%s)*%s*%s)"
- (format_coeff coeff) c wf1 p1 wf3 wf2 p2
- | C_13_42, (F124|F213)
- | C_14_23, (F123|F214) ->
- printf "((%s%s)*(%s*%s*%s)*%s*%s)"
- (format_coeff coeff) c wf2 p2 wf3 wf1 p1
- | C_13_42, (F132|F241)
- | C_14_23, (F142|F231) ->
- printf "((%s%s)*(%s*%s*%s)*%s*%s)"
- (format_coeff coeff) c wf1 p1 wf2 wf3 p3
- | C_13_42, (F142|F231)
- | C_14_23, (F132|F241) ->
- printf "((%s%s)*(%s*%s*%s)*%s*%s)"
- (format_coeff coeff) c wf3 p3 wf2 wf1 p1
- | C_13_42, (F312|F421)
- | C_14_23, (F412|F321) ->
- printf "((%s%s)*(%s*%s*%s)*%s*%s)"
- (format_coeff coeff) c wf2 p2 wf1 wf3 p3
- | C_13_42, (F321|F412)
- | C_14_23, (F421|F312) ->
- printf "((%s%s)*(%s*%s*%s)*%s*%s)"
- (format_coeff coeff) c wf3 p3 wf1 wf2 p2
- | C_13_42, (F134|F243)
- | C_14_23, (F143|F234) ->
- printf "((%s%s)*(%s*%s)*(%s*%s*%s))"
- (format_coeff coeff) c wf3 p123 wf1 p1 wf2
- | C_13_42, (F143|F234)
- | C_14_23, (F134|F243) ->
- printf "((%s%s)*(%s*%s)*(%s*%s*%s))"
- (format_coeff coeff) c wf2 p123 wf1 p1 wf3
- | C_13_42, (F314|F423)
- | C_14_23, (F413|F324) ->
- printf "((%s%s)*(%s*%s)*(%s*%s*%s))"
- (format_coeff coeff) c wf3 p123 wf2 p2 wf1
- | C_13_42, (F324|F413)
- | C_14_23, (F423|F314) ->
- printf "((%s%s)*(%s*%s)*(%s*%s*%s))"
- (format_coeff coeff) c wf1 p123 wf2 p2 wf3
- | C_13_42, (F341|F432)
- | C_14_23, (F431|F342) ->
- printf "((%s%s)*(%s*%s)*(%s*%s*%s))"
- (format_coeff coeff) c wf2 p123 wf3 p3 wf1
- | C_13_42, (F342|F431)
- | C_14_23, (F432|F341) ->
- printf "((%s%s)*(%s*%s)*(%s*%s*%s))"
- (format_coeff coeff) c wf1 p123 wf3 p3 wf2
-
- let print_add_dscalar2_vector2 c wf1 wf2 wf3 p1 p2 p3 p123
- fusion (coeff, contraction) =
- printf "@ + ";
- print_dscalar2_vector2 c wf1 wf2 wf3 p1 p2 p3 p123
- fusion (coeff, contraction)
-
- let print_dscalar2_vector2_km c pa pb wf1 wf2 wf3 p1 p2 p3 p123 fusion (coeff, contraction) =
- match contraction, fusion with
- | C_12_34, (F123|F213|F124|F214) ->
- printf "(%s%s%s+%s))*(%s*%s)*(%s*%s)*%s"
- (format_coeff coeff) c pa pb p1 p2 wf1 wf2 wf3
- | C_12_34, (F134|F143|F234|F243) ->
- printf "(%s%s%s+%s))*(%s*%s)*(%s*%s)*%s"
- (format_coeff coeff) c pa pb p1 p123 wf2 wf3 wf1
- | C_12_34, (F132|F231|F142|F241) ->
- printf "(%s%s%s+%s))*(%s*%s)*(%s*%s)*%s"
- (format_coeff coeff) c pa pb p1 p3 wf1 wf3 wf2
- | C_12_34, (F312|F321|F412|F421) ->
- printf "(%s%s%s+%s))*(%s*%s)*(%s*%s)*%s"
- (format_coeff coeff) c pa pb p2 p3 wf2 wf3 wf1
- | C_12_34, (F314|F413|F324|F423) ->
- printf "(%s%s%s+%s))*(%s*%s)*(%s*%s)*%s"
- (format_coeff coeff) c pa pb p2 p123 wf1 wf3 wf2
- | C_12_34, (F341|F431|F342|F432) ->
- printf "(%s%s%s+%s))*(%s*%s)*(%s*%s)*%s"
- (format_coeff coeff) c pa pb p3 p123 wf1 wf2 wf3
- | C_13_42, (F123|F214)
- | C_14_23, (F124|F213) ->
- printf "((%s%s%s+%s))*(%s*%s*%s)*%s*%s)"
- (format_coeff coeff) c pa pb wf1 p1 wf3 wf2 p2
- | C_13_42, (F124|F213)
- | C_14_23, (F123|F214) ->
- printf "((%s%s%s+%s))*(%s*%s*%s)*%s*%s)"
- (format_coeff coeff) c pa pb wf2 p2 wf3 wf1 p1
- | C_13_42, (F132|F241)
- | C_14_23, (F142|F231) ->
- printf "((%s%s%s+%s))*(%s*%s*%s)*%s*%s)"
- (format_coeff coeff) c pa pb wf1 p1 wf2 wf3 p3
- | C_13_42, (F142|F231)
- | C_14_23, (F132|F241) ->
- printf "((%s%s%s+%s))*(%s*%s*%s)*%s*%s)"
- (format_coeff coeff) c pa pb wf3 p3 wf2 wf1 p1
- | C_13_42, (F312|F421)
- | C_14_23, (F412|F321) ->
- printf "((%s%s%s+%s))*(%s*%s*%s)*%s*%s)"
- (format_coeff coeff) c pa pb wf2 p2 wf1 wf3 p3
- | C_13_42, (F321|F412)
- | C_14_23, (F421|F312) ->
- printf "((%s%s%s+%s))*(%s*%s*%s)*%s*%s)"
- (format_coeff coeff) c pa pb wf3 p3 wf1 wf2 p2
- | C_13_42, (F134|F243)
- | C_14_23, (F143|F234) ->
- printf "((%s%s%s+%s))*(%s*%s)*(%s*%s*%s))"
- (format_coeff coeff) c pa pb wf3 p123 wf1 p1 wf2
- | C_13_42, (F143|F234)
- | C_14_23, (F134|F243) ->
- printf "((%s%s%s+%s))*(%s*%s)*(%s*%s*%s))"
- (format_coeff coeff) c pa pb wf2 p123 wf1 p1 wf3
- | C_13_42, (F314|F423)
- | C_14_23, (F413|F324) ->
- printf "((%s%s%s+%s))*(%s*%s)*(%s*%s*%s))"
- (format_coeff coeff) c pa pb wf3 p123 wf2 p2 wf1
- | C_13_42, (F324|F413)
- | C_14_23, (F423|F314) ->
- printf "((%s%s%s+%s))*(%s*%s)*(%s*%s*%s))"
- (format_coeff coeff) c pa pb wf1 p123 wf2 p2 wf3
- | C_13_42, (F341|F432)
- | C_14_23, (F431|F342) ->
- printf "((%s%s%s+%s))*(%s*%s)*(%s*%s*%s))"
- (format_coeff coeff) c pa pb wf2 p123 wf3 p3 wf1
- | C_13_42, (F342|F431)
- | C_14_23, (F432|F341) ->
- printf "((%s%s%s+%s))*(%s*%s)*(%s*%s*%s))"
- (format_coeff coeff) c pa pb wf1 p123 wf3 p3 wf2
-
- let print_add_dscalar2_vector2_km c pa pb wf1 wf2 wf3 p1 p2 p3 p123 fusion (coeff, contraction) =
- printf "@ + ";
- print_dscalar2_vector2_km c pa pb wf1 wf2 wf3 p1 p2 p3 p123 fusion (coeff, contraction)
-
- let print_dscalar2_vector2_m_0_km c pa pb wf1 wf2 wf3 p1 p2 p3 fusion (coeff, contraction) =
- match contraction, fusion with
- | C_12_34, (F123|F213|F124|F214) ->
- printf "@[((%s%s%s+%s))*v_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf1 p1 wf2 p2 wf3 p3
- | C_12_34, (F134|F143|F234|F243) ->
- printf "@[((%s%s%s+%s))*phi_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf1 p1 wf2 p2 wf3 p3
- | C_12_34, (F132|F231|F142|F241) ->
- printf "@[((%s%s%s+%s))*v_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf1 p1 wf3 p3 wf2 p2
- | C_12_34, (F312|F321|F412|F421) ->
- printf "@[((%s%s%s+%s))*v_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf3 p3 wf2 p2 wf1 p1
- | C_12_34, (F314|F413|F324|F423) ->
- printf "@[((%s%s%s+%s))*phi_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf2 p2 wf1 p1 wf3 p3
- | C_12_34, (F341|F431|F342|F432) ->
- printf "@[((%s%s%s+%s))*phi_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf3 p3 wf2 p2 wf1 p1
- | C_13_42, (F123|F214)
- | C_14_23, (F124|F213) ->
- printf "@[((%s%s%s+%s))*v_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf1 p1 wf2 p3 wf3 p2
- | C_13_42, (F124|F213)
- | C_14_23, (F123|F214) ->
- printf "@[((%s%s%s+%s))*v_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf2 p2 wf1 p3 wf3 p1
- | C_13_42, (F132|F241)
- | C_14_23, (F142|F231) ->
- printf "@[((%s%s%s+%s))*v_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf1 p1 wf3 p2 wf2 p3
- | C_13_42, (F142|F231)
- | C_14_23, (F132|F241) ->
- printf "@[((%s%s%s+%s))*v_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf3 p3 wf1 p2 wf2 p1
- | C_13_42, (F312|F421)
- | C_14_23, (F412|F321) ->
- printf "@[((%s%s%s+%s))*v_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf2 p2 wf3 p1 wf1 p3
- | C_13_42, (F321|F412)
- | C_14_23, (F421|F312) ->
- printf "@[((%s%s%s+%s))*v_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf3 p3 wf2 p1 wf1 p2
- | C_13_42, (F134|F243)
- | C_14_23, (F143|F234) ->
- printf "@[((%s%s%s+%s))*phi_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf1 p3 wf3 p1 wf2 p2
- | C_13_42, (F143|F234)
- | C_14_23, (F134|F243) ->
- printf "@[((%s%s%s+%s))*phi_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf1 p2 wf2 p1 wf3 p3
- | C_13_42, (F314|F423)
- | C_14_23, (F413|F324) ->
- printf "@[((%s%s%s+%s))*phi_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf2 p3 wf3 p2 wf1 p1
- | C_13_42, (F324|F413)
- | C_14_23, (F423|F314) ->
- printf "@[((%s%s%s+%s))*phi_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf2 p1 wf1 p2 wf3 p3
- | C_13_42, (F341|F432)
- | C_14_23, (F431|F342) ->
- printf "@[((%s%s%s+%s))*phi_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf3 p2 wf2 p3 wf1 p1
- | C_13_42, (F342|F431)
- | C_14_23, (F432|F341) ->
- printf "@[((%s%s%s+%s))*phi_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf3 p1 wf1 p3 wf2 p2
-
- let print_add_dscalar2_vector2_m_0_km c pa pb wf1 wf2 wf3 p1 p2 p3 fusion (coeff, contraction) =
- printf "@ + ";
- print_dscalar2_vector2_m_0_km c pa pb wf1 wf2 wf3 p1 p2 p3 fusion (coeff, contraction)
-
- let print_dscalar2_vector2_m_1_km c pa pb wf1 wf2 wf3 p1 p2 p3 fusion (coeff, contraction) =
- match contraction, fusion with
- | C_12_34, (F123|F213|F124|F214) ->
- printf "@[((%s%s%s+%s))*v_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf1 p1 wf2 p2 wf3 p3
- | C_12_34, (F134|F143|F234|F243) ->
- printf "@[((%s%s%s+%s))*phi_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf1 p1 wf2 p2 wf3 p3
- | C_12_34, (F132|F231|F142|F241) ->
- printf "@[((%s%s%s+%s))*v_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf1 p1 wf3 p3 wf2 p2
- | C_12_34, (F312|F321|F412|F421) ->
- printf "@[((%s%s%s+%s))*v_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf3 p3 wf2 p2 wf1 p1
- | C_12_34, (F314|F413|F324|F423) ->
- printf "@[((%s%s%s+%s))*phi_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf2 p2 wf1 p1 wf3 p3
- | C_12_34, (F341|F431|F342|F432) ->
- printf "@[((%s%s%s+%s))*phi_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf3 p3 wf2 p2 wf1 p1
- | C_13_42, (F123|F214)
- | C_14_23, (F124|F213) ->
- printf "@[((%s%s%s+%s))*v_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf1 p1 wf2 p3 wf3 p2
- | C_13_42, (F124|F213)
- | C_14_23, (F123|F214) ->
- printf "@[((%s%s%s+%s))*v_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf2 p2 wf1 p3 wf3 p1
- | C_13_42, (F132|F241)
- | C_14_23, (F142|F231) ->
- printf "@[((%s%s%s+%s))*v_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf1 p1 wf3 p2 wf2 p3
- | C_13_42, (F142|F231)
- | C_14_23, (F132|F241) ->
- printf "@[((%s%s%s+%s))*v_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf3 p3 wf1 p2 wf2 p1
- | C_13_42, (F312|F421)
- | C_14_23, (F412|F321) ->
- printf "@[((%s%s%s+%s))*v_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf2 p2 wf3 p1 wf1 p3
- | C_13_42, (F321|F412)
- | C_14_23, (F421|F312) ->
- printf "@[((%s%s%s+%s))*v_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf3 p3 wf2 p1 wf1 p2
- | C_13_42, (F134|F243)
- | C_14_23, (F143|F234) ->
- printf "@[((%s%s%s+%s))*phi_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf1 p3 wf3 p1 wf2 p2
- | C_13_42, (F143|F234)
- | C_14_23, (F134|F243) ->
- printf "@[((%s%s%s+%s))*phi_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf1 p2 wf2 p1 wf3 p3
- | C_13_42, (F314|F423)
- | C_14_23, (F413|F324) ->
- printf "@[((%s%s%s+%s))*phi_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf2 p3 wf3 p2 wf1 p1
- | C_13_42, (F324|F413)
- | C_14_23, (F423|F314) ->
- printf "@[((%s%s%s+%s))*phi_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf2 p1 wf1 p2 wf3 p3
- | C_13_42, (F341|F432)
- | C_14_23, (F431|F342) ->
- printf "@[((%s%s%s+%s))*phi_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf3 p2 wf2 p3 wf1 p1
- | C_13_42, (F342|F431)
- | C_14_23, (F432|F341) ->
- printf "@[((%s%s%s+%s))*phi_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf3 p1 wf1 p3 wf2 p2
-
- let print_add_dscalar2_vector2_m_1_km c pa pb wf1 wf2 wf3 p1 p2 p3 fusion (coeff, contraction) =
- printf "@ + ";
- print_dscalar2_vector2_m_1_km c pa pb wf1 wf2 wf3 p1 p2 p3 fusion (coeff, contraction)
-
- let print_dscalar2_vector2_m_7_km c pa pb wf1 wf2 wf3 p1 p2 p3 fusion (coeff, contraction) =
- match contraction, fusion with
- | C_12_34, (F123|F213|F124|F214) ->
- printf "@[((%s%s%s+%s))*v_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf1 p1 wf2 p2 wf3 p3
- | C_12_34, (F134|F143|F234|F243) ->
- printf "@[((%s%s%s+%s))*phi_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf1 p1 wf2 p2 wf3 p3
- | C_12_34, (F132|F231|F142|F241) ->
- printf "@[((%s%s%s+%s))*v_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf1 p1 wf3 p3 wf2 p2
- | C_12_34, (F312|F321|F412|F421) ->
- printf "@[((%s%s%s+%s))*v_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf3 p3 wf2 p2 wf1 p1
- | C_12_34, (F314|F413|F324|F423) ->
- printf "@[((%s%s%s+%s))*phi_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf2 p2 wf1 p1 wf3 p3
- | C_12_34, (F341|F431|F342|F432) ->
- printf "@[((%s%s%s+%s))*phi_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf3 p3 wf2 p2 wf1 p1
- | C_13_42, (F123|F214)
- | C_14_23, (F124|F213) ->
- printf "@[((%s%s%s+%s))*v_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf1 p1 wf2 p3 wf3 p2
- | C_13_42, (F124|F213)
- | C_14_23, (F123|F214) ->
- printf "@[((%s%s%s+%s))*v_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf2 p2 wf1 p3 wf3 p1
- | C_13_42, (F132|F241)
- | C_14_23, (F142|F231) ->
- printf "@[((%s%s%s+%s))*v_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf1 p1 wf3 p2 wf2 p3
- | C_13_42, (F142|F231)
- | C_14_23, (F132|F241) ->
- printf "@[((%s%s%s+%s))*v_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf3 p3 wf1 p2 wf2 p1
- | C_13_42, (F312|F421)
- | C_14_23, (F412|F321) ->
- printf "@[((%s%s%s+%s))*v_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf2 p2 wf3 p1 wf1 p3
- | C_13_42, (F321|F412)
- | C_14_23, (F421|F312) ->
- printf "@[((%s%s%s+%s))*v_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf3 p3 wf2 p1 wf1 p2
- | C_13_42, (F134|F243)
- | C_14_23, (F143|F234) ->
- printf "@[((%s%s%s+%s))*phi_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf1 p3 wf3 p1 wf2 p2
- | C_13_42, (F143|F234)
- | C_14_23, (F134|F243) ->
- printf "@[((%s%s%s+%s))*phi_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf1 p2 wf2 p1 wf3 p3
- | C_13_42, (F314|F423)
- | C_14_23, (F413|F324) ->
- printf "@[((%s%s%s+%s))*phi_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf2 p3 wf3 p2 wf1 p1
- | C_13_42, (F324|F413)
- | C_14_23, (F423|F314) ->
- printf "@[((%s%s%s+%s))*phi_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf2 p1 wf1 p2 wf3 p3
- | C_13_42, (F341|F432)
- | C_14_23, (F431|F342) ->
- printf "@[((%s%s%s+%s))*phi_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf3 p2 wf2 p3 wf1 p1
- | C_13_42, (F342|F431)
- | C_14_23, (F432|F341) ->
- printf "@[((%s%s%s+%s))*phi_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
- (format_coeff coeff) c pa pb wf3 p1 wf1 p3 wf2 p2
-
- let print_add_dscalar2_vector2_m_7_km c pa pb wf1 wf2 wf3 p1 p2 p3 fusion (coeff, contraction) =
- printf "@ + ";
- print_dscalar2_vector2_m_7_km c pa pb wf1 wf2 wf3 p1 p2 p3 fusion (coeff, contraction)
-
- let print_dscalar4_km c pa pb wf1 wf2 wf3 p1 p2 p3 p123 fusion (coeff, contraction) =
- match contraction, fusion with
- | C_12_34, (F341|F431|F342|F432|F123|F213|F124|F214)
- | C_13_42, (F241|F421|F243|F423|F132|F312|F134|F314)
- | C_14_23, (F231|F321|F234|F324|F142|F412|F143|F413) ->
- printf "((%s%s%s+%s))*(%s*%s)*(%s*%s)*%s*%s*%s)"
- (format_coeff coeff) c pa pb p1 p2 p3 p123 wf1 wf2 wf3
- | C_12_34, (F134|F143|F234|F243|F312|F321|F412|F421)
- | C_13_42, (F124|F142|F324|F342|F213|F231|F413|F431)
- | C_14_23, (F123|F132|F423|F432|F214|F241|F314|F341) ->
- printf "((%s%s%s+%s))*(%s*%s)*(%s*%s)*%s*%s*%s)"
- (format_coeff coeff) c pa pb p2 p3 p1 p123 wf1 wf2 wf3
- | C_12_34, (F314|F413|F324|F423|F132|F231|F142|F241)
- | C_13_42, (F214|F412|F234|F432|F123|F321|F143|F341)
- | C_14_23, (F213|F312|F243|F342|F124|F421|F134|F431) ->
- printf "((%s%s%s+%s))*(%s*%s)*(%s*%s)*%s*%s*%s)"
- (format_coeff coeff) c pa pb p1 p3 p2 p123 wf1 wf2 wf3
-
- let print_add_dscalar4_km c pa pb wf1 wf2 wf3 p1 p2 p3 p123 fusion (coeff, contraction) =
- printf "@ + ";
- print_dscalar4_km c pa pb wf1 wf2 wf3 p1 p2 p3 p123 fusion (coeff, contraction)
-
- let print_current amplitude dictionary rhs =
- match F.coupling rhs with
- | V3 (vertex, fusion, constant) ->
- let ch1, ch2 = children2 rhs in
- let wf1 = multiple_variable amplitude dictionary ch1
- and wf2 = multiple_variable amplitude dictionary ch2
- and p1 = momentum ch1
- and p2 = momentum ch2
- and m1 = CM.mass_symbol (F.flavor ch1)
- and m2 = CM.mass_symbol (F.flavor ch2) in
- let c = CM.constant_symbol constant in
- printf "@, %s " (if (F.sign rhs) < 0 then "-" else "+");
- begin match vertex with
-
-(* Fermionic currents $\bar\psi\fmslash{A}\psi$ and $\bar\psi\phi\psi$
- are handled by the [Fermions] module, since they depend on the
- choice of Feynman rules: Dirac or Majorana. *)
-
- | FBF (coeff, fb, b, f) ->
- begin match coeff, fb, b, f with
- | _, _, (VLRM|SPM|VAM|VA3M|TVA|TVAM|TLR|TLRM|TRL|TRLM), _ ->
- let p12 = Printf.sprintf "(-%s-%s)" p1 p2 in
- Fermions.print_current_mom (coeff, fb, b, f) c wf1 wf2 p1 p2
- p12 fusion
- | _, _, _, _ ->
- Fermions.print_current (coeff, fb, b, f) c wf1 wf2 fusion
- end
- | PBP (coeff, f1, b, f2) ->
- Fermions.print_current_p (coeff, f1, b, f2) c wf1 wf2 fusion
- | BBB (coeff, fb1, b, fb2) ->
- Fermions.print_current_b (coeff, fb1, b, fb2) c wf1 wf2 fusion
- | GBG (coeff, fb, b, f) -> let p12 =
- Printf.sprintf "(-%s-%s)" p1 p2 in
- Fermions.print_current_g (coeff, fb, b, f) c wf1 wf2 p1 p2
- p12 fusion
-
-(* Table~\ref{tab:dim4-bosons} is a bit misleading, since if includes
- totally antisymmetric structure constants. The space-time part alone
- is also totally antisymmetric: *)
-
- | Gauge_Gauge_Gauge coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | (F23|F31|F12) ->
- printf "g_gg(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | (F32|F13|F21) ->
- printf "g_gg(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- end
-
- | I_Gauge_Gauge_Gauge coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | (F23|F31|F12) ->
- printf "g_gg((0,1)*(%s),%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | (F32|F13|F21) ->
- printf "g_gg((0,1)*(%s),%s,%s,%s,%s)" c wf2 p2 wf1 p1
- end
-
-(* In [Aux_Gauge_Gauge], we can not rely on antisymmetry alone, because of the
- different Lorentz representations of the auxialiary and the gauge field.
- Instead we have to provide the sign in
- \begin{equation}
- (V_2 \wedge V_3) \cdot T_1 =
- \begin{cases}
- V_2 \cdot (T_1 \cdot V_3) = - V_2 \cdot (V_3 \cdot T_1) & \\
- V_3 \cdot (V_2 \cdot T_1) = - V_3 \cdot (T_1 \cdot V_2) &
- \end{cases}
- \end{equation}
- ourselves. Alternatively, one could provide \verb+g_xg+ mirroring
- \verb+g_gx+. *)
-
- | Aux_Gauge_Gauge coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F23 -> printf "x_gg(%s,%s,%s)" c wf1 wf2
- | F32 -> printf "x_gg(%s,%s,%s)" c wf2 wf1
- | F12 -> printf "g_gx(%s,%s,%s)" c wf2 wf1
- | F21 -> printf "g_gx(%s,%s,%s)" c wf1 wf2
- | F13 -> printf "(-1)*g_gx(%s,%s,%s)" c wf2 wf1
- | F31 -> printf "(-1)*g_gx(%s,%s,%s)" c wf1 wf2
- end
-
-(* These cases are symmetric and we just have to juxtapose the correct fields
- and provide parentheses to minimize the number of multiplications. *)
-
- | Scalar_Vector_Vector coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | (F23|F32) -> printf "%s*(%s*%s)" c wf1 wf2
- | (F12|F13) -> printf "(%s*%s)*%s" c wf1 wf2
- | (F21|F31) -> printf "(%s*%s)*%s" c wf2 wf1
- end
-
- | Aux_Vector_Vector coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | (F23|F32) -> printf "%s*(%s*%s)" c wf1 wf2
- | (F12|F13) -> printf "(%s*%s)*%s" c wf1 wf2
- | (F21|F31) -> printf "(%s*%s)*%s" c wf2 wf1
- end
-
-(* Even simpler: *)
-
- | Scalar_Scalar_Scalar coeff ->
- printf "(%s*%s*%s)" (format_coupling coeff c) wf1 wf2
-
- | Aux_Scalar_Scalar coeff ->
- printf "(%s*%s*%s)" (format_coupling coeff c) wf1 wf2
-
- | Aux_Scalar_Vector coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | (F13|F31) -> printf "%s*(%s*%s)" c wf1 wf2
- | (F23|F21) -> printf "(%s*%s)*%s" c wf1 wf2
- | (F32|F12) -> printf "(%s*%s)*%s" c wf2 wf1
- end
-
- | Vector_Scalar_Scalar coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F23 -> printf "v_ss(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F32 -> printf "v_ss(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- | F12 -> printf "s_vs(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F21 -> printf "s_vs(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- | F13 -> printf "(-1)*s_vs(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F31 -> printf "(-1)*s_vs(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- end
-
- | Graviton_Scalar_Scalar coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F12 -> printf "s_gravs(%s,%s,-(%s+%s),%s,%s,%s)" c m2 p1 p2 p2 wf1 wf2
- | F21 -> printf "s_gravs(%s,%s,-(%s+%s),%s,%s,%s)" c m1 p1 p2 p1 wf2 wf1
- | F13 -> printf "s_gravs(%s,%s,%s,-(%s+%s),%s,%s)" c m2 p2 p1 p2 wf1 wf2
- | F31 -> printf "s_gravs(%s,%s,%s,-(%s+%s),%s,%s)" c m1 p1 p1 p2 wf2 wf1
- | F23 -> printf "grav_ss(%s,%s,%s,%s,%s,%s)" c m1 p1 p2 wf1 wf2
- | F32 -> printf "grav_ss(%s,%s,%s,%s,%s,%s)" c m1 p2 p1 wf2 wf1
- end
-
-(* In producing a vector in the fusion we always contract the rightmost index with the
- vector wavefunction from [rhs]. So the first momentum is always the one of the
- vector boson produced in the fusion, while the second one is that from the [rhs].
- This makes the cases [F12] and [F13] as well as [F21] and [F31] equal. In principle,
- we could have already done this for the [Graviton_Scalar_Scalar] case. *)
-
-
- | Graviton_Vector_Vector coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | (F12|F13) -> printf "v_gravv(%s,%s,-(%s+%s),%s,%s,%s)" c m2 p1 p2 p2 wf1 wf2
- | (F21|F31) -> printf "v_gravv(%s,%s,-(%s+%s),%s,%s,%s)" c m1 p1 p2 p1 wf2 wf1
- | F23 -> printf "grav_vv(%s,%s,%s,%s,%s,%s)" c m1 p1 p2 wf1 wf2
- | F32 -> printf "grav_vv(%s,%s,%s,%s,%s,%s)" c m1 p2 p1 wf2 wf1
- end
-
- | Graviton_Spinor_Spinor coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F23 -> printf "f_gravf(%s,%s,-(%s+%s),(-%s),%s,%s)" c m2 p1 p2 p2 wf1 wf2
- | F32 -> printf "f_gravf(%s,%s,-(%s+%s),(-%s),%s,%s)" c m1 p1 p2 p1 wf2 wf1
- | F12 -> printf "f_fgrav(%s,%s,%s,%s+%s,%s,%s)" c m1 p1 p1 p2 wf1 wf2
- | F21 -> printf "f_fgrav(%s,%s,%s,%s+%s,%s,%s)" c m2 p2 p1 p2 wf2 wf1
- | F13 -> printf "grav_ff(%s,%s,%s,(-%s),%s,%s)" c m1 p1 p2 wf1 wf2
- | F31 -> printf "grav_ff(%s,%s,%s,(-%s),%s,%s)" c m1 p2 p1 wf2 wf1
- end
-
- | Dim4_Vector_Vector_Vector_T coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F23 -> printf "tkv_vv(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F32 -> printf "tkv_vv(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- | F12 -> printf "tv_kvv(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F21 -> printf "tv_kvv(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- | F13 -> printf "(-1)*tv_kvv(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F31 -> printf "(-1)*tv_kvv(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- end
-
- | Dim4_Vector_Vector_Vector_L coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F23 -> printf "lkv_vv(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F32 -> printf "lkv_vv(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- | F12 | F13 -> printf "lv_kvv(%s,%s,%s,%s)" c wf1 p1 wf2
- | F21 | F31 -> printf "lv_kvv(%s,%s,%s,%s)" c wf2 p2 wf1
- end
-
- | Dim6_Gauge_Gauge_Gauge coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F23 | F31 | F12 ->
- printf "kg_kgkg(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F32 | F13 | F21 ->
- printf "kg_kgkg(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- end
-
- | Dim4_Vector_Vector_Vector_T5 coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F23 -> printf "t5kv_vv(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F32 -> printf "t5kv_vv(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- | F12 | F13 -> printf "t5v_kvv(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F21 | F31 -> printf "t5v_kvv(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- end
-
- | Dim4_Vector_Vector_Vector_L5 coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F23 -> printf "l5kv_vv(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F32 -> printf "l5kv_vv(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- | F12 -> printf "l5v_kvv(%s,%s,%s,%s)" c wf1 p1 wf2
- | F21 -> printf "l5v_kvv(%s,%s,%s,%s)" c wf2 p2 wf1
- | F13 -> printf "(-1)*l5v_kvv(%s,%s,%s,%s)" c wf1 p1 wf2
- | F31 -> printf "(-1)*l5v_kvv(%s,%s,%s,%s)" c wf2 p2 wf1
- end
-
- | Dim6_Gauge_Gauge_Gauge_5 coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F23 -> printf "kg5_kgkg(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F32 -> printf "kg5_kgkg(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- | F12 -> printf "kg_kg5kg(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F21 -> printf "kg_kg5kg(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- | F13 -> printf "(-1)*kg_kg5kg(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F31 -> printf "(-1)*kg_kg5kg(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- end
-
- | Aux_DScalar_DScalar coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | (F23|F32) ->
- printf "%s*(%s*%s)*(%s*%s)" c p1 p2 wf1 wf2
- | (F12|F13) ->
- printf "%s*(-((%s+%s)*%s))*(%s*%s)" c p1 p2 p2 wf1 wf2
- | (F21|F31) ->
- printf "%s*(-((%s+%s)*%s))*(%s*%s)" c p1 p2 p1 wf1 wf2
- end
-
- | Aux_Vector_DScalar coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F23 -> printf "%s*(%s*%s)*%s" c wf1 p2 wf2
- | F32 -> printf "%s*(%s*%s)*%s" c wf2 p1 wf1
- | F12 -> printf "%s*(-((%s+%s)*%s))*%s" c p1 p2 wf2 wf1
- | F21 -> printf "%s*(-((%s+%s)*%s))*%s" c p1 p2 wf1 wf2
- | (F13|F31) -> printf "(-(%s+%s))*(%s*%s*%s)" p1 p2 c wf1 wf2
- end
-
- | Dim5_Scalar_Gauge2 coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | (F23|F32) -> printf "(%s)*((%s*%s)*(%s*%s) - (%s*%s)*(%s*%s))"
- c p1 wf2 p2 wf1 p1 p2 wf2 wf1
- | (F12|F13) -> printf "(%s)*%s*((-((%s+%s)*%s))*%s - ((-(%s+%s)*%s))*%s)"
- c wf1 p1 p2 wf2 p2 p1 p2 p2 wf2
- | (F21|F31) -> printf "(%s)*%s*((-((%s+%s)*%s))*%s - ((-(%s+%s)*%s))*%s)"
- c wf2 p2 p1 wf1 p1 p1 p2 p1 wf1
- end
-
- | Dim5_Scalar_Gauge2_Skew coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | (F23|F32) -> printf "(- phi_vv (%s, %s, %s, %s, %s))" c p1 p2 wf1 wf2
- | (F12|F13) -> printf "(- v_phiv (%s, %s, %s, %s, %s))" c wf1 p1 p2 wf2
- | (F21|F31) -> printf "v_phiv (%s, %s, %s, %s, %s)" c wf2 p1 p2 wf1
- end
-
- | Dim5_Scalar_Vector_Vector_T coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | (F23|F32) -> printf "(%s)*(%s*%s)*(%s*%s)" c p1 wf2 p2 wf1
- | (F12|F13) -> printf "(%s)*%s*(-((%s+%s)*%s))*%s" c wf1 p1 p2 wf2 p2
- | (F21|F31) -> printf "(%s)*%s*(-((%s+%s)*%s))*%s" c wf2 p2 p1 wf1 p1
- end
-
- | Dim5_Scalar_Vector_Vector_U coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | (F23|F32) -> printf "phi_u_vv (%s, %s, %s, %s, %s)" c p1 p2 wf1 wf2
- | (F12|F13) -> printf "v_u_phiv (%s, %s, %s, %s, %s)" c wf1 p1 p2 wf2
- | (F21|F31) -> printf "v_u_phiv (%s, %s, %s, %s, %s)" c wf2 p2 p1 wf1
- end
-
- | Dim5_Scalar_Vector_Vector_TU coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F23 -> printf "(%s)*((%s*%s)*(-(%s+%s)*%s) - (-(%s+%s)*%s)*(%s*%s))"
- c p1 wf2 p1 p2 wf1 p1 p2 p1 wf1 wf2
- | F32 -> printf "(%s)*((%s*%s)*(-(%s+%s)*%s) - (-(%s+%s)*%s)*(%s*%s))"
- c p2 wf1 p1 p2 wf2 p1 p2 p2 wf1 wf2
- | F12 -> printf "(%s)*%s*((%s*%s)*%s - (%s*%s)*%s)"
- c wf1 p1 wf2 p2 p1 p2 wf2
- | F21 -> printf "(%s)*%s*((%s*%s)*%s - (%s*%s)*%s)"
- c wf2 p2 wf1 p1 p1 p2 wf1
- | F13 -> printf "(%s)*%s*((-(%s+%s)*%s)*%s - (-(%s+%s)*%s)*%s)"
- c wf1 p1 p2 wf2 p1 p1 p2 p1 wf2
- | F31 -> printf "(%s)*%s*((-(%s+%s)*%s)*%s - (-(%s+%s)*%s)*%s)"
- c wf2 p1 p2 wf1 p2 p1 p2 p2 wf1
- end
-
- | Dim5_Scalar_Scalar2 coeff->
- let c = format_coupling coeff c in
- begin match fusion with
- | (F23|F32) -> printf "phi_dim5s2(%s, %s ,%s, %s, %s)"
- c wf1 p1 wf2 p2
- | (F12|F13) -> let p12 = Printf.sprintf "(-%s-%s)" p1 p2 in
- printf "phi_dim5s2(%s,%s,%s,%s,%s)" c wf1 p12 wf2 p2
- | (F21|F31) -> let p12 = Printf.sprintf "(-%s-%s)" p1 p2 in
- printf "phi_dim5s2(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p12
- end
-
- | Scalar_Vector_Vector_t coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | (F23|F32) -> printf "s_vv_t(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | (F12|F13) -> printf "v_sv_t(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | (F21|F31) -> printf "v_sv_t(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- end
-
- | Dim6_Vector_Vector_Vector_T coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F23 -> printf "(%s)*(%s*%s)*(%s*%s)*(%s-%s)" c p2 wf1 p1 wf2 p1 p2
- | F32 -> printf "(%s)*(%s*%s)*(%s*%s)*(%s-%s)" c p1 wf2 p2 wf1 p2 p1
- | (F12|F13) -> printf "(%s)*((%s+2*%s)*%s)*(-((%s+%s)*%s))*%s"
- c p1 p2 wf1 p1 p2 wf2 p2
- | (F21|F31) -> printf "(%s)*((-((%s+%s)*%s))*(%s+2*%s)*%s)*%s"
- c p2 p1 wf1 p2 p1 wf2 p1
- end
-
- | Tensor_2_Vector_Vector coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | (F23|F32) -> printf "t2_vv(%s,%s,%s)" c wf1 wf2
- | (F12|F13) -> printf "v_t2v(%s,%s,%s)" c wf1 wf2
- | (F21|F31) -> printf "v_t2v(%s,%s,%s)" c wf2 wf1
- end
-
- | Tensor_2_Scalar_Scalar coeff->
- let c = format_coupling coeff c in
- begin match fusion with
- | (F23|F32) -> printf "t2_phi2(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | (F12|F13) -> printf "phi_t2phi(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | (F21|F31) -> printf "phi_t2phi(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- end
-
- | Tensor_2_Vector_Vector_1 coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | (F23|F32) -> printf "t2_vv_1(%s,%s,%s)" c wf1 wf2
- | (F12|F13) -> printf "v_t2v_1(%s,%s,%s)" c wf1 wf2
- | (F21|F31) -> printf "v_t2v_1(%s,%s,%s)" c wf2 wf1
- end
-
- | Tensor_2_Vector_Vector_cf coeff->
- let c = format_coupling coeff c in
- begin match fusion with
- | (F23|F32) -> printf "t2_vv_cf(%s,%s,%s)" c wf1 wf2
- | (F12|F13) -> printf "v_t2v_cf(%s,%s,%s)" c wf1 wf2
- | (F21|F31) -> printf "v_t2v_cf(%s,%s,%s)" c wf2 wf1
- end
-
- | Tensor_2_Scalar_Scalar_cf coeff->
- let c = format_coupling coeff c in
- begin match fusion with
- | (F23|F32) -> printf "t2_phi2_cf(%s,%s,%s,%s, %s)" c wf1 p1 wf2 p2
- | (F12|F13) -> printf "phi_t2phi_cf(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | (F21|F31) -> printf "phi_t2phi_cf(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- end
-
- | Dim5_Tensor_2_Vector_Vector_1 coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | (F23|F32) -> printf "t2_vv_d5_1(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | (F12|F13) -> printf "v_t2v_d5_1(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | (F21|F31) -> printf "v_t2v_d5_1(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- end
-
- | Tensor_2_Vector_Vector_t coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | (F23|F32) -> printf "t2_vv_t(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | (F12|F13) -> printf "v_t2v_t(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | (F21|F31) -> printf "v_t2v_t(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- end
-
- | Dim5_Tensor_2_Vector_Vector_2 coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F23 -> printf "t2_vv_d5_2(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F32 -> printf "t2_vv_d5_2(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- | (F12|F13) -> printf "v_t2v_d5_2(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | (F21|F31) -> printf "v_t2v_d5_2(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- end
-
- | TensorVector_Vector_Vector coeff->
- let c = format_coupling coeff c in
- begin match fusion with
- | (F23|F32) -> printf "dv_vv(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | (F12|F13) -> printf "v_dvv(%s,%s,%s,%s)" c wf1 p1 wf2
- | (F21|F31) -> printf "v_dvv(%s,%s,%s,%s)" c wf2 p2 wf1
- end
-
- | TensorVector_Vector_Vector_cf coeff->
- let c = format_coupling coeff c in
- begin match fusion with
- | (F23|F32) -> printf "dv_vv_cf(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | (F12|F13) -> printf "v_dvv_cf(%s,%s,%s,%s)" c wf1 p1 wf2
- | (F21|F31) -> printf "v_dvv_cf(%s,%s,%s,%s)" c wf2 p2 wf1
- end
-
- | TensorVector_Scalar_Scalar coeff->
- let c = format_coupling coeff c in
- begin match fusion with
- | (F23|F32) -> printf "dv_phi2(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | (F12|F13) -> printf "phi_dvphi(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | (F21|F31) -> printf "phi_dvphi(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- end
-
- | TensorVector_Scalar_Scalar_cf coeff->
- let c = format_coupling coeff c in
- begin match fusion with
- | (F23|F32) -> printf "dv_phi2_cf(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | (F12|F13) -> printf "phi_dvphi_cf(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | (F21|F31) -> printf "phi_dvphi_cf(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- end
-
- | TensorScalar_Vector_Vector coeff->
- let c = format_coupling coeff c in
- begin match fusion with
- | (F23|F32) -> printf "tphi_vv(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | (F12|F13) -> printf "v_tphiv(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | (F21|F31) -> printf "v_tphiv(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- end
-
- | TensorScalar_Vector_Vector_cf coeff->
- let c = format_coupling coeff c in
- begin match fusion with
- | (F23|F32) -> printf "tphi_vv_cf(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | (F12|F13) -> printf "v_tphiv_cf(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | (F21|F31) -> printf "v_tphiv_cf(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- end
-
- | TensorScalar_Scalar_Scalar coeff->
- let c = format_coupling coeff c in
- begin match fusion with
- | (F23|F32) -> printf "tphi_ss(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | (F12|F13) -> printf "s_tphis(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | (F21|F31) -> printf "s_tphis(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- end
-
- | TensorScalar_Scalar_Scalar_cf coeff->
- let c = format_coupling coeff c in
- begin match fusion with
- | (F23|F32) -> printf "tphi_ss_cf(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | (F12|F13) -> printf "s_tphis_cf(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | (F21|F31) -> printf "s_tphis_cf(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- end
-
- | Dim7_Tensor_2_Vector_Vector_T coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F23 -> printf "t2_vv_d7(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F32 -> printf "t2_vv_d7(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- | (F12|F13) -> printf "v_t2v_d7(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | (F21|F31) -> printf "v_t2v_d7(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- end
-
- | Dim6_Scalar_Vector_Vector_D coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | (F23|F32) -> printf "s_vv_6D(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | (F12|F13) -> printf "v_sv_6D(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | (F21|F31) -> printf "v_sv_6D(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- end
-
- | Dim6_Scalar_Vector_Vector_DP coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | (F23|F32) -> printf "s_vv_6DP(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | (F12|F13) -> printf "v_sv_6DP(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | (F21|F31) -> printf "v_sv_6DP(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- end
-
- | Dim6_HAZ_D coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F23 -> printf "h_az_D(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F32 -> printf "h_az_D(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- | F13 -> printf "a_hz_D(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F31 -> printf "a_hz_D(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- | F12 -> printf "z_ah_D(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- | F21 -> printf "z_ah_D(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- end
- | Dim6_HAZ_DP coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F23 -> printf "h_az_DP(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F32 -> printf "h_az_DP(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- | F13 -> printf "a_hz_DP(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F31 -> printf "a_hz_DP(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- | F12 -> printf "z_ah_DP(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- | F21 -> printf "z_ah_DP(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- end
- | Gauge_Gauge_Gauge_i coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F23 -> printf "g_gg_23(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F32 -> printf "g_gg_23(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- | F13 -> printf "g_gg_13(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F31 -> printf "g_gg_13(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- | F12 -> printf "(-1) * g_gg_13(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F21 -> printf "(-1) * g_gg_13(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- end
-
- | Dim6_GGG coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F23 -> printf "g_gg_6(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F32 -> printf "g_gg_6(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- | F12 -> printf "g_gg_6(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F21 -> printf "g_gg_6(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- | F13 -> printf "(-1) * g_gg_6(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F31 -> printf "(-1) * g_gg_6(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- end
-
- | Dim6_AWW_DP coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F23 -> printf "a_ww_DP(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F32 -> printf "a_ww_DP(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- | F13 -> printf "w_aw_DP(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F31 -> printf "w_aw_DP(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- | F12 -> printf "(-1) * w_aw_DP(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F21 -> printf "(-1) * w_aw_DP(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- end
-
- | Dim6_AWW_DW coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F23 -> printf "a_ww_DW(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F32 -> printf "a_ww_DW(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- | F13 -> printf "(-1) * a_ww_DW(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F31 -> printf "(-1) * a_ww_DW(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- | F12 -> printf "a_ww_DW(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F21 -> printf "a_ww_DW(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- end
-
- | Dim6_Gauge_Gauge_Gauge_i coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F23 | F31 | F12 ->
- printf "kg_kgkg_i(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F32 | F13 | F21 ->
- printf "kg_kgkg_i(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- end
-
- | Dim6_HHH coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | (F23|F32|F12|F21|F13|F31) ->
- printf "h_hh_6(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- end
-
- | Dim6_WWZ_DPWDW coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F23 -> printf "w_wz_DPW(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F32 -> printf "w_wz_DPW(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- | F13 -> printf "(-1) * w_wz_DPW(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F31 -> printf "(-1) * w_wz_DPW(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- | F12 -> printf "z_ww_DPW(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F21 -> printf "z_ww_DPW(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- end
- | Dim6_WWZ_DW coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F23 -> printf "w_wz_DW(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F32 -> printf "w_wz_DW(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- | F13 -> printf "(-1) * w_wz_DW(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F31 -> printf "(-1) * w_wz_DW(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- | F12 -> printf "z_ww_DW(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F21 -> printf "z_ww_DW(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- end
- | Dim6_WWZ_D coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F23 -> printf "w_wz_D(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F32 -> printf "w_wz_D(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- | F13 -> printf "(-1) * w_wz_D(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F31 -> printf "(-1) * w_wz_D(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- | F12 -> printf "z_ww_D(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | F21 -> printf "z_ww_D(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- end
-
-(*i
- | Dim6_Glu_Glu_Glu coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | (F23|F31|F12) ->
- printf "g_gg_glu(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
- | (F32|F13|F21) ->
- printf "g_gg_glu(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
- end
-i*)
-
- end
-
-(* Flip the sign to account for the~$\mathrm{i}^2$ relative to diagrams
- with only cubic couplings.
- \label{hack:sign(V4)} *)
-(* \begin{dubious}
- That's an \emph{slightly dangerous} hack!!! How do we accnount
- for such signs when treating $n$-ary vertices uniformly?
- \end{dubious} *)
-
- | V4 (vertex, fusion, constant) ->
- let c = CM.constant_symbol constant
- and ch1, ch2, ch3 = children3 rhs in
- let wf1 = multiple_variable amplitude dictionary ch1
- and wf2 = multiple_variable amplitude dictionary ch2
- and wf3 = multiple_variable amplitude dictionary ch3
- and p1 = momentum ch1
- and p2 = momentum ch2
- and p3 = momentum ch3 in
- printf "@, %s " (if (F.sign rhs) < 0 then "+" else "-");
- begin match vertex with
- | Scalar4 coeff ->
- printf "(%s*%s*%s*%s)" (format_coupling coeff c) wf1 wf2 wf3
- | Scalar2_Vector2 coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F134 | F143 | F234 | F243 ->
- printf "%s*%s*(%s*%s)" c wf1 wf2 wf3
- | F314 | F413 | F324 | F423 ->
- printf "%s*%s*(%s*%s)" c wf2 wf1 wf3
- | F341 | F431 | F342 | F432 ->
- printf "%s*%s*(%s*%s)" c wf3 wf1 wf2
- | F312 | F321 | F412 | F421 ->
- printf "(%s*%s*%s)*%s" c wf2 wf3 wf1
- | F231 | F132 | F241 | F142 ->
- printf "(%s*%s*%s)*%s" c wf1 wf3 wf2
- | F123 | F213 | F124 | F214 ->
- printf "(%s*%s*%s)*%s" c wf1 wf2 wf3
- end
- | Vector4 contractions ->
- begin match contractions with
- | [] -> invalid_arg "Targets.print_current: Vector4 []"
- | head :: tail ->
- printf "(";
- print_vector4 c wf1 wf2 wf3 fusion head;
- List.iter (print_add_vector4 c wf1 wf2 wf3 fusion) tail;
- printf ")"
- end
- | Dim8_Vector4_t_0 contractions ->
- begin match contractions with
- | [] -> invalid_arg "Targets.print_current: Vector4 []"
- | head :: tail ->
- print_vector4_t_0 c wf1 p1 wf2 p2 wf3 p3 fusion head;
- List.iter (print_add_vector4 c wf1 wf2 wf3 fusion) tail;
- end
- | Dim8_Vector4_t_1 contractions ->
- begin match contractions with
- | [] -> invalid_arg "Targets.print_current: Vector4 []"
- | head :: tail ->
- print_vector4_t_1 c wf1 p1 wf2 p2 wf3 p3 fusion head;
- List.iter (print_add_vector4 c wf1 wf2 wf3 fusion) tail;
- end
- | Dim8_Vector4_t_2 contractions ->
- begin match contractions with
- | [] -> invalid_arg "Targets.print_current: Vector4 []"
- | head :: tail ->
- print_vector4_t_2 c wf1 p1 wf2 p2 wf3 p3 fusion head;
- List.iter (print_add_vector4 c wf1 wf2 wf3 fusion) tail;
- end
- | Dim8_Vector4_m_0 contractions ->
- begin match contractions with
- | [] -> invalid_arg "Targets.print_current: Vector4 []"
- | head :: tail ->
- print_vector4_m_0 c wf1 p1 wf2 p2 wf3 p3 fusion head;
- List.iter (print_add_vector4 c wf1 wf2 wf3 fusion) tail;
- end
- | Dim8_Vector4_m_1 contractions ->
- begin match contractions with
- | [] -> invalid_arg "Targets.print_current: Vector4 []"
- | head :: tail ->
- print_vector4_m_1 c wf1 p1 wf2 p2 wf3 p3 fusion head;
- List.iter (print_add_vector4 c wf1 wf2 wf3 fusion) tail;
- end
- | Dim8_Vector4_m_7 contractions ->
- begin match contractions with
- | [] -> invalid_arg "Targets.print_current: Vector4 []"
- | head :: tail ->
- print_vector4_m_7 c wf1 p1 wf2 p2 wf3 p3 fusion head;
- List.iter (print_add_vector4 c wf1 wf2 wf3 fusion) tail;
- end
- | Vector4_K_Matrix_tho (_, poles) ->
- let pa, pb =
- begin match fusion with
- | (F341|F431|F342|F432|F123|F213|F124|F214) -> (p1, p2)
- | (F134|F143|F234|F243|F312|F321|F412|F421) -> (p2, p3)
- | (F314|F413|F324|F423|F132|F231|F142|F241) -> (p1, p3)
- end in
- printf "(%s*(%s*%s)*(%s*%s)*(%s*%s)@,*("
- c p1 wf1 p2 wf2 p3 wf3;
- List.iter (fun (coeff, pole) ->
- printf "+%s/((%s+%s)*(%s+%s)-%s)"
- (CM.constant_symbol coeff) pa pb pa pb
- (CM.constant_symbol pole))
- poles;
- printf ")*(-%s-%s-%s))" p1 p2 p3
- | Vector4_K_Matrix_jr (disc, contractions) ->
- let pa, pb =
- begin match disc, fusion with
- | 3, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
- | 3, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
- | 3, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
- | _, (F341|F431|F342|F432|F123|F213|F124|F214) -> (p1, p2)
- | _, (F134|F143|F234|F243|F312|F321|F412|F421) -> (p2, p3)
- | _, (F314|F413|F324|F423|F132|F231|F142|F241) -> (p1, p3)
- end in
- begin match contractions with
- | [] -> invalid_arg "Targets.print_current: Vector4_K_Matrix_jr []"
- | head :: tail ->
- printf "(";
- print_vector4_km c pa pb wf1 wf2 wf3 fusion head;
- List.iter (print_add_vector4_km c pa pb wf1 wf2 wf3 fusion)
- tail;
- printf ")"
- end
- | Vector4_K_Matrix_cf_t0 (disc, contractions) ->
- let pa, pb, pc =
- begin match disc, fusion with
- | 3, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2, p3)
- | 3, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3, p1)
- | 3, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3, p2)
- | _, (F341|F431|F342|F432|F123|F213|F124|F214) -> (p1, p2, p3)
- | _, (F134|F143|F234|F243|F312|F321|F412|F421) -> (p2, p3, p1)
- | _, (F314|F413|F324|F423|F132|F231|F142|F241) -> (p1, p3, p2)
- end in
- begin match contractions with
- | [] -> invalid_arg "Targets.print_current: Vector4_K_Matrix_cf_t0 []"
- | head :: tail ->
- printf "(";
- print_vector4_km_t_0 c pa pb wf1 p1 wf2 p2 wf3 p3 fusion head;
- List.iter (print_add_vector4_km c pa pb wf1 wf2 wf3 fusion)
- tail;
- printf ")"
- end
- | Vector4_K_Matrix_cf_t1 (disc, contractions) ->
- let pa, pb =
- begin match disc, fusion with
- | 3, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
- | 3, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
- | 3, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
- | _, (F341|F431|F342|F432|F123|F213|F124|F214) -> (p1, p2)
- | _, (F134|F143|F234|F243|F312|F321|F412|F421) -> (p2, p3)
- | _, (F314|F413|F324|F423|F132|F231|F142|F241) -> (p1, p3)
- end in
- begin match contractions with
- | [] -> invalid_arg "Targets.print_current: Vector4_K_Matrix_cf_t1 []"
- | head :: tail ->
- printf "(";
- print_vector4_km_t_1 c pa pb wf1 p1 wf2 p2 wf3 p3 fusion head;
- List.iter (print_add_vector4_km c pa pb wf1 wf2 wf3 fusion)
- tail;
- printf ")"
- end
- | Vector4_K_Matrix_cf_t2 (disc, contractions) ->
- let pa, pb =
- begin match disc, fusion with
- | 3, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
- | 3, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
- | 3, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
- | _, (F341|F431|F342|F432|F123|F213|F124|F214) -> (p1, p2)
- | _, (F134|F143|F234|F243|F312|F321|F412|F421) -> (p2, p3)
- | _, (F314|F413|F324|F423|F132|F231|F142|F241) -> (p1, p3)
- end in
- begin match contractions with
- | [] -> invalid_arg "Targets.print_current: Vector4_K_Matrix_cf_t2 []"
- | head :: tail ->
- printf "(";
- print_vector4_km_t_2 c pa pb wf1 p1 wf2 p2 wf3 p3 fusion head;
- List.iter (print_add_vector4_km c pa pb wf1 wf2 wf3 fusion)
- tail;
- printf ")"
- end
- | Vector4_K_Matrix_cf_t_rsi (disc, contractions) ->
- let pa, pb, pc =
- begin match disc, fusion with
- | 3, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2, p3)
- | 3, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3, p1)
- | 3, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3, p2)
- | _, (F341|F431|F342|F432|F123|F213|F124|F214) -> (p1, p2, p3)
- | _, (F134|F143|F234|F243|F312|F321|F412|F421) -> (p2, p3, p1)
- | _, (F314|F413|F324|F423|F132|F231|F142|F241) -> (p1, p3, p2)
- end in
- begin match contractions with
- | [] -> invalid_arg "Targets.print_current: Vector4_K_Matrix_cf_t_rsi []"
- | head :: tail ->
- printf "(";
- print_vector4_km_t_rsi c pa pb pc wf1 p1 wf2 p2 wf3 p3 fusion head;
- List.iter (print_add_vector4_km c pa pb wf1 wf2 wf3 fusion)
- tail;
- printf ")"
- end
- | Vector4_K_Matrix_cf_m0 (disc, contractions) ->
- let pa, pb =
- begin match disc, fusion with
- | 3, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
- | 3, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
- | 3, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
- | _, (F341|F431|F342|F432|F123|F213|F124|F214) -> (p1, p2)
- | _, (F134|F143|F234|F243|F312|F321|F412|F421) -> (p2, p3)
- | _, (F314|F413|F324|F423|F132|F231|F142|F241) -> (p1, p3)
- end in
- begin match contractions with
- | [] -> invalid_arg "Targets.print_current: Vector4_K_Matrix_cf_m0 []"
- | head :: tail ->
- printf "(";
- print_vector4_km_m_0 c pa pb wf1 p1 wf2 p2 wf3 p3 fusion head;
- List.iter (print_add_vector4_km c pa pb wf1 wf2 wf3 fusion)
- tail;
- printf ")"
- end
- | Vector4_K_Matrix_cf_m1 (disc, contractions) ->
- let pa, pb =
- begin match disc, fusion with
- | 3, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
- | 3, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
- | 3, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
- | _, (F341|F431|F342|F432|F123|F213|F124|F214) -> (p1, p2)
- | _, (F134|F143|F234|F243|F312|F321|F412|F421) -> (p2, p3)
- | _, (F314|F413|F324|F423|F132|F231|F142|F241) -> (p1, p3)
- end in
- begin match contractions with
- | [] -> invalid_arg "Targets.print_current: Vector4_K_Matrix_cf_m1 []"
- | head :: tail ->
- printf "(";
- print_vector4_km_m_1 c pa pb wf1 p1 wf2 p2 wf3 p3 fusion head;
- List.iter (print_add_vector4_km c pa pb wf1 wf2 wf3 fusion)
- tail;
- printf ")"
- end
- | Vector4_K_Matrix_cf_m7 (disc, contractions) ->
- let pa, pb =
- begin match disc, fusion with
- | 3, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
- | 3, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
- | 3, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
- | _, (F341|F431|F342|F432|F123|F213|F124|F214) -> (p1, p2)
- | _, (F134|F143|F234|F243|F312|F321|F412|F421) -> (p2, p3)
- | _, (F314|F413|F324|F423|F132|F231|F142|F241) -> (p1, p3)
- end in
- begin match contractions with
- | [] -> invalid_arg "Targets.print_current: Vector4_K_Matrix_cf_m7 []"
- | head :: tail ->
- printf "(";
- print_vector4_km_m_7 c pa pb wf1 p1 wf2 p2 wf3 p3 fusion head;
- List.iter (print_add_vector4_km c pa pb wf1 wf2 wf3 fusion)
- tail;
- printf ")"
- end
- | DScalar2_Vector2_K_Matrix_ms (disc, contractions) ->
- let p123 = Printf.sprintf "(-%s-%s-%s)" p1 p2 p3 in
- let pa, pb =
- begin match disc, fusion with
- | 3, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
- | 3, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
- | 3, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
- | 4, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
- | 4, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
- | 4, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
- | 5, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
- | 5, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
- | 5, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
- | 6, (F134|F132|F314|F312|F241|F243|F421|F423) -> (p1, p2)
- | 6, (F213|F413|F231|F431|F124|F324|F142|F342) -> (p2, p3)
- | 6, (F143|F123|F341|F321|F412|F214|F432|F234) -> (p1, p3)
- | 7, (F134|F132|F314|F312|F241|F243|F421|F423) -> (p1, p2)
- | 7, (F213|F413|F231|F431|F124|F324|F142|F342) -> (p2, p3)
- | 7, (F143|F123|F341|F321|F412|F214|F432|F234) -> (p1, p3)
- | 8, (F134|F132|F314|F312|F241|F243|F421|F423) -> (p1, p2)
- | 8, (F213|F413|F231|F431|F124|F324|F142|F342) -> (p2, p3)
- | 8, (F143|F123|F341|F321|F412|F214|F432|F234) -> (p1, p3)
- | _, (F341|F431|F342|F432|F123|F213|F124|F214) -> (p1, p2)
- | _, (F134|F143|F234|F243|F312|F321|F412|F421) -> (p2, p3)
- | _, (F314|F413|F324|F423|F132|F231|F142|F241) -> (p1, p3)
- end in
- begin match contractions with
- | [] -> invalid_arg "Targets.print_current: DScalar2_Vector4_K_Matrix_ms []"
- | head :: tail ->
- printf "(";
- print_dscalar2_vector2_km
- c pa pb wf1 wf2 wf3 p1 p2 p3 p123 fusion head;
- List.iter (print_add_dscalar2_vector2_km
- c pa pb wf1 wf2 wf3 p1 p2 p3 p123 fusion)
- tail;
- printf ")"
- end
- | DScalar2_Vector2_m_0_K_Matrix_cf (disc, contractions) ->
- let pa, pb =
- begin match disc, fusion with
- | 3, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
- | 3, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
- | 3, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
- | 4, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
- | 4, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
- | 4, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
- | 5, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
- | 5, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
- | 5, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
- | 6, (F134|F132|F314|F312|F241|F243|F421|F423) -> (p1, p2)
- | 6, (F213|F413|F231|F431|F124|F324|F142|F342) -> (p2, p3)
- | 6, (F143|F123|F341|F321|F412|F214|F432|F234) -> (p1, p3)
- | 7, (F134|F132|F314|F312|F241|F243|F421|F423) -> (p1, p2)
- | 7, (F213|F413|F231|F431|F124|F324|F142|F342) -> (p2, p3)
- | 7, (F143|F123|F341|F321|F412|F214|F432|F234) -> (p1, p3)
- | 8, (F134|F132|F314|F312|F241|F243|F421|F423) -> (p1, p2)
- | 8, (F213|F413|F231|F431|F124|F324|F142|F342) -> (p2, p3)
- | 8, (F143|F123|F341|F321|F412|F214|F432|F234) -> (p1, p3)
- | _, (F341|F431|F342|F432|F123|F213|F124|F214) -> (p1, p2)
- | _, (F134|F143|F234|F243|F312|F321|F412|F421) -> (p2, p3)
- | _, (F314|F413|F324|F423|F132|F231|F142|F241) -> (p1, p3)
- end in
- begin match contractions with
- | [] -> invalid_arg "Targets.print_current: DScalar2_Vector4_K_Matrix_cf_m0 []"
- | head :: tail ->
- printf "(";
- print_dscalar2_vector2_m_0_km
- c pa pb wf1 wf2 wf3 p1 p2 p3 fusion head;
- List.iter (print_add_dscalar2_vector2_m_0_km
- c pa pb wf1 wf2 wf3 p1 p2 p3 fusion)
- tail;
- printf ")"
- end
- | DScalar2_Vector2_m_1_K_Matrix_cf (disc, contractions) ->
- let pa, pb =
- begin match disc, fusion with
- | 3, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
- | 3, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
- | 3, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
- | 4, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
- | 4, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
- | 4, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
- | 5, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
- | 5, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
- | 5, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
- | 6, (F134|F132|F314|F312|F241|F243|F421|F423) -> (p1, p2)
- | 6, (F213|F413|F231|F431|F124|F324|F142|F342) -> (p2, p3)
- | 6, (F143|F123|F341|F321|F412|F214|F432|F234) -> (p1, p3)
- | 7, (F134|F132|F314|F312|F241|F243|F421|F423) -> (p1, p2)
- | 7, (F213|F413|F231|F431|F124|F324|F142|F342) -> (p2, p3)
- | 7, (F143|F123|F341|F321|F412|F214|F432|F234) -> (p1, p3)
- | 8, (F134|F132|F314|F312|F241|F243|F421|F423) -> (p1, p2)
- | 8, (F213|F413|F231|F431|F124|F324|F142|F342) -> (p2, p3)
- | 8, (F143|F123|F341|F321|F412|F214|F432|F234) -> (p1, p3)
- | _, (F341|F431|F342|F432|F123|F213|F124|F214) -> (p1, p2)
- | _, (F134|F143|F234|F243|F312|F321|F412|F421) -> (p2, p3)
- | _, (F314|F413|F324|F423|F132|F231|F142|F241) -> (p1, p3)
- end in
- begin match contractions with
- | [] -> invalid_arg "Targets.print_current: DScalar2_Vector4_K_Matrix_cf_m1 []"
- | head :: tail ->
- printf "(";
- print_dscalar2_vector2_m_1_km
- c pa pb wf1 wf2 wf3 p1 p2 p3 fusion head;
- List.iter (print_add_dscalar2_vector2_m_1_km
- c pa pb wf1 wf2 wf3 p1 p2 p3 fusion)
- tail;
- printf ")"
- end
- | DScalar2_Vector2_m_7_K_Matrix_cf (disc, contractions) ->
- let pa, pb =
- begin match disc, fusion with
- | 3, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
- | 3, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
- | 3, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
- | 4, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
- | 4, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
- | 4, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
- | 5, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
- | 5, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
- | 5, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
- | 6, (F134|F132|F314|F312|F241|F243|F421|F423) -> (p1, p2)
- | 6, (F213|F413|F231|F431|F124|F324|F142|F342) -> (p2, p3)
- | 6, (F143|F123|F341|F321|F412|F214|F432|F234) -> (p1, p3)
- | 7, (F134|F132|F314|F312|F241|F243|F421|F423) -> (p1, p2)
- | 7, (F213|F413|F231|F431|F124|F324|F142|F342) -> (p2, p3)
- | 7, (F143|F123|F341|F321|F412|F214|F432|F234) -> (p1, p3)
- | 8, (F134|F132|F314|F312|F241|F243|F421|F423) -> (p1, p2)
- | 8, (F213|F413|F231|F431|F124|F324|F142|F342) -> (p2, p3)
- | 8, (F143|F123|F341|F321|F412|F214|F432|F234) -> (p1, p3)
- | _, (F341|F431|F342|F432|F123|F213|F124|F214) -> (p1, p2)
- | _, (F134|F143|F234|F243|F312|F321|F412|F421) -> (p2, p3)
- | _, (F314|F413|F324|F423|F132|F231|F142|F241) -> (p1, p3)
- end in
- begin match contractions with
- | [] -> invalid_arg "Targets.print_current: DScalar2_Vector4_K_Matrix_cf_m7 []"
- | head :: tail ->
- printf "(";
- print_dscalar2_vector2_m_7_km
- c pa pb wf1 wf2 wf3 p1 p2 p3 fusion head;
- List.iter (print_add_dscalar2_vector2_m_7_km
- c pa pb wf1 wf2 wf3 p1 p2 p3 fusion)
- tail;
- printf ")"
- end
- | DScalar4_K_Matrix_ms (disc, contractions) ->
- let p123 = Printf.sprintf "(-%s-%s-%s)" p1 p2 p3 in
- let pa, pb =
- begin match disc, fusion with
- | 3, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
- | 3, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
- | 3, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
- | _, (F341|F431|F342|F432|F123|F213|F124|F214) -> (p1, p2)
- | _, (F134|F143|F234|F243|F312|F321|F412|F421) -> (p2, p3)
- | _, (F314|F413|F324|F423|F132|F231|F142|F241) -> (p1, p3)
- end in
- begin match contractions with
- | [] -> invalid_arg "Targets.print_current: DScalar4_K_Matrix_ms []"
- | head :: tail ->
- printf "(";
- print_dscalar4_km
- c pa pb wf1 wf2 wf3 p1 p2 p3 p123 fusion head;
- List.iter (print_add_dscalar4_km
- c pa pb wf1 wf2 wf3 p1 p2 p3 p123 fusion)
- tail;
- printf ")"
- end
- | Dim8_Scalar2_Vector2_1 coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F134 | F143 | F234 | F243 ->
- printf "phi_phi2v_1(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F314 | F413 | F324 | F423 ->
- printf "phi_phi2v_1(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F341 | F431 | F342 | F432 ->
- printf "phi_phi2v_1(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F312 | F321 | F412 | F421 ->
- printf "v_phi2v_1(%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1
- | F231 | F132 | F241 | F142 ->
- printf "v_phi2v_1(%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2
- | F123 | F213 | F124 | F214 ->
- printf "v_phi2v_1(%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3
- end
- | Dim8_Scalar2_Vector2_2 coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F134 | F143 | F234 | F243 ->
- printf "phi_phi2v_2(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F314 | F413 | F324 | F423 ->
- printf "phi_phi2v_2(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F341 | F431 | F342 | F432 ->
- printf "phi_phi2v_2(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F312 | F321 | F412 | F421 ->
- printf "v_phi2v_2(%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1
- | F231 | F132 | F241 | F142 ->
- printf "v_phi2v_2(%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2
- | F123 | F213 | F124 | F214 ->
- printf "v_phi2v_2(%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3
- end
- | Dim8_Scalar2_Vector2_m_0 coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F134 | F143 | F234 | F243 ->
- printf "phi_phi2v_m_0(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F314 | F413 | F324 | F423 ->
- printf "phi_phi2v_m_0(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F341 | F431 | F342 | F432 ->
- printf "phi_phi2v_m_0(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F312 | F321 | F412 | F421 ->
- printf "v_phi2v_m_0(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F231 | F132 | F241 | F142 ->
- printf "v_phi2v_m_0(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F123 | F213 | F124 | F214 ->
- printf "v_phi2v_m_0(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- end
- | Dim8_Scalar2_Vector2_m_1 coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F134 | F143 | F234 | F243 ->
- printf "phi_phi2v_m_1(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F314 | F413 | F324 | F423 ->
- printf "phi_phi2v_m_1(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F341 | F431 | F342 | F432 ->
- printf "phi_phi2v_m_1(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F312 | F321 | F412 | F421 ->
- printf "v_phi2v_m_1(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F231 | F132 | F241 | F142 ->
- printf "v_phi2v_m_1(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F123 | F213 | F124 | F214 ->
- printf "v_phi2v_m_1(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- end
- | Dim8_Scalar2_Vector2_m_7 coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F134 | F143 | F234 | F243 ->
- printf "phi_phi2v_m_7(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F314 | F413 | F324 | F423 ->
- printf "phi_phi2v_m_7(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F341 | F431 | F342 | F432 ->
- printf "phi_phi2v_m_7(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F312 | F321 | F412 | F421 ->
- printf "v_phi2v_m_7(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F231 | F132 | F241 | F142 ->
- printf "v_phi2v_m_7(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F123 | F213 | F124 | F214 ->
- printf "v_phi2v_m_7(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- end
- | Dim8_Scalar4 coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F134 | F143 | F234 | F243 | F314 | F413 | F324 | F423
- | F341 | F431 | F342 | F432 | F312 | F321 | F412 | F421
- | F231 | F132 | F241 | F142 | F123 | F213 | F124 | F214 ->
- printf "s_dim8s3 (%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- end
- | GBBG (coeff, fb, b, f) ->
- Fermions.print_current_g4 (coeff, fb, b, f) c wf1 wf2 wf3
- fusion
-
- | Dim6_H4_P2 coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F134 | F143 | F234 | F243 | F314 | F413 | F324 | F423
- | F341 | F431 | F342 | F432 | F312 | F321 | F412 | F421
- | F231 | F132 | F241 | F142 | F123 | F213 | F124 | F214 ->
- printf "hhhh_p2 (%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- end
- | Dim6_AHWW_DPB coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F234 ->
- printf "a_hww_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F243 ->
- printf "a_hww_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F342 ->
- printf "a_hww_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F324 ->
- printf "a_hww_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F423 ->
- printf "a_hww_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F432 ->
- printf "a_hww_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F134 ->
- printf "h_aww_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F143 ->
- printf "h_aww_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F341 ->
- printf "h_aww_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F314 ->
- printf "h_aww_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F413 ->
- printf "h_aww_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F431 ->
- printf "h_aww_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F124 ->
- printf "w_ahw_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F142 ->
- printf "w_ahw_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F241 ->
- printf "w_ahw_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F214 ->
- printf "w_ahw_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F412 ->
- printf "w_ahw_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F421 ->
- printf "w_ahw_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F123 ->
- printf "(-1)*w_ahw_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F132 ->
- printf "(-1)*w_ahw_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F231 ->
- printf "(-1)*w_ahw_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F213 ->
- printf "(-1)*w_ahw_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F312 ->
- printf "(-1)*w_ahw_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F321 ->
- printf "(-1)*w_ahw_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- end
- | Dim6_AHWW_DPW coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F234 ->
- printf "a_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F243 ->
- printf "a_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F342 ->
- printf "a_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F324 ->
- printf "a_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F423 ->
- printf "a_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F432 ->
- printf "a_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F134 ->
- printf "h_aww_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F143 ->
- printf "h_aww_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F341 ->
- printf "h_aww_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F314 ->
- printf "h_aww_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F413 ->
- printf "h_aww_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F431 ->
- printf "h_aww_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F124 ->
- printf "w_ahw_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F142 ->
- printf "w_ahw_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F241 ->
- printf "w_ahw_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F214 ->
- printf "w_ahw_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F412 ->
- printf "w_ahw_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F421 ->
- printf "w_ahw_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F123 ->
- printf "(-1)*w_ahw_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F132 ->
- printf "(-1)*w_ahw_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F231 ->
- printf "(-1)*w_ahw_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F213 ->
- printf "(-1)*w_ahw_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F312 ->
- printf "(-1)*w_ahw_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F321 ->
- printf "(-1)*w_ahw_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- end
- | Dim6_AHWW_DW coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F234 ->
- printf "a_hww_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F243 ->
- printf "a_hww_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F342 ->
- printf "a_hww_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F324 ->
- printf "a_hww_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F423 ->
- printf "a_hww_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F432 ->
- printf "a_hww_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F134 ->
- printf "h_aww_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F143 ->
- printf "h_aww_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F341 ->
- printf "h_aww_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F314 ->
- printf "h_aww_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F413 ->
- printf "h_aww_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F431 ->
- printf "h_aww_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F124 ->
- printf "w3_ahw_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F142 ->
- printf "w3_ahw_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F241 ->
- printf "w3_ahw_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F214 ->
- printf "w3_ahw_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F412 ->
- printf "w3_ahw_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F421 ->
- printf "w3_ahw_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F123 ->
- printf "w4_ahw_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F132 ->
- printf "w4_ahw_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F231 ->
- printf "w4_ahw_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F213 ->
- printf "w4_ahw_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F312 ->
- printf "w4_ahw_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F321 ->
- printf "w4_ahw_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
-(*i | F234 | F134 | F124 | F123 ->
- printf "a_hww_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F243 | F143 | F142 | F132 ->
- printf "a_hww_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F342 | F341 | F241 | F231 ->
- printf "a_hww_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F324 | F314 | F214 | F213 ->
- printf "a_hww_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F423 | F413 | F412 | F312 ->
- printf "a_hww_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F432 | F431 | F421 | F321 ->
- printf "a_hww_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1 i*)
- end
- | Dim6_Scalar2_Vector2_D coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F234 | F134 ->
- printf "h_hww_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F243 | F143 ->
- printf "h_hww_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F342 | F341 ->
- printf "h_hww_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F324 | F314 ->
- printf "h_hww_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F423 | F413 ->
- printf "h_hww_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F432 | F431 ->
- printf "h_hww_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F124 | F123 ->
- printf "w_hhw_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F142 | F132 ->
- printf "w_hhw_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F241 | F231 ->
- printf "w_hhw_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F214 | F213 ->
- printf "w_hhw_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F412 | F312 ->
- printf "w_hhw_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F421 | F321 ->
- printf "w_hhw_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- end
- | Dim6_Scalar2_Vector2_DP coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F234 | F134 ->
- printf "h_hww_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F342 | F341 ->
- printf "h_hww_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F423 | F413 ->
- printf "h_hww_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F243 | F143 ->
- printf "h_hww_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F324 | F314 ->
- printf "h_hww_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F432 | F431 ->
- printf "h_hww_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F123 | F124 ->
- printf "w_hhw_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F231 | F241->
- printf "w_hhw_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F312 | F412 ->
- printf "w_hhw_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F132 | F142->
- printf "w_hhw_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F213 | F214 ->
- printf "w_hhw_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F321 | F421 ->
- printf "w_hhw_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
-(*i | F234 ->
- printf "h_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F243 ->
- printf "h_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F342 ->
- printf "h_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F324 ->
- printf "h_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F423 ->
- printf "h_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F432 ->
- printf "h_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F124 ->
- printf "w_hhw_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F142 ->
- printf "w_hhw_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F241 ->
- printf "w_hhw_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F214 ->
- printf "w_hhw_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F412 ->
- printf "w_hhw_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F421 ->
- printf "w_hhw_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F134 ->
- printf "h_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F143 ->
- printf "h_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F341 ->
- printf "h_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F314 ->
- printf "h_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F413 ->
- printf "h_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F431 ->
- printf "h_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F123 ->
- printf "w_hhw_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F132 ->
- printf "w_hhw_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F231 ->
- printf "w_hhw_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F213 ->
- printf "w_hhw_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F312 ->
- printf "w_hhw_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F321 ->
- printf "w_hhw_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1 i*)
- end
- | Dim6_Scalar2_Vector2_PB coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F234 | F134 ->
- printf "h_hvv_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F342 | F341 ->
- printf "h_hvv_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F423 | F413 ->
- printf "h_hvv_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F243 | F143 ->
- printf "h_hvv_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F324 | F314 ->
- printf "h_hvv_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F432 | F431 ->
- printf "h_hvv_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F123 | F124 ->
- printf "v_hhv_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F231 | F241->
- printf "v_hhv_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F312 | F412 ->
- printf "v_hhv_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F132 | F142->
- printf "v_hhv_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F213 | F214 ->
- printf "v_hhv_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F321 | F421 ->
- printf "v_hhv_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- end
-
- | Dim6_HHZZ_T coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F234 | F134 ->
- printf "(%s)*(%s)*(%s)*(%s)" c wf1 wf2 wf3
- | F342 | F341 ->
- printf "(%s)*(%s)*(%s)*(%s)" c wf3 wf1 wf2
- | F423 | F413 ->
- printf "(%s)*(%s)*(%s)*(%s)" c wf2 wf3 wf1
- | F243 | F143 ->
- printf "(%s)*(%s)*(%s)*(%s)" c wf1 wf3 wf2
- | F324 | F314 ->
- printf "(%s)*(%s)*(%s)*(%s)" c wf2 wf1 wf3
- | F432 | F431 ->
- printf "(%s)*(%s)*(%s)*(%s)" c wf3 wf2 wf1
- | F123 | F124 | F231 | F241 | F312 | F412 ->
- printf "(%s)*(%s)*(%s)*(%s)" c wf1 wf2 wf3
- | F132 | F142 | F213 | F214 | F321 | F421 ->
- printf "(%s)*(%s)*(%s)*(%s)" c wf1 wf2 wf3
- end
- | Dim6_Vector4_DW coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F234 | F134 ->
- printf "a_aww_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F342 | F341 ->
- printf "a_aww_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F423 | F413 ->
- printf "a_aww_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F243 | F143 ->
- printf "a_aww_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F324 | F314 ->
- printf "a_aww_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F432 | F431 ->
- printf "a_aww_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F124 | F123 ->
- printf "w_aaw_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F241 | F231 ->
- printf "w_aaw_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F412 | F312 ->
- printf "w_aaw_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F142 | F132 ->
- printf "w_aaw_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F214 | F213 ->
- printf "w_aaw_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F421 | F321 ->
- printf "w_aaw_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- end
- | Dim6_Vector4_W coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F234 | F134 ->
- printf "a_aww_W(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F342 | F341 ->
- printf "a_aww_W(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F423 | F413 ->
- printf "a_aww_W(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F243 | F143 ->
- printf "a_aww_W(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F324 | F314 ->
- printf "a_aww_W(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F432 | F431 ->
- printf "a_aww_W(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F123 | F124 ->
- printf "w_aaw_W(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F231 | F241->
- printf "w_aaw_W(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F312 | F412 ->
- printf "w_aaw_W(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F132 | F142->
- printf "w_aaw_W(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F213 | F214 ->
- printf "w_aaw_W(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F321 | F421 ->
- printf "w_aaw_W(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- end
- | Dim6_HWWZ_DW coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F234 ->
- printf "h_wwz_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F243 ->
- printf "h_wwz_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F342 ->
- printf "h_wwz_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F324 ->
- printf "h_wwz_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F423 ->
- printf "h_wwz_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F432 ->
- printf "h_wwz_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F124 ->
- printf "(-1)*w_hwz_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F142 ->
- printf "(-1)*w_hwz_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F241 ->
- printf "(-1)*w_hwz_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F214 ->
- printf "(-1)*w_hwz_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F412 ->
- printf "(-1)*w_hwz_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F421 ->
- printf "(-1)*w_hwz_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F134 ->
- printf "w_hwz_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F143 ->
- printf "w_hwz_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F341 ->
- printf "w_hwz_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F314 ->
- printf "w_hwz_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F413 ->
- printf "w_hwz_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F431 ->
- printf "w_hwz_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F123 ->
- printf "z_hww_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F132 ->
- printf "z_hww_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F231 ->
- printf "z_hww_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F213 ->
- printf "z_hww_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F312 ->
- printf "z_hww_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F321 ->
- printf "z_hww_DW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- end
- | Dim6_HWWZ_DPB coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F234 ->
- printf "h_wwz_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F243 ->
- printf "h_wwz_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F342 ->
- printf "h_wwz_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F324 ->
- printf "h_wwz_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F423 ->
- printf "h_wwz_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F432 ->
- printf "h_wwz_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F124 ->
- printf "(-1)*w_hwz_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F142 ->
- printf "(-1)*w_hwz_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F241 ->
- printf "(-1)*w_hwz_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F214 ->
- printf "(-1)*w_hwz_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F412 ->
- printf "(-1)*w_hwz_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F421 ->
- printf "(-1)*w_hwz_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F134 ->
- printf "w_hwz_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F143 ->
- printf "w_hwz_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F341 ->
- printf "w_hwz_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F314 ->
- printf "w_hwz_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F413 ->
- printf "w_hwz_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F431 ->
- printf "w_hwz_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F123 ->
- printf "z_hww_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F132 ->
- printf "z_hww_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F231 ->
- printf "z_hww_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F213 ->
- printf "z_hww_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F312 ->
- printf "z_hww_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F321 ->
- printf "z_hww_DPB(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- end
- | Dim6_HWWZ_DDPW coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F234 ->
- printf "h_wwz_DDPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F243 ->
- printf "h_wwz_DDPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F342 ->
- printf "h_wwz_DDPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F324 ->
- printf "h_wwz_DDPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F423 ->
- printf "h_wwz_DDPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F432 ->
- printf "h_wwz_DDPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F124 ->
- printf "(-1)*w_hwz_DDPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F142 ->
- printf "(-1)*w_hwz_DDPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F241 ->
- printf "(-1)*w_hwz_DDPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F214 ->
- printf "(-1)*w_hwz_DDPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F412 ->
- printf "(-1)*w_hwz_DDPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F421 ->
- printf "(-1)*w_hwz_DDPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F134 ->
- printf "w_hwz_DDPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F143 ->
- printf "w_hwz_DDPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F341 ->
- printf "w_hwz_DDPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F314 ->
- printf "w_hwz_DDPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F413 ->
- printf "w_hwz_DDPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F431 ->
- printf "w_hwz_DDPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F123 ->
- printf "z_hww_DDPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F132 ->
- printf "z_hww_DDPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F231 ->
- printf "z_hww_DDPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F213 ->
- printf "z_hww_DDPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F312 ->
- printf "z_hww_DDPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F321 ->
- printf "z_hww_DDPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- end
- | Dim6_HWWZ_DPW coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F234 ->
- printf "h_wwz_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F243 ->
- printf "h_wwz_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F342 ->
- printf "h_wwz_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F324 ->
- printf "h_wwz_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F423 ->
- printf "h_wwz_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F432 ->
- printf "h_wwz_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F124 ->
- printf "(-1)*w_hwz_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F142 ->
- printf "(-1)*w_hwz_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F241 ->
- printf "(-1)*w_hwz_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F214 ->
- printf "(-1)*w_hwz_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F412 ->
- printf "(-1)*w_hwz_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F421 ->
- printf "(-1)*w_hwz_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F134 ->
- printf "w_hwz_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F143 ->
- printf "w_hwz_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F341 ->
- printf "w_hwz_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F314 ->
- printf "w_hwz_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F413 ->
- printf "w_hwz_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F431 ->
- printf "w_hwz_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F123 ->
- printf "z_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F132 ->
- printf "z_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F231 ->
- printf "z_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F213 ->
- printf "z_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F312 ->
- printf "z_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F321 ->
- printf "z_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- end
- | Dim6_AHHZ_D coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F234 ->
- printf "a_hhz_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F243 ->
- printf "a_hhz_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F342 ->
- printf "a_hhz_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F324 ->
- printf "a_hhz_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F423 ->
- printf "a_hhz_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F432 ->
- printf "a_hhz_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F124 ->
- printf "h_ahz_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F142 ->
- printf "h_ahz_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F241 ->
- printf "h_ahz_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F214 ->
- printf "h_ahz_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F412 ->
- printf "h_ahz_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F421 ->
- printf "h_ahz_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F134 ->
- printf "h_ahz_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F143 ->
- printf "h_ahz_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F341 ->
- printf "h_ahz_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F314 ->
- printf "h_ahz_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F413 ->
- printf "h_ahz_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F431 ->
- printf "h_ahz_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F123 ->
- printf "z_ahh_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F132 ->
- printf "z_ahh_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F231 ->
- printf "z_ahh_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F213 ->
- printf "z_ahh_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F312 ->
- printf "z_ahh_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F321 ->
- printf "z_ahh_D(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- end
- | Dim6_AHHZ_DP coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F234 ->
- printf "a_hhz_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F243 ->
- printf "a_hhz_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F342 ->
- printf "a_hhz_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F324 ->
- printf "a_hhz_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F423 ->
- printf "a_hhz_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F432 ->
- printf "a_hhz_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F124 ->
- printf "h_ahz_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F142 ->
- printf "h_ahz_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F241 ->
- printf "h_ahz_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F214 ->
- printf "h_ahz_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F412 ->
- printf "h_ahz_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F421 ->
- printf "h_ahz_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F134 ->
- printf "h_ahz_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F143 ->
- printf "h_ahz_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F341 ->
- printf "h_ahz_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F314 ->
- printf "h_ahz_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F413 ->
- printf "h_ahz_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F431 ->
- printf "h_ahz_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F123 ->
- printf "z_ahh_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F132 ->
- printf "z_ahh_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F231 ->
- printf "z_ahh_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F213 ->
- printf "z_ahh_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F312 ->
- printf "z_ahh_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F321 ->
- printf "z_ahh_DP(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- end
- | Dim6_AHHZ_PB coeff ->
- let c = format_coupling coeff c in
- begin match fusion with
- | F234 ->
- printf "a_hhz_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F243 ->
- printf "a_hhz_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F342 ->
- printf "a_hhz_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F324 ->
- printf "a_hhz_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F423 ->
- printf "a_hhz_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F432 ->
- printf "a_hhz_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F124 ->
- printf "h_ahz_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F142 ->
- printf "h_ahz_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F241 ->
- printf "h_ahz_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F214 ->
- printf "h_ahz_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F412 ->
- printf "h_ahz_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F421 ->
- printf "h_ahz_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F134 ->
- printf "h_ahz_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F143 ->
- printf "h_ahz_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F341 ->
- printf "h_ahz_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F314 ->
- printf "h_ahz_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F413 ->
- printf "h_ahz_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F431 ->
- printf "h_ahz_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- | F123 ->
- printf "z_ahh_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf2 p2 wf3 p3
- | F132 ->
- printf "z_ahh_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf1 p1 wf3 p3 wf2 p2
- | F231 ->
- printf "z_ahh_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf1 p1 wf2 p2
- | F213 ->
- printf "z_ahh_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf1 p1 wf3 p3
- | F312 ->
- printf "z_ahh_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf2 p2 wf3 p3 wf1 p1
- | F321 ->
- printf "z_ahh_PB(%s,%s,%s,%s,%s,%s,%s)"
- c wf3 p3 wf2 p2 wf1 p1
- end
-
-(* \begin{dubious}
- In principle, [p4] could be obtained from the left hand side \ldots
- \end{dubious} *)
- | DScalar4 contractions ->
- let p123 = Printf.sprintf "(-%s-%s-%s)" p1 p2 p3 in
- begin match contractions with
- | [] -> invalid_arg "Targets.print_current: DScalar4 []"
- | head :: tail ->
- printf "(";
- print_dscalar4 c wf1 wf2 wf3 p1 p2 p3 p123 fusion head;
- List.iter (print_add_dscalar4
- c wf1 wf2 wf3 p1 p2 p3 p123 fusion) tail;
- printf ")"
- end
-
- | DScalar2_Vector2 contractions ->
- let p123 = Printf.sprintf "(-%s-%s-%s)" p1 p2 p3 in
- begin match contractions with
- | [] -> invalid_arg "Targets.print_current: DScalar4 []"
- | head :: tail ->
- printf "(";
- print_dscalar2_vector2
- c wf1 wf2 wf3 p1 p2 p3 p123 fusion head;
- List.iter (print_add_dscalar2_vector2
- c wf1 wf2 wf3 p1 p2 p3 p123 fusion) tail;
- printf ")"
- end
-
- end
-
- (* \begin{dubious}
- This reproduces the hack on page~\pageref{hack:sign(V4)}
- and gives the correct results up to quartic vertices.
- Make sure that it is also correct in light
- of~\eqref{eq:factors-of-i}, i.\,e.
- \begin{equation*}
- \ii T = \ii^{\#\text{vertices}}\ii^{\#\text{propagators}} \cdots
- = \ii^{n-2}\ii^{n-3} \cdots
- = -\ii(-1)^n \cdots
- \end{equation*}
- \end{dubious} *)
- | Vn (UFO (c, v, s, fl, color), fusion, constant) ->
- if Color.Vertex.trivial color then
- let g = CM.constant_symbol constant
- and chn = F.children rhs in
- let wfs = List.map (multiple_variable amplitude dictionary) chn
- and ps = List.map momentum chn in
- let n = List.length fusion in
- let eps = if n mod 2 = 0 then -1 else 1 in
- printf "@, %s " (if (eps * F.sign rhs) < 0 then "-" else "+");
- UFO.Targets.Fortran.fuse c v s fl g wfs ps fusion
- else
- failwith "print_current: nontrivial color structure"
-
- let print_propagator f p m gamma =
- let minus_third = "(-1.0_" ^ !kind ^ "/3.0_" ^ !kind ^ ")" in
- let w =
- begin match CM.width f with
- | Vanishing | Fudged -> "0.0_" ^ !kind
- | Constant | Complex_Mass -> gamma
- | Timelike -> "wd_tl(" ^ p ^ "," ^ gamma ^ ")"
- | Running -> "wd_run(" ^ p ^ "," ^ m ^ "," ^ gamma ^ ")"
- | Custom f -> f ^ "(" ^ p ^ "," ^ gamma ^ ")"
- end in
- let cms =
- begin match CM.width f with
- | Complex_Mass -> ".true."
- | _ -> ".false."
- end in
- match CM.propagator f with
- | Prop_Scalar ->
- printf "pr_phi(%s,%s,%s," p m w
- | Prop_Col_Scalar ->
- printf "%s * pr_phi(%s,%s,%s," minus_third p m w
- | Prop_Ghost -> printf "(0,1) * pr_phi(%s, %s, %s," p m w
- | Prop_Spinor ->
- printf "%s(%s,%s,%s,%s," Fermions.psi_propagator p m w cms
- | Prop_ConjSpinor ->
- printf "%s(%s,%s,%s,%s," Fermions.psibar_propagator p m w cms
- | Prop_Majorana ->
- printf "%s(%s,%s,%s,%s," Fermions.chi_propagator p m w cms
- | Prop_Col_Majorana ->
- printf "%s * %s(%s,%s,%s,%s," minus_third Fermions.chi_propagator p m w cms
- | Prop_Unitarity ->
- printf "pr_unitarity(%s,%s,%s,%s," p m w cms
- | Prop_Col_Unitarity ->
- printf "%s * pr_unitarity(%s,%s,%s,%s," minus_third p m w cms
- | Prop_Feynman ->
- printf "pr_feynman(%s," p
- | Prop_Col_Feynman ->
- printf "%s * pr_feynman(%s," minus_third p
- | Prop_Gauge xi ->
- printf "pr_gauge(%s,%s," p (CM.gauge_symbol xi)
- | Prop_Rxi xi ->
- printf "pr_rxi(%s,%s,%s,%s," p m w (CM.gauge_symbol xi)
- | Prop_Tensor_2 ->
- printf "pr_tensor(%s,%s,%s," p m w
- | Prop_Tensor_pure ->
- printf "pr_tensor_pure(%s,%s,%s," p m w
- | Prop_Vector_pure ->
- printf "pr_vector_pure(%s,%s,%s," p m w
- | Prop_Vectorspinor ->
- printf "pr_grav(%s,%s,%s," p m w
- | Aux_Scalar | Aux_Spinor | Aux_ConjSpinor | Aux_Majorana
- | Aux_Vector | Aux_Tensor_1 -> printf "("
- | Aux_Col_Scalar | Aux_Col_Vector | Aux_Col_Tensor_1 -> printf "%s * (" minus_third
- | Only_Insertion -> printf "("
- | Prop_UFO name ->
- printf "pr_U_%s(%s,%s,%s," name p m w
-
- let print_projector f p m gamma =
- let minus_third = "(-1.0_" ^ !kind ^ "/3.0_" ^ !kind ^ ")" in
- match CM.propagator f with
- | Prop_Scalar ->
- printf "pj_phi(%s,%s," m gamma
- | Prop_Col_Scalar ->
- printf "%s * pj_phi(%s,%s," minus_third m gamma
- | Prop_Ghost ->
- printf "(0,1) * pj_phi(%s,%s," m gamma
- | Prop_Spinor ->
- printf "%s(%s,%s,%s," Fermions.psi_projector p m gamma
- | Prop_ConjSpinor ->
- printf "%s(%s,%s,%s," Fermions.psibar_projector p m gamma
- | Prop_Majorana ->
- printf "%s(%s,%s,%s," Fermions.chi_projector p m gamma
- | Prop_Col_Majorana ->
- printf "%s * %s(%s,%s,%s," minus_third Fermions.chi_projector p m gamma
- | Prop_Unitarity ->
- printf "pj_unitarity(%s,%s,%s," p m gamma
- | Prop_Col_Unitarity ->
- printf "%s * pj_unitarity(%s,%s,%s," minus_third p m gamma
- | Prop_Feynman | Prop_Col_Feynman ->
- invalid_arg "no on-shell Feynman propagator!"
- | Prop_Gauge _ ->
- invalid_arg "no on-shell massless gauge propagator!"
- | Prop_Rxi _ ->
- invalid_arg "no on-shell Rxi propagator!"
- | Prop_Vectorspinor ->
- printf "pj_grav(%s,%s,%s," p m gamma
- | Prop_Tensor_2 ->
- printf "pj_tensor(%s,%s,%s," p m gamma
- | Prop_Tensor_pure ->
- invalid_arg "no on-shell pure Tensor propagator!"
- | Prop_Vector_pure ->
- invalid_arg "no on-shell pure Vector propagator!"
- | Aux_Scalar | Aux_Spinor | Aux_ConjSpinor | Aux_Majorana
- | Aux_Vector | Aux_Tensor_1 -> printf "("
- | Aux_Col_Scalar | Aux_Col_Vector | Aux_Col_Tensor_1 -> printf "%s * (" minus_third
- | Only_Insertion -> printf "("
- | Prop_UFO name ->
- invalid_arg "no on shell UFO propagator"
-
- let print_gauss f p m gamma =
- let minus_third = "(-1.0_" ^ !kind ^ "/3.0_" ^ !kind ^ ")" in
- match CM.propagator f with
- | Prop_Scalar ->
- printf "pg_phi(%s,%s,%s," p m gamma
- | Prop_Ghost ->
- printf "(0,1) * pg_phi(%s,%s,%s," p m gamma
- | Prop_Spinor ->
- printf "%s(%s,%s,%s," Fermions.psi_projector p m gamma
- | Prop_ConjSpinor ->
- printf "%s(%s,%s,%s," Fermions.psibar_projector p m gamma
- | Prop_Majorana ->
- printf "%s(%s,%s,%s," Fermions.chi_projector p m gamma
- | Prop_Col_Majorana ->
- printf "%s * %s(%s,%s,%s," minus_third Fermions.chi_projector p m gamma
- | Prop_Unitarity ->
- printf "pg_unitarity(%s,%s,%s," p m gamma
- | Prop_Feynman | Prop_Col_Feynman ->
- invalid_arg "no on-shell Feynman propagator!"
- | Prop_Gauge _ ->
- invalid_arg "no on-shell massless gauge propagator!"
- | Prop_Rxi _ ->
- invalid_arg "no on-shell Rxi propagator!"
- | Prop_Tensor_2 ->
- printf "pg_tensor(%s,%s,%s," p m gamma
- | Prop_Tensor_pure ->
- invalid_arg "no pure tensor propagator!"
- | Prop_Vector_pure ->
- invalid_arg "no pure vector propagator!"
- | Aux_Scalar | Aux_Spinor | Aux_ConjSpinor | Aux_Majorana
- | Aux_Vector | Aux_Tensor_1 -> printf "("
- | Only_Insertion -> printf "("
- | Prop_UFO name ->
- invalid_arg "no UFO gauss insertion"
- | _ -> invalid_arg "targets:print_gauss: not available"
-
- let print_fusion_diagnostics amplitude dictionary fusion =
- if warn diagnose_gauge then begin
- let lhs = F.lhs fusion in
- let f = F.flavor lhs
- and v = variable lhs
- and p = momentum lhs in
- let mass = CM.mass_symbol f in
- match CM.propagator f with
- | Prop_Gauge _ | Prop_Feynman
- | Prop_Rxi _ | Prop_Unitarity ->
- printf " @[<2>%s =" v;
- List.iter (print_current amplitude dictionary) (F.rhs fusion); nl ();
- begin match CM.goldstone f with
- | None ->
- printf " call omega_ward_%s(\"%s\",%s,%s,%s)"
- (suffix diagnose_gauge) v mass p v; nl ()
- | Some (g, phase) ->
- let gv = add_tag lhs (CM.flavor_symbol g ^ "_" ^ format_p lhs) in
- printf " call omega_slavnov_%s"
- (suffix diagnose_gauge);
- printf "(@[\"%s\",%s,%s,%s,@,%s*%s)"
- v mass p v (format_constant phase) gv; nl ()
- end
- | _ -> ()
- end
-
- let print_fusion amplitude dictionary fusion =
- let lhs = F.lhs fusion in
- let f = F.flavor lhs in
- printf " @[<2>%s =@, " (multiple_variable amplitude dictionary lhs);
- if F.on_shell amplitude lhs then
- print_projector f (momentum lhs)
- (CM.mass_symbol f) (CM.width_symbol f)
- else
- if F.is_gauss amplitude lhs then
- print_gauss f (momentum lhs)
- (CM.mass_symbol f) (CM.width_symbol f)
- else
- print_propagator f (momentum lhs)
- (CM.mass_symbol f) (CM.width_symbol f);
- List.iter (print_current amplitude dictionary) (F.rhs fusion);
- printf ")"; nl ()
-
- let print_momenta seen_momenta amplitude =
- List.fold_left (fun seen f ->
- let wf = F.lhs f in
- let p = F.momentum_list wf in
- if not (PSet.mem p seen) then begin
- let rhs1 = List.hd (F.rhs f) in
- printf " %s = %s" (momentum wf)
- (String.concat " + "
- (List.map momentum (F.children rhs1))); nl ()
- end;
- PSet.add p seen)
- seen_momenta (F.fusions amplitude)
-
- let print_fusions dictionary fusions =
- List.iter
- (fun (f, amplitude) ->
- print_fusion_diagnostics amplitude dictionary f;
- print_fusion amplitude dictionary f)
- fusions
-
-(* \begin{dubious}
- The following will need a bit more work, because
- the decision when to [reverse_braket] for UFO models
- with Majorana fermions needs collaboration
- from [UFO.Targets.Fortran.fuse] which is called by
- [print_current]. See the function
- [UFO_targets.Fortran.jrr_print_majorana_current_transposing]
- for illustration (the function is never used and only for
- documentation).
- \end{dubious} *)
-
- let spins_of_rhs rhs =
- List.map (fun wf -> CM.lorentz (F.flavor wf)) (F.children rhs)
-
- let spins_of_ket ket =
- match ThoList.uniq (List.map spins_of_rhs ket) with
- | [spins] -> spins
- | [] -> failwith "Targets.Fortran.spins_of_ket: empty"
- | _ -> [] (* HACK! *)
-
- let print_braket amplitude dictionary name braket =
- let bra = F.bra braket
- and ket = F.ket braket in
- let spin_bra = CM.lorentz (F.flavor bra)
- and spins_ket = spins_of_ket ket in
- let vintage = true (* [F.vintage] *) in
- printf " @[<2>%s = %s@, + " name name;
- if Fermions.reverse_braket vintage spin_bra spins_ket then
- begin
- printf "@,(";
- List.iter (print_current amplitude dictionary) ket;
- printf ")*%s" (multiple_variable amplitude dictionary bra)
- end
- else
- begin
- printf "%s*@,(" (multiple_variable amplitude dictionary bra);
- List.iter (print_current amplitude dictionary) ket;
- printf ")"
- end;
- nl ()
-
-(* \begin{equation}
- \label{eq:factors-of-i}
- \ii T = \ii^{\#\text{vertices}}\ii^{\#\text{propagators}} \cdots
- = \ii^{n-2}\ii^{n-3} \cdots
- = -\ii(-1)^n \cdots
- \end{equation} *)
-
-(* \begin{dubious}
- [tho:] we write some brakets twice using different names. Is it useful
- to cache them?
- \end{dubious} *)
-
- let print_brakets dictionary amplitude =
- let name = flavors_symbol (flavors amplitude) in
- printf " %s = 0" name; nl ();
- List.iter (print_braket amplitude dictionary name) (F.brakets amplitude);
- let n = List.length (F.externals amplitude) in
- if n mod 2 = 0 then begin
- printf " @[<2>%s =@, - %s ! %d vertices, %d propagators"
- name name (n - 2) (n - 3); nl ()
- end else begin
- printf " ! %s = %s ! %d vertices, %d propagators"
- name name (n - 2) (n - 3); nl ()
- end;
- let s = F.symmetry amplitude in
- if s > 1 then
- printf " @[<2>%s =@, %s@, / sqrt(%d.0_%s) ! symmetry factor" name name s !kind
- else
- printf " ! unit symmetry factor";
- nl ()
-
- let print_incoming wf =
- let p = momentum wf
- and s = spin wf
- and f = F.flavor wf in
- let m = CM.mass_symbol f in
- match CM.lorentz f with
- | Scalar -> printf "1"
- | BRS Scalar -> printf "(0,-1) * (%s * %s - %s**2)" p p m
- | Spinor ->
- printf "%s (%s, - %s, %s)" Fermions.psi_incoming m p s
- | BRS Spinor ->
- printf "%s (%s, - %s, %s)" Fermions.brs_psi_incoming m p s
- | ConjSpinor ->
- printf "%s (%s, - %s, %s)" Fermions.psibar_incoming m p s
- | BRS ConjSpinor ->
- printf "%s (%s, - %s, %s)" Fermions.brs_psibar_incoming m p s
- | Majorana ->
- printf "%s (%s, - %s, %s)" Fermions.chi_incoming m p s
- | Maj_Ghost -> printf "ghost (%s, - %s, %s)" m p s
- | BRS Majorana ->
- printf "%s (%s, - %s, %s)" Fermions.brs_chi_incoming m p s
- | Vector | Massive_Vector ->
- printf "eps (%s, - %s, %s)" m p s
-(*i | Ward_Vector -> printf "%s" p i*)
- | BRS Vector | BRS Massive_Vector -> printf
- "(0,1) * (%s * %s - %s**2) * eps (%s, -%s, %s)" p p m m p s
- | Vectorspinor | BRS Vectorspinor ->
- printf "%s (%s, - %s, %s)" Fermions.grav_incoming m p s
- | Tensor_1 -> invalid_arg "Tensor_1 only internal"
- | Tensor_2 -> printf "eps2 (%s, - %s, %s)" m p s
- | _ -> invalid_arg "no such BRST transformations"
-
- let print_outgoing wf =
- let p = momentum wf
- and s = spin wf
- and f = F.flavor wf in
- let m = CM.mass_symbol f in
- match CM.lorentz f with
- | Scalar -> printf "1"
- | BRS Scalar -> printf "(0,-1) * (%s * %s - %s**2)" p p m
- | Spinor ->
- printf "%s (%s, %s, %s)" Fermions.psi_outgoing m p s
- | BRS Spinor ->
- printf "%s (%s, %s, %s)" Fermions.brs_psi_outgoing m p s
- | ConjSpinor ->
- printf "%s (%s, %s, %s)" Fermions.psibar_outgoing m p s
- | BRS ConjSpinor ->
- printf "%s (%s, %s, %s)" Fermions.brs_psibar_outgoing m p s
- | Majorana ->
- printf "%s (%s, %s, %s)" Fermions.chi_outgoing m p s
- | BRS Majorana ->
- printf "%s (%s, %s, %s)" Fermions.brs_chi_outgoing m p s
- | Maj_Ghost -> printf "ghost (%s, %s, %s)" m p s
- | Vector | Massive_Vector ->
- printf "conjg (eps (%s, %s, %s))" m p s
-(*i | Ward_Vector -> printf "%s" p i*)
- | BRS Vector | BRS Massive_Vector -> printf
- "(0,1) * (%s*%s-%s**2) * (conjg (eps (%s, %s, %s)))" p p m m p s
- | Vectorspinor | BRS Vectorspinor ->
- printf "%s (%s, %s, %s)" Fermions.grav_incoming m p s
- | Tensor_1 -> invalid_arg "Tensor_1 only internal"
- | Tensor_2 -> printf "conjg (eps2 (%s, %s, %s))" m p s
- | BRS _ -> invalid_arg "no such BRST transformations"
-
- (*i unused value
- let twice_spin wf =
- match CM.lorentz (F.flavor wf) with
- | Scalar | BRS Scalar -> "0"
- | Spinor | ConjSpinor | Majorana | Maj_Ghost | Vectorspinor
- | BRS Spinor | BRS ConjSpinor | BRS Majorana | BRS Vectorspinor -> "1"
- | Vector | BRS Vector | Massive_Vector | BRS Massive_Vector -> "2"
- | Tensor_1 -> "2"
- | Tensor_2 -> "4"
- | BRS _ -> invalid_arg "Targets.twice_spin: no such BRST transformation"
- i*)
-
- (*i unused value
- let print_argument_diagnostics amplitude =
- let externals = (F.externals amplitude) in
- let n = List.length externals
- and masses = List.map (fun wf -> CM.mass_symbol (F.flavor wf)) externals in
- if warn diagnose_arguments then begin
- printf " call omega_check_arguments_%s (%d, k)"
- (suffix diagnose_arguments) n; nl ()
- end;
- if warn diagnose_momenta then begin
- printf " @[<2>call omega_check_momenta_%s ((/ "
- (suffix diagnose_momenta);
- print_list masses;
- printf " /), k)"; nl ()
- end
- i*)
-
- let print_external_momenta amplitude =
- let externals =
- List.combine
- (F.externals amplitude)
- (List.map (fun _ -> true) (F.incoming amplitude) @
- List.map (fun _ -> false) (F.outgoing amplitude)) in
- List.iter (fun (wf, incoming) ->
- if incoming then
- printf " %s = - k(:,%d) ! incoming"
- (momentum wf) (ext_momentum wf)
- else
- printf " %s = k(:,%d) ! outgoing"
- (momentum wf) (ext_momentum wf); nl ()) externals
-
- let print_externals seen_wfs amplitude =
- let externals =
- List.combine
- (F.externals amplitude)
- (List.map (fun _ -> true) (F.incoming amplitude) @
- List.map (fun _ -> false) (F.outgoing amplitude)) in
- List.fold_left (fun seen (wf, incoming) ->
- if not (WFSet.mem wf seen) then begin
- printf " @[<2>%s =@, " (variable wf);
- (if incoming then print_incoming else print_outgoing) wf; nl ()
- end;
- WFSet.add wf seen) seen_wfs externals
-
- (*i unused value
- let flavors_to_string flavors =
- String.concat " " (List.map CM.flavor_to_string flavors)
- i*)
-
- (*i unused value
- let process_to_string amplitude =
- flavors_to_string (F.incoming amplitude) ^ " -> " ^
- flavors_to_string (F.outgoing amplitude)
- i*)
-
- let flavors_sans_color_to_string flavors =
- String.concat " " (List.map M.flavor_to_string flavors)
-
- let process_sans_color_to_string (fin, fout) =
- flavors_sans_color_to_string fin ^ " -> " ^
- flavors_sans_color_to_string fout
-
- let print_fudge_factor amplitude =
- let name = flavors_symbol (flavors amplitude) in
- List.iter (fun wf ->
- let p = momentum wf
- and f = F.flavor wf in
- match CM.width f with
- | Fudged ->
- let m = CM.mass_symbol f
- and w = CM.width_symbol f in
- printf " if (%s > 0.0_%s) then" w !kind; nl ();
- printf " @[<2>%s = %s@ * (%s*%s - %s**2)"
- name name p p m;
- printf "@ / cmplx (%s*%s - %s**2, %s*%s, kind=%s)"
- p p m m w !kind; nl ();
- printf " end if"; nl ()
- | _ -> ()) (F.s_channel amplitude)
-
- let num_helicities amplitudes =
- List.length (CF.helicities amplitudes)
-
-(* \thocwmodulesubsection{Spin, Flavor \&\ Color Tables} *)
-
-(* The following abomination is required to keep the number of continuation
- lines as low as possible. FORTRAN77-style \texttt{DATA} statements
- are actually a bit nicer here, but they are nor available for
- \emph{constant} arrays. *)
-
-(* \begin{dubious}
- We used to have a more elegant design with a sentinel~0 added to each
- initializer, but some revisions of the Compaq/Digital Compiler have a
- bug that causes it to reject this variant.
- \end{dubious} *)
-
-(* \begin{dubious}
- The actual table writing code using \texttt{reshape} should be factored,
- since it's the same algorithm every time.
- \end{dubious} *)
-
- let print_integer_parameter name value =
- printf " @[<2>integer, parameter :: %s = %d" name value; nl ()
-
- let print_real_parameter name value =
- printf " @[<2>real(kind=%s), parameter :: %s = %d"
- !kind name value; nl ()
-
- let print_logical_parameter name value =
- printf " @[<2>logical, parameter :: %s = .%s."
- name (if value then "true" else "false"); nl ()
-
- let num_particles_in amplitudes =
- match CF.flavors amplitudes with
- | [] -> 0
- | (fin, _) :: _ -> List.length fin
-
- let num_particles_out amplitudes =
- match CF.flavors amplitudes with
- | [] -> 0
- | (_, fout) :: _ -> List.length fout
-
- let num_particles amplitudes =
- match CF.flavors amplitudes with
- | [] -> 0
- | (fin, fout) :: _ -> List.length fin + List.length fout
-
- module CFlow = Color.Flow
-
- let num_color_flows amplitudes =
- if !amp_triv then
- 1
- else
- List.length (CF.color_flows amplitudes)
-
- let num_color_indices_default = 2 (* Standard model *)
-
- let num_color_indices amplitudes =
- try CFlow.rank (List.hd (CF.color_flows amplitudes)) with _ -> num_color_indices_default
-
- let color_to_string c =
- "(" ^ (String.concat "," (List.map (Printf.sprintf "%3d") c)) ^ ")"
-
- let cflow_to_string cflow =
- String.concat " " (List.map color_to_string (CFlow.in_to_lists cflow)) ^ " -> " ^
- String.concat " " (List.map color_to_string (CFlow.out_to_lists cflow))
-
- let protected = ", protected" (* Fortran 2003! *)
-
- (*i unused value
- let print_spin_table_old abbrev name = function
- | [] ->
- printf " @[<2>integer, dimension(n_prt,0) ::";
- printf "@ table_spin_%s" name; nl ()
- | _ :: tuples' as tuples ->
- ignore (List.fold_left (fun i (tuple1, tuple2) ->
- printf " @[<2>integer, dimension(n_prt), parameter, private ::";
- printf "@ %s%04d = (/ %s /)" abbrev i
- (String.concat ", " (List.map (Printf.sprintf "%2d") (tuple1 @ tuple2)));
- nl (); succ i) 1 tuples);
- printf
- " @[<2>integer, dimension(n_prt,n_hel), parameter ::";
- printf "@ table_spin_%s =@ reshape ( (/" name;
- printf "@ %s%04d" abbrev 1;
- ignore (List.fold_left (fun i tuple ->
- printf ",@ %s%04d" abbrev i; succ i) 2 tuples');
- printf "@ /), (/ n_prt, n_hel /) )"; nl ()
- i*)
-
- let print_spin_table name tuples =
- printf " @[<2>integer, dimension(n_prt,n_hel), save%s :: table_spin_%s"
- protected name; nl ();
- match tuples with
- | [] -> ()
- | _ ->
- ignore (List.fold_left (fun i (tuple1, tuple2) ->
- printf " @[<2>data table_spin_%s(:,%4d) / %s /" name i
- (String.concat ", " (List.map (Printf.sprintf "%2d") (tuple1 @ tuple2)));
- nl (); succ i) 1 tuples)
-
- let print_spin_tables amplitudes =
- (* [print_spin_table_old "s" "states_old" (CF.helicities amplitudes);] *)
- print_spin_table "states" (CF.helicities amplitudes);
- nl ()
-
- (*i unused value
- let print_flavor_table_old n abbrev name = function
- | [] ->
- printf " @[<2>integer, dimension(n_prt,0) ::";
- printf "@ table_flavor_%s" name; nl ()
- | _ :: tuples' as tuples ->
- ignore (List.fold_left (fun i tuple ->
- printf
- " @[<2>integer, dimension(n_prt), parameter, private ::";
- printf "@ %s%04d = (/ %s /) ! %s" abbrev i
- (String.concat ", "
- (List.map (fun f -> Printf.sprintf "%3d" (M.pdg f)) tuple))
- (String.concat " " (List.map M.flavor_to_string tuple));
- nl (); succ i) 1 tuples);
- printf
- " @[<2>integer, dimension(n_prt,n_flv), parameter ::";
- printf "@ table_flavor_%s =@ reshape ( (/" name;
- printf "@ %s%04d" abbrev 1;
- ignore (List.fold_left (fun i tuple ->
- printf ",@ %s%04d" abbrev i; succ i) 2 tuples');
- printf "@ /), (/ n_prt, n_flv /) )"; nl ()
- i*)
-
- let print_flavor_table name tuples =
- printf " @[<2>integer, dimension(n_prt,n_flv), save%s :: table_flavor_%s"
- protected name; nl ();
- match tuples with
- | [] -> ()
- | _ ->
- ignore (List.fold_left (fun i tuple ->
- printf " @[<2>data table_flavor_%s(:,%4d) / %s / ! %s" name i
- (String.concat ", "
- (List.map (fun f -> Printf.sprintf "%3d" (M.pdg f)) tuple))
- (String.concat " " (List.map M.flavor_to_string tuple));
- nl (); succ i) 1 tuples)
-
- let print_flavor_tables amplitudes =
- (* [let n = num_particles amplitudes in] *)
- (* [print_flavor_table_old n "f" "states_old"
- (List.map (fun (fin, fout) -> fin @ fout) (CF.flavors amplitudes));] *)
- print_flavor_table "states"
- (List.map (fun (fin, fout) -> fin @ fout) (CF.flavors amplitudes));
- nl ()
-
- let num_flavors amplitudes =
- List.length (CF.flavors amplitudes)
-
- (*i unused value
- let print_color_flows_table_old abbrev = function
- | [] ->
- printf " @[<2>integer, dimension(n_cindex, n_prt, n_cflow) ::";
- printf "@ table_color_flows"; nl ()
- | _ :: tuples' as tuples ->
- ignore (List.fold_left (fun i tuple ->
- printf
- " @[<2>integer, dimension(n_cindex, n_prt), parameter, private ::";
- printf "@ %s%04d = reshape ( (/ " abbrev i;
- begin match CFlow.to_lists tuple with
- | [] -> ()
- | cf1 :: cfn ->
- printf "@ %s" (String.concat "," (List.map string_of_int cf1));
- List.iter (function cf ->
- printf ",@ %s" (String.concat "," (List.map string_of_int cf))) cfn
- end;
- printf "@ /),@ (/ n_cindex, n_prt /) )";
- nl (); succ i) 1 tuples);
- printf
- " @[<2>integer, dimension(n_cindex, n_prt, n_cflow), parameter ::";
- printf "@ table_color_flows_old =@ reshape ( (/";
- printf "@ %s%04d" abbrev 1;
- ignore (List.fold_left (fun i tuple ->
- printf ",@ %s%04d" abbrev i; succ i) 2 tuples');
- printf "@ /),@ (/ n_cindex, n_prt, n_cflow /) )"; nl ()
- i*)
-
- (*i unused value
- let print_ghost_flags_table_old abbrev = function
- | [] ->
- printf " @[<2>logical, dimension(n_prt, n_cflow) ::";
- printf "@ table_ghost_flags"; nl ()
- | _ :: tuples' as tuples ->
- ignore (List.fold_left (fun i tuple ->
- printf
- " @[<2>logical, dimension(n_prt), parameter, private ::";
- printf "@ %s%04d = (/ " abbrev i;
- begin match CFlow.ghost_flags tuple with
- | [] -> ()
- | gf1 :: gfn ->
- printf "@ %s" (if gf1 then "T" else "F");
- List.iter (function gf -> printf ",@ %s" (if gf then "T" else "F")) gfn
- end;
- printf "@ /)";
- nl (); succ i) 1 tuples);
- printf
- " @[<2>logical, dimension(n_prt, n_cflow), parameter ::";
- printf "@ table_ghost_flags_old =@ reshape ( (/";
- printf "@ %s%04d" abbrev 1;
- ignore (List.fold_left (fun i tuple ->
- printf ",@ %s%04d" abbrev i; succ i) 2 tuples');
- printf "@ /),@ (/ n_prt, n_cflow /) )"; nl ()
- i*)
-
- let print_color_flows_table tuples =
- if !amp_triv then begin
- printf
- " @[<2>integer, dimension(n_cindex,n_prt,n_cflow), save%s :: table_color_flows = 0"
- protected; nl ();
- end
- else begin
- printf
- " @[<2>integer, dimension(n_cindex,n_prt,n_cflow), save%s :: table_color_flows"
- protected; nl ();
- end;
- if not !amp_triv then begin
- match tuples with
- | [] -> ()
- | _ :: _ as tuples ->
- ignore (List.fold_left (fun i tuple ->
- begin match CFlow.to_lists tuple with
- | [] -> ()
- | cf1 :: cfn ->
- printf " @[<2>data table_color_flows(:,:,%4d) /" i;
- printf "@ %s" (String.concat "," (List.map string_of_int cf1));
- List.iter (function cf ->
- printf ",@ %s" (String.concat "," (List.map string_of_int cf))) cfn;
- printf "@ /"; nl ()
- end;
- succ i) 1 tuples)
- end
-
- let print_ghost_flags_table tuples =
- if !amp_triv then begin
- printf
- " @[<2>logical, dimension(n_prt,n_cflow), save%s :: table_ghost_flags = F"
- protected; nl ();
- end
- else begin
- printf
- " @[<2>logical, dimension(n_prt,n_cflow), save%s :: table_ghost_flags"
- protected; nl ();
- match tuples with
- | [] -> ()
- | _ ->
- ignore (List.fold_left (fun i tuple ->
- begin match CFlow.ghost_flags tuple with
- | [] -> ()
- | gf1 :: gfn ->
- printf " @[<2>data table_ghost_flags(:,%4d) /" i;
- printf "@ %s" (if gf1 then "T" else "F");
- List.iter (function gf -> printf ",@ %s" (if gf then "T" else "F")) gfn;
- printf " /";
- nl ()
- end;
- succ i) 1 tuples)
- end
-
- let format_power_of x
- { Color.Flow.num = num; Color.Flow.den = den; Color.Flow.power = pwr } =
- match num, den, pwr with
- | _, 0, _ -> invalid_arg "format_power_of: zero denominator"
- | 0, _, _ -> "+zero"
- | 1, 1, 0 | -1, -1, 0 -> "+one"
- | -1, 1, 0 | 1, -1, 0 -> "-one"
- | 1, 1, 1 | -1, -1, 1 -> "+" ^ x
- | -1, 1, 1 | 1, -1, 1 -> "-" ^ x
- | 1, 1, -1 | -1, -1, -1 -> "+1/" ^ x
- | -1, 1, -1 | 1, -1, -1 -> "-1/" ^ x
- | 1, 1, p | -1, -1, p ->
- "+" ^ (if p > 0 then "" else "1/") ^ x ^ "**" ^ string_of_int (abs p)
- | -1, 1, p | 1, -1, p ->
- "-" ^ (if p > 0 then "" else "1/") ^ x ^ "**" ^ string_of_int (abs p)
- | n, 1, 0 ->
- (if n < 0 then "-" else "+") ^ string_of_int (abs n) ^ ".0_" ^ !kind
- | n, d, 0 ->
- (if n * d < 0 then "-" else "+") ^
- string_of_int (abs n) ^ ".0_" ^ !kind ^ "/" ^
- string_of_int (abs d)
- | n, 1, 1 ->
- (if n < 0 then "-" else "+") ^ string_of_int (abs n) ^ "*" ^ x
- | n, 1, -1 ->
- (if n < 0 then "-" else "+") ^ string_of_int (abs n) ^ "/" ^ x
- | n, d, 1 ->
- (if n * d < 0 then "-" else "+") ^
- string_of_int (abs n) ^ ".0_" ^ !kind ^ "/" ^
- string_of_int (abs d) ^ "*" ^ x
- | n, d, -1 ->
- (if n * d < 0 then "-" else "+") ^
- string_of_int (abs n) ^ ".0_" ^ !kind ^ "/" ^
- string_of_int (abs d) ^ "/" ^ x
- | n, 1, p ->
- (if n < 0 then "-" else "+") ^ string_of_int (abs n) ^
- (if p > 0 then "*" else "/") ^ x ^ "**" ^ string_of_int (abs p)
- | n, d, p ->
- (if n * d < 0 then "-" else "+") ^
- string_of_int (abs n) ^ ".0_" ^ !kind ^ "/" ^
- string_of_int (abs d) ^
- (if p > 0 then "*" else "/") ^ x ^ "**" ^ string_of_int (abs p)
-
- let format_powers_of x = function
- | [] -> "zero"
- | powers -> String.concat "" (List.map (format_power_of x) powers)
-
- (*i unused value
- let print_color_factor_table_old table =
- let n_cflow = Array.length table in
- let n_cfactors = ref 0 in
- for c1 = 0 to pred n_cflow do
- for c2 = 0 to pred n_cflow do
- match table.(c1).(c2) with
- | [] -> ()
- | _ -> incr n_cfactors
- done
- done;
- print_integer_parameter "n_cfactors" !n_cfactors;
- if n_cflow <= 0 then begin
- printf " @[<2>type(%s), dimension(n_cfactors) ::"
- omega_color_factor_abbrev;
- printf "@ table_color_factors"; nl ()
- end else begin
- printf
- " @[<2>type(%s), dimension(n_cfactors), parameter ::"
- omega_color_factor_abbrev;
- printf "@ table_color_factors = (/@ ";
- let comma = ref "" in
- for c1 = 0 to pred n_cflow do
- for c2 = 0 to pred n_cflow do
- match table.(c1).(c2) with
- | [] -> ()
- | cf ->
- printf "%s@ %s(%d,%d,%s)" !comma omega_color_factor_abbrev
- (succ c1) (succ c2) (format_powers_of nc_parameter cf);
- comma := ","
- done
- done;
- printf "@ /)"; nl ()
- end
- i*)
-
-(* \begin{dubious}
- We can optimize the following slightly by reusing common color factor [parameter]s.
- \end{dubious} *)
-
- let print_color_factor_table table =
- let n_cflow = Array.length table in
- let n_cfactors = ref 0 in
- for c1 = 0 to pred n_cflow do
- for c2 = 0 to pred n_cflow do
- match table.(c1).(c2) with
- | [] -> ()
- | _ -> incr n_cfactors
- done
- done;
- print_integer_parameter "n_cfactors" !n_cfactors;
- printf " @[<2>type(%s), dimension(n_cfactors), save%s ::"
- omega_color_factor_abbrev protected;
- printf "@ table_color_factors"; nl ();
- if not !amp_triv then begin
- let i = ref 1 in
- if n_cflow > 0 then begin
- for c1 = 0 to pred n_cflow do
- for c2 = 0 to pred n_cflow do
- match table.(c1).(c2) with
- | [] -> ()
- | cf ->
- printf " @[<2>real(kind=%s), parameter, private :: color_factor_%06d = %s"
- !kind !i (format_powers_of nc_parameter cf);
- nl ();
- printf " @[<2>data table_color_factors(%6d) / %s(%d,%d,color_factor_%06d) /"
- !i omega_color_factor_abbrev (succ c1) (succ c2) !i;
- incr i;
- nl ();
- done
- done
- end;
- end
-
- let print_color_tables amplitudes =
- let cflows = CF.color_flows amplitudes
- and cfactors = CF.color_factors amplitudes in
- (* [print_color_flows_table_old "c" cflows; nl ();] *)
- print_color_flows_table cflows; nl ();
- (* [print_ghost_flags_table_old "g" cflows; nl ();] *)
- print_ghost_flags_table cflows; nl ();
- (* [print_color_factor_table_old cfactors; nl ();] *)
- print_color_factor_table cfactors; nl ()
-
- let option_to_logical = function
- | Some _ -> "T"
- | None -> "F"
-
- (*i unused value
- let print_flavor_color_table_old abbrev n_flv n_cflow table =
- if n_flv <= 0 || n_cflow <= 0 then begin
- printf " @[<2>logical, dimension(n_flv, n_cflow) ::";
- printf "@ flv_col_is_allowed"; nl ()
- end else begin
- for c = 0 to pred n_cflow do
- printf
- " @[<2>logical, dimension(n_flv), parameter, private ::";
- printf "@ %s%04d = (/@ %s" abbrev (succ c) (option_to_logical table.(0).(c));
- for f = 1 to pred n_flv do
- printf ",@ %s" (option_to_logical table.(f).(c))
- done;
- printf "@ /)"; nl ()
- done;
- printf
- " @[<2>logical, dimension(n_flv, n_cflow), parameter ::";
- printf "@ flv_col_is_allowed_old =@ reshape ( (/@ %s%04d" abbrev 1;
- for c = 1 to pred n_cflow do
- printf ",@ %s%04d" abbrev (succ c)
- done;
- printf "@ /),@ (/ n_flv, n_cflow /) )"; nl ()
- end
- i*)
-
- let print_flavor_color_table n_flv n_cflow table =
- if !amp_triv then begin
- printf
- " @[<2>logical, dimension(n_flv, n_cflow), save%s :: @ flv_col_is_allowed = T"
- protected; nl ();
- end
- else begin
- printf
- " @[<2>logical, dimension(n_flv, n_cflow), save%s :: @ flv_col_is_allowed"
- protected; nl ();
- if n_flv > 0 then begin
- for c = 0 to pred n_cflow do
- printf
- " @[<2>data flv_col_is_allowed(:,%4d) /" (succ c);
- printf "@ %s" (option_to_logical table.(0).(c));
- for f = 1 to pred n_flv do
- printf ",@ %s" (option_to_logical table.(f).(c))
- done;
- printf "@ /"; nl ()
- done;
- end;
- end
-
- let print_amplitude_table a =
- (* [print_flavor_color_table_old "a"
- (num_flavors a) (List.length (CF.color_flows a)) (CF.process_table a);
- nl ();] *)
- print_flavor_color_table
- (num_flavors a) (List.length (CF.color_flows a)) (CF.process_table a);
- nl ();
- printf
- " @[<2>complex(kind=%s), dimension(n_flv, n_cflow, n_hel), save :: amp" !kind;
- nl ();
- nl ()
-
- let print_helicity_selection_table () =
- printf " @[<2>logical, dimension(n_hel), save :: ";
- printf "hel_is_allowed = T"; nl ();
- printf " @[<2>real(kind=%s), dimension(n_hel), save :: " !kind;
- printf "hel_max_abs = 0"; nl ();
- printf " @[<2>real(kind=%s), save :: " !kind;
- printf "hel_sum_abs = 0, ";
- printf "hel_threshold = 1E10_%s" !kind; nl ();
- printf " @[<2>integer, save :: ";
- printf "hel_count = 0, ";
- printf "hel_cutoff = 100"; nl ();
- printf " @[<2>integer :: ";
- printf "i"; nl ();
- printf " @[<2>integer, save, dimension(n_hel) :: ";
- printf "hel_map = (/(i, i = 1, n_hel)/)"; nl ();
- printf " @[<2>integer, save :: hel_finite = n_hel"; nl ();
- nl ()
-
-(* \thocwmodulesubsection{Optional MD5 sum function} *)
-
- let print_md5sum_functions = function
- | Some s ->
- printf " @[<5>"; if !fortran95 then printf "pure ";
- printf "function md5sum ()"; nl ();
- printf " character(len=32) :: md5sum"; nl ();
- printf " ! DON'T EVEN THINK of modifying the following line!"; nl ();
- printf " md5sum = \"%s\"" s; nl ();
- printf " end function md5sum"; nl ();
- nl ()
- | None -> ()
-
-(* \thocwmodulesubsection{Maintenance \&\ Inquiry Functions} *)
-
- let print_maintenance_functions () =
- if !whizard then begin
- printf " subroutine init (par, scheme)"; nl ();
- printf " real(kind=%s), dimension(*), intent(in) :: par" !kind; nl ();
- printf " integer, intent(in) :: scheme"; nl ();
- printf " call import_from_whizard (par, scheme)"; nl ();
- printf " end subroutine init"; nl ();
- nl ();
- printf " subroutine final ()"; nl ();
- printf " end subroutine final"; nl ();
- nl ();
- printf " subroutine update_alpha_s (alpha_s)"; nl ();
- printf " real(kind=%s), intent(in) :: alpha_s" !kind; nl ();
- printf " call model_update_alpha_s (alpha_s)"; nl ();
- printf " end subroutine update_alpha_s"; nl ();
- nl ()
- end
-
- let print_inquiry_function_openmp () = begin
- printf " pure function openmp_supported () result (status)"; nl ();
- printf " logical :: status"; nl ();
- printf " status = %s" (if !openmp then ".true." else ".false."); nl ();
- printf " end function openmp_supported"; nl ();
- nl ()
- end
-
- (*i unused value
- let print_inquiry_function_declarations name =
- printf " @[<2>public :: number_%s,@ %s" name name;
- nl ()
- i*)
-
- (*i unused value
- let print_numeric_inquiry_functions () =
- printf " @[<5>"; if !fortran95 then printf "pure ";
- printf "function number_particles_in () result (n)"; nl ();
- printf " integer :: n"; nl ();
- printf " n = n_in"; nl ();
- printf " end function number_particles_in"; nl ();
- nl ();
- printf " @[<5>"; if !fortran95 then printf "pure ";
- printf "function number_particles_out () result (n)"; nl ();
- printf " integer :: n"; nl ();
- printf " n = n_out"; nl ();
- printf " end function number_particles_out"; nl ();
- nl ()
- i*)
-
- let print_external_mass_case flv (fin, fout) =
- printf " case (%3d)" (succ flv); nl ();
- List.iteri
- (fun i f ->
- printf " m(%2d) = %s" (succ i) (M.mass_symbol f); nl ())
- (fin @ fout)
-
- let print_external_masses amplitudes =
- printf " @[<5>"; if !fortran95 then printf "pure ";
- printf "subroutine external_masses (m, flv)"; nl ();
- printf " real(kind=%s), dimension(:), intent(out) :: m" !kind; nl ();
- printf " integer, intent(in) :: flv"; nl ();
- printf " select case (flv)"; nl ();
- List.iteri print_external_mass_case (CF.flavors amplitudes);
- printf " end select"; nl ();
- printf " end subroutine external_masses"; nl ();
- nl ()
-
- let print_numeric_inquiry_functions (f, v) =
- printf " @[<5>"; if !fortran95 then printf "pure ";
- printf "function %s () result (n)" f; nl ();
- printf " integer :: n"; nl ();
- printf " n = %s" v; nl ();
- printf " end function %s" f; nl ();
- nl ()
-
- let print_inquiry_functions name =
- printf " @[<5>"; if !fortran95 then printf "pure ";
- printf "function number_%s () result (n)" name; nl ();
- printf " integer :: n"; nl ();
- printf " n = size (table_%s, dim=2)" name; nl ();
- printf " end function number_%s" name; nl ();
- nl ();
- printf " @[<5>"; if !fortran95 then printf "pure ";
- printf "subroutine %s (a)" name; nl ();
- printf " integer, dimension(:,:), intent(out) :: a"; nl ();
- printf " a = table_%s" name; nl ();
- printf " end subroutine %s" name; nl ();
- nl ()
-
- let print_color_flows () =
- printf " @[<5>"; if !fortran95 then printf "pure ";
- printf "function number_color_indices () result (n)"; nl ();
- printf " integer :: n"; nl ();
- if !amp_triv then begin
- printf " n = n_cindex"; nl ();
- end
- else begin
- printf " n = size (table_color_flows, dim=1)"; nl ();
- end;
- printf " end function number_color_indices"; nl ();
- nl ();
- printf " @[<5>"; if !fortran95 then printf "pure ";
- printf "function number_color_flows () result (n)"; nl ();
- printf " integer :: n"; nl ();
- if !amp_triv then begin
- printf " n = n_cflow"; nl ();
- end
- else begin
- printf " n = size (table_color_flows, dim=3)"; nl ();
- end;
- printf " end function number_color_flows"; nl ();
- nl ();
- printf " @[<5>"; if !fortran95 then printf "pure ";
- printf "subroutine color_flows (a, g)"; nl ();
- printf " integer, dimension(:,:,:), intent(out) :: a"; nl ();
- printf " logical, dimension(:,:), intent(out) :: g"; nl ();
- printf " a = table_color_flows"; nl ();
- printf " g = table_ghost_flags"; nl ();
- printf " end subroutine color_flows"; nl ();
- nl ()
-
- let print_color_factors () =
- printf " @[<5>"; if !fortran95 then printf "pure ";
- printf "function number_color_factors () result (n)"; nl ();
- printf " integer :: n"; nl ();
- printf " n = size (table_color_factors)"; nl ();
- printf " end function number_color_factors"; nl ();
- nl ();
- printf " @[<5>"; if !fortran95 then printf "pure ";
- printf "subroutine color_factors (cf)"; nl ();
- printf " type(%s), dimension(:), intent(out) :: cf"
- omega_color_factor_abbrev; nl ();
- printf " cf = table_color_factors"; nl ();
- printf " end subroutine color_factors"; nl ();
- nl ();
- printf " @[<5>"; if !fortran95 && pure_unless_openmp then printf "pure ";
- printf "function color_sum (flv, hel) result (amp2)"; nl ();
- printf " integer, intent(in) :: flv, hel"; nl ();
- printf " real(kind=%s) :: amp2" !kind; nl ();
- printf " amp2 = real (omega_color_sum (flv, hel, amp, table_color_factors))"; nl ();
- printf " end function color_sum"; nl ();
- nl ()
-
- let print_dispatch_functions () =
- printf " @[<5>";
- printf "subroutine new_event (p)"; nl ();
- printf " real(kind=%s), dimension(0:3,*), intent(in) :: p" !kind; nl ();
- printf " logical :: mask_dirty"; nl ();
- printf " integer :: hel"; nl ();
- printf " call calculate_amplitudes (amp, p, hel_is_allowed)"; nl ();
- printf " if ((hel_threshold .gt. 0) .and. (hel_count .le. hel_cutoff)) then"; nl ();
- printf " call @[<3>omega_update_helicity_selection@ (hel_count,@ amp,@ ";
- printf "hel_max_abs,@ hel_sum_abs,@ hel_is_allowed,@ hel_threshold,@ hel_cutoff,@ mask_dirty)"; nl ();
- printf " if (mask_dirty) then"; nl ();
- printf " hel_finite = 0"; nl ();
- printf " do hel = 1, n_hel"; nl ();
- printf " if (hel_is_allowed(hel)) then"; nl ();
- printf " hel_finite = hel_finite + 1"; nl ();
- printf " hel_map(hel_finite) = hel"; nl ();
- printf " end if"; nl ();
- printf " end do"; nl ();
- printf " end if"; nl ();
- printf " end if"; nl ();
- printf " end subroutine new_event"; nl ();
- nl ();
- printf " @[<5>";
- printf "subroutine reset_helicity_selection (threshold, cutoff)"; nl ();
- printf " real(kind=%s), intent(in) :: threshold" !kind; nl ();
- printf " integer, intent(in) :: cutoff"; nl ();
- printf " integer :: i"; nl ();
- printf " hel_is_allowed = T"; nl ();
- printf " hel_max_abs = 0"; nl ();
- printf " hel_sum_abs = 0"; nl ();
- printf " hel_count = 0"; nl ();
- printf " hel_threshold = threshold"; nl ();
- printf " hel_cutoff = cutoff"; nl ();
- printf " hel_map = (/(i, i = 1, n_hel)/)"; nl ();
- printf " hel_finite = n_hel"; nl ();
- printf " end subroutine reset_helicity_selection"; nl ();
- nl ();
- printf " @[<5>"; if !fortran95 then printf "pure ";
- printf "function is_allowed (flv, hel, col) result (yorn)"; nl ();
- printf " logical :: yorn"; nl ();
- printf " integer, intent(in) :: flv, hel, col"; nl ();
- if !amp_triv then begin
- printf " ! print *, 'inside is_allowed'"; nl ();
- end;
- if not !amp_triv then begin
- printf " yorn = hel_is_allowed(hel) .and. ";
- printf "flv_col_is_allowed(flv,col)"; nl ();
- end
- else begin
- printf " yorn = .false."; nl ();
- end;
- printf " end function is_allowed"; nl ();
- nl ();
- printf " @[<5>"; if !fortran95 then printf "pure ";
- printf "function get_amplitude (flv, hel, col) result (amp_result)"; nl ();
- printf " complex(kind=%s) :: amp_result" !kind; nl ();
- printf " integer, intent(in) :: flv, hel, col"; nl ();
- printf " amp_result = amp(flv, col, hel)"; nl ();
- printf " end function get_amplitude"; nl ();
- nl ()
-
-(* \thocwmodulesubsection{Main Function} *)
-
- let format_power_of_nc
- { Color.Flow.num = num; Color.Flow.den = den; Color.Flow.power = pwr } =
- match num, den, pwr with
- | _, 0, _ -> invalid_arg "format_power_of_nc: zero denominator"
- | 0, _, _ -> ""
- | 1, 1, 0 | -1, -1, 0 -> "+ 1"
- | -1, 1, 0 | 1, -1, 0 -> "- 1"
- | 1, 1, 1 | -1, -1, 1 -> "+ N"
- | -1, 1, 1 | 1, -1, 1 -> "- N"
- | 1, 1, -1 | -1, -1, -1 -> "+ 1/N"
- | -1, 1, -1 | 1, -1, -1 -> "- 1/N"
- | 1, 1, p | -1, -1, p ->
- "+ " ^ (if p > 0 then "" else "1/") ^ "N^" ^ string_of_int (abs p)
- | -1, 1, p | 1, -1, p ->
- "- " ^ (if p > 0 then "" else "1/") ^ "N^" ^ string_of_int (abs p)
- | n, 1, 0 ->
- (if n < 0 then "- " else "+ ") ^ string_of_int (abs n)
- | n, d, 0 ->
- (if n * d < 0 then "- " else "+ ") ^
- string_of_int (abs n) ^ "/" ^ string_of_int (abs d)
- | n, 1, 1 ->
- (if n < 0 then "- " else "+ ") ^ string_of_int (abs n) ^ "N"
- | n, 1, -1 ->
- (if n < 0 then "- " else "+ ") ^ string_of_int (abs n) ^ "/N"
- | n, d, 1 ->
- (if n * d < 0 then "- " else "+ ") ^
- string_of_int (abs n) ^ "/" ^ string_of_int (abs d) ^ "N"
- | n, d, -1 ->
- (if n * d < 0 then "- " else "+ ") ^
- string_of_int (abs n) ^ "/" ^ string_of_int (abs d) ^ "/N"
- | n, 1, p ->
- (if n < 0 then "- " else "+ ") ^ string_of_int (abs n) ^
- (if p > 0 then "*" else "/") ^ "N^" ^ string_of_int (abs p)
- | n, d, p ->
- (if n * d < 0 then "- " else "+ ") ^ string_of_int (abs n) ^ "/" ^
- string_of_int (abs d) ^ (if p > 0 then "*" else "/") ^ "N^" ^ string_of_int (abs p)
-
- let format_powers_of_nc = function
- | [] -> "0"
- | powers -> String.concat " " (List.map format_power_of_nc powers)
-
- let print_description cmdline amplitudes () =
- printf
- "! File generated automatically by O'Mega %s %s %s"
- Config.version Config.status Config.date; nl ();
- List.iter (fun s -> printf "! %s" s; nl ()) (M.caveats ());
- printf "!"; nl ();
- printf "! %s" cmdline; nl ();
- printf "!"; nl ();
- printf "! with all scattering amplitudes for the process(es)"; nl ();
- printf "!"; nl ();
- printf "! flavor combinations:"; nl ();
- printf "!"; nl ();
- ThoList.iteri
- (fun i process ->
- printf "! %3d: %s" i (process_sans_color_to_string process); nl ())
- 1 (CF.flavors amplitudes);
- printf "!"; nl ();
- printf "! color flows:"; nl ();
- if not !amp_triv then begin
- printf "!"; nl ();
- ThoList.iteri
- (fun i cflow ->
- printf "! %3d: %s" i (cflow_to_string cflow); nl ())
- 1 (CF.color_flows amplitudes);
- printf "!"; nl ();
- printf "! NB: i.g. not all color flows contribute to all flavor"; nl ();
- printf "! combinations. Consult the array FLV_COL_IS_ALLOWED"; nl ();
- printf "! below for the allowed combinations."; nl ();
- end;
- printf "!"; nl ();
- printf "! Color Factors:"; nl ();
- printf "!"; nl ();
- if not !amp_triv then begin
- let cfactors = CF.color_factors amplitudes in
- for c1 = 0 to pred (Array.length cfactors) do
- for c2 = 0 to c1 do
- match cfactors.(c1).(c2) with
- | [] -> ()
- | cfactor ->
- printf "! (%3d,%3d): %s"
- (succ c1) (succ c2) (format_powers_of_nc cfactor); nl ()
- done
- done;
- end;
- if not !amp_triv then begin
- printf "!"; nl ();
- printf "! vanishing or redundant flavor combinations:"; nl ();
- printf "!"; nl ();
- List.iter (fun process ->
- printf "! %s" (process_sans_color_to_string process); nl ())
- (CF.vanishing_flavors amplitudes);
- printf "!"; nl ();
- end;
- begin
- match CF.constraints amplitudes with
- | None -> ()
- | Some s ->
- printf
- "! diagram selection (MIGHT BREAK GAUGE INVARIANCE!!!):"; nl ();
- printf "!"; nl ();
- printf "! %s" s; nl ();
- printf "!"; nl ()
- end;
- printf "!"; nl ()
-
-(* \thocwmodulesubsection{Printing Modules} *)
-
- type accessibility =
- | Public
- | Private
- | Protected (* Fortran 2003 *)
-
- let accessibility_to_string = function
- | Public -> "public"
- | Private -> "private"
- | Protected -> "protected"
-
- type used_symbol =
- | As_Is of string
- | Aliased of string * string
-
- let print_used_symbol = function
- | As_Is name -> printf "%s" name
- | Aliased (orig, alias) -> printf "%s => %s" alias orig
-
- type used_module =
- | Full of string
- | Full_Aliased of string * (string * string) list
- | Subset of string * used_symbol list
-
- let print_used_module = function
- | Full name
- | Full_Aliased (name, [])
- | Subset (name, []) ->
- printf " use %s" name;
- nl ()
- | Full_Aliased (name, aliases) ->
- printf " @[<5>use %s" name;
- List.iter
- (fun (orig, alias) -> printf ", %s => %s" alias orig)
- aliases;
- nl ()
- | Subset (name, used_symbol :: used_symbols) ->
- printf " @[<5>use %s, only: " name;
- print_used_symbol used_symbol;
- List.iter (fun s -> printf ", "; print_used_symbol s) used_symbols;
- nl ()
-
- type fortran_module =
- { module_name : string;
- default_accessibility : accessibility;
- used_modules : used_module list;
- public_symbols : string list;
- print_declarations : (unit -> unit) list;
- print_implementations : (unit -> unit) list }
-
- let print_public = function
- | name1 :: names ->
- printf " @[<2>public :: %s" name1;
- List.iter (fun n -> printf ",@ %s" n) names; nl ()
- | [] -> ()
-
- (*i unused value
- let print_public_interface generic procedures =
- printf " public :: %s" generic; nl ();
- begin match procedures with
- | name1 :: names ->
- printf " interface %s" generic; nl ();
- printf " @[<2>module procedure %s" name1;
- List.iter (fun n -> printf ",@ %s" n) names; nl ();
- printf " end interface"; nl ();
- print_public procedures
- | [] -> ()
- end
- i*)
-
- let print_module m =
- printf "module %s" m.module_name; nl ();
- List.iter print_used_module m.used_modules;
- printf " implicit none"; nl ();
- printf " %s" (accessibility_to_string m.default_accessibility); nl ();
- print_public m.public_symbols; nl ();
- begin match m.print_declarations with
- | [] -> ()
- | print_declarations ->
- List.iter (fun f -> f ()) print_declarations; nl ()
- end;
- begin match m.print_implementations with
- | [] -> ()
- | print_implementations ->
- printf "contains"; nl (); nl ();
- List.iter (fun f -> f ()) print_implementations; nl ();
- end;
- printf "end module %s" m.module_name; nl ()
-
- let print_modules modules =
- List.iter print_module modules;
- print_flush ()
-
- let module_to_file line_length oc prelude m =
- output_string oc (m.module_name ^ "\n");
- let filename = m.module_name ^ ".f90" in
- let channel = open_out filename in
- Format_Fortran.set_formatter_out_channel ~width:line_length channel;
- prelude ();
- print_modules [m];
- close_out channel
-
- let modules_to_file line_length oc prelude = function
- | [] -> ()
- | m :: mlist ->
- module_to_file line_length oc prelude m;
- List.iter (module_to_file line_length oc (fun () -> ())) mlist
-
-(* \thocwmodulesubsection{Chopping Up Amplitudes} *)
-
- let num_fusions_brakets size amplitudes =
- let num_fusions =
- max 1 size in
- let count_brakets =
- List.fold_left
- (fun sum process -> sum + List.length (F.brakets process))
- 0 (CF.processes amplitudes)
- and count_processes =
- List.length (CF.processes amplitudes) in
- if count_brakets > 0 then
- let num_brakets =
- max 1 ((num_fusions * count_processes) / count_brakets) in
- (num_fusions, num_brakets)
- else
- (num_fusions, 1)
-
- let chop_amplitudes size amplitudes =
- let num_fusions, num_brakets = num_fusions_brakets size amplitudes in
- (ThoList.enumerate 1 (ThoList.chopn num_fusions (CF.fusions amplitudes)),
- ThoList.enumerate 1 (ThoList.chopn num_brakets (CF.processes amplitudes)))
-
- let print_compute_fusions1 dictionary (n, fusions) =
- if not !amp_triv then begin
- if !openmp then begin
- printf " subroutine compute_fusions_%04d (%s)" n openmp_tld; nl ();
- printf " @[<5>type(%s), intent(inout) :: %s" openmp_tld_type openmp_tld; nl ();
- end else begin
- printf " @[<5>subroutine compute_fusions_%04d ()" n; nl ();
- end;
- print_fusions dictionary fusions;
- printf " end subroutine compute_fusions_%04d" n; nl ();
- end
-
- and print_compute_brakets1 dictionary (n, processes) =
- if not !amp_triv then begin
- if !openmp then begin
- printf " subroutine compute_brakets_%04d (%s)" n openmp_tld; nl ();
- printf " @[<5>type(%s), intent(inout) :: %s" openmp_tld_type openmp_tld; nl ();
- end else begin
- printf " @[<5>subroutine compute_brakets_%04d ()" n; nl ();
- end;
- List.iter (print_brakets dictionary) processes;
- printf " end subroutine compute_brakets_%04d" n; nl ();
- end
-
-(* \thocwmodulesubsection{Common Stuff} *)
-
- let omega_public_symbols =
- ["number_particles_in"; "number_particles_out";
- "number_color_indices";
- "reset_helicity_selection"; "new_event";
- "is_allowed"; "get_amplitude"; "color_sum";
- "external_masses"; "openmp_supported"] @
- ThoList.flatmap
- (fun n -> ["number_" ^ n; n])
- ["spin_states"; "flavor_states"; "color_flows"; "color_factors"]
-
- let whizard_public_symbols md5sum =
- ["init"; "final"; "update_alpha_s"] @
- (match md5sum with Some _ -> ["md5sum"] | None -> [])
-
- let used_modules () =
- [Full "kinds";
- Full Fermions.use_module;
- Full_Aliased ("omega_color", ["omega_color_factor", omega_color_factor_abbrev])] @
- List.map
- (fun m -> Full m)
- (match !parameter_module with
- | "" -> !use_modules
- | pm -> pm :: !use_modules)
-
- let public_symbols () =
- if !whizard then
- omega_public_symbols @ (whizard_public_symbols !md5sum)
- else
- omega_public_symbols
-
- let print_constants amplitudes =
-
- printf " ! DON'T EVEN THINK of removing the following!"; nl ();
- printf " ! If the compiler complains about undeclared"; nl ();
- printf " ! or undefined variables, you are compiling"; nl ();
- printf " ! against an incompatible omega95 module!"; nl ();
- printf " @[<2>integer, dimension(%d), parameter, private :: "
- (List.length require_library);
- printf "require =@ (/ @[";
- print_list require_library;
- printf " /)"; nl (); nl ();
-
- (* Using these parameters makes sense for documentation, but in
- practice, there is no need to ever change them. *)
- List.iter
- (function name, value -> print_integer_parameter name (value amplitudes))
- [ ("n_prt", num_particles);
- ("n_in", num_particles_in);
- ("n_out", num_particles_out);
- ("n_cflow", num_color_flows); (* Number of different color amplitudes. *)
- ("n_cindex", num_color_indices); (* Maximum rank of color tensors. *)
- ("n_flv", num_flavors); (* Number of different flavor amplitudes. *)
- ("n_hel", num_helicities) (* Number of different helicty amplitudes. *) ];
- nl ();
-
- (* Abbreviations. *)
- printf " ! NB: you MUST NOT change the value of %s here!!!" nc_parameter;
- nl ();
- printf " ! It is defined here for convenience only and must be"; nl ();
- printf " ! compatible with hardcoded values in the amplitude!"; nl ();
- print_real_parameter nc_parameter (CM.nc ()); (* $N_C$ *)
- List.iter
- (function name, value -> print_logical_parameter name value)
- [ ("F", false); ("T", true) ]; nl ();
-
- print_spin_tables amplitudes;
- print_flavor_tables amplitudes;
- print_color_tables amplitudes;
- print_amplitude_table amplitudes;
- print_helicity_selection_table ()
-
- let print_interface amplitudes =
- print_md5sum_functions !md5sum;
- print_maintenance_functions ();
- List.iter print_numeric_inquiry_functions
- [("number_particles_in", "n_in");
- ("number_particles_out", "n_out")];
- List.iter print_inquiry_functions
- ["spin_states"; "flavor_states"];
- print_external_masses amplitudes;
- print_inquiry_function_openmp ();
- print_color_flows ();
- print_color_factors ();
- print_dispatch_functions ();
- nl ();
- (* Is this really necessary? *)
- Format_Fortran.switch_line_continuation false;
- if !km_write || !km_pure then (Targets_Kmatrix.Fortran.print !km_pure);
- if !km_2_write || !km_2_pure then (Targets_Kmatrix_2.Fortran.print !km_2_pure);
- Format_Fortran.switch_line_continuation true;
- nl ()
-
- let print_calculate_amplitudes declarations computations amplitudes =
- printf " @[<5>subroutine calculate_amplitudes (amp, k, mask)"; nl ();
- printf " complex(kind=%s), dimension(:,:,:), intent(out) :: amp" !kind; nl ();
- printf " real(kind=%s), dimension(0:3,*), intent(in) :: k" !kind; nl ();
- printf " logical, dimension(:), intent(in) :: mask"; nl ();
- printf " integer, dimension(n_prt) :: s"; nl ();
- printf " integer :: h, hi"; nl ();
- declarations ();
- if not !amp_triv then begin
- begin match CF.processes amplitudes with
- | p :: _ -> print_external_momenta p
- | _ -> ()
- end;
- ignore (List.fold_left print_momenta PSet.empty (CF.processes amplitudes));
- end;
- printf " amp = 0"; nl ();
- if not !amp_triv then begin
- if num_helicities amplitudes > 0 then begin
- printf " if (hel_finite == 0) return"; nl ();
- if !openmp then begin
- printf "!$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(s, h, %s) SCHEDULE(STATIC)" openmp_tld; nl ();
- end;
- printf " do hi = 1, hel_finite"; nl ();
- printf " h = hel_map(hi)"; nl ();
- printf " s = table_spin_states(:,h)"; nl ();
- ignore (List.fold_left print_externals WFSet.empty (CF.processes amplitudes));
- computations ();
- List.iter print_fudge_factor (CF.processes amplitudes);
- (* This sorting should slightly improve cache locality. *)
- let triple_snd = fun (_, x, _) -> x
- in let triple_fst = fun (x, _, _) -> x
- in let rec builder1 flvi flowi flows = match flows with
- | (Some a) :: tl -> (flvi, flowi, flavors_symbol (flavors a)) :: (builder1 flvi (flowi + 1) tl)
- | None :: tl -> builder1 flvi (flowi + 1) tl
- | [] -> []
- in let rec builder2 flvi flvs = match flvs with
- | flv :: tl -> (builder1 flvi 1 flv) @ (builder2 (flvi + 1) tl)
- | [] -> []
- in let unsorted = builder2 1 (List.map Array.to_list (Array.to_list (CF.process_table amplitudes)))
- in let sorted = List.sort (fun a b ->
- if (triple_snd a != triple_snd b) then triple_snd a - triple_snd b else (triple_fst a - triple_fst b))
- unsorted
- in List.iter (fun (flvi, flowi, flv) ->
- (printf " amp(%d,%d,h) = %s" flvi flowi flv; nl ();)) sorted;
-
- (*i printf " else"; nl ();
- printf " amp(:,h,:) = 0"; nl (); i*)
- printf " end do"; nl ();
- if !openmp then begin
- printf "!$OMP END PARALLEL DO"; nl ();
- end;
- end;
- end;
- printf " end subroutine calculate_amplitudes"; nl ()
-
- let print_compute_chops chopped_fusions chopped_brakets () =
- List.iter
- (fun (i, _) -> printf " call compute_fusions_%04d (%s)" i
- (if !openmp then openmp_tld else ""); nl ())
- chopped_fusions;
- List.iter
- (fun (i, _) -> printf " call compute_brakets_%04d (%s)" i
- (if !openmp then openmp_tld else ""); nl ())
- chopped_brakets
-
- (* \thocwmodulesubsection{UFO Fusions} *)
-
- module VSet =
- Set.Make (struct type t = F.constant Coupling.t let compare = compare end)
-
- let ufo_fusions_used amplitudes =
- let couplings =
- List.fold_left
- (fun acc p ->
- let fusions = ThoList.flatmap F.rhs (F.fusions p)
- and brakets = ThoList.flatmap F.ket (F.brakets p) in
- let couplings =
- VSet.of_list (List.map F.coupling (fusions @ brakets)) in
- VSet.union acc couplings)
- VSet.empty (CF.processes amplitudes) in
- VSet.fold
- (fun v acc ->
- match v with
- | Coupling.Vn (Coupling.UFO (_, v, _, _, _), _, _) ->
- Sets.String.add v acc
- | _ -> acc)
- couplings Sets.String.empty
-
-(* \thocwmodulesubsection{Single Function} *)
-
- let amplitudes_to_channel_single_function cmdline oc amplitudes =
-
- let print_declarations () =
- print_constants amplitudes
-
- and print_implementations () =
- print_interface amplitudes;
- print_calculate_amplitudes
- (fun () -> print_variable_declarations amplitudes)
- (fun () ->
- print_fusions (CF.dictionary amplitudes) (CF.fusions amplitudes);
- List.iter
- (print_brakets (CF.dictionary amplitudes))
- (CF.processes amplitudes))
- amplitudes in
-
- let fortran_module =
- { module_name = !module_name;
- used_modules = used_modules ();
- default_accessibility = Private;
- public_symbols = public_symbols ();
- print_declarations = [print_declarations];
- print_implementations = [print_implementations] } in
-
- Format_Fortran.set_formatter_out_channel ~width:!line_length oc;
- print_description cmdline amplitudes ();
- print_modules [fortran_module]
-
-(* \thocwmodulesubsection{Single Module} *)
-
- let amplitudes_to_channel_single_module cmdline oc size amplitudes =
-
- let print_declarations () =
- print_constants amplitudes;
- print_variable_declarations amplitudes
-
- and print_implementations () =
- print_interface amplitudes in
-
- let chopped_fusions, chopped_brakets =
- chop_amplitudes size amplitudes in
-
- let dictionary = CF.dictionary amplitudes in
-
- let print_compute_amplitudes () =
- print_calculate_amplitudes
- (fun () -> ())
- (print_compute_chops chopped_fusions chopped_brakets)
- amplitudes
-
- and print_compute_fusions () =
- List.iter (print_compute_fusions1 dictionary) chopped_fusions
-
- and print_compute_brakets () =
- List.iter (print_compute_brakets1 dictionary) chopped_brakets in
-
- let fortran_module =
- { module_name = !module_name;
- used_modules = used_modules ();
- default_accessibility = Private;
- public_symbols = public_symbols ();
- print_declarations = [print_declarations];
- print_implementations = [print_implementations;
- print_compute_amplitudes;
- print_compute_fusions;
- print_compute_brakets] } in
-
- Format_Fortran.set_formatter_out_channel ~width:!line_length oc;
- print_description cmdline amplitudes ();
- print_modules [fortran_module]
-
-(* \thocwmodulesubsection{Multiple Modules} *)
-
- let modules_of_amplitudes _ _ size amplitudes =
-
- let name = !module_name in
-
- let print_declarations () =
- print_constants amplitudes
- and print_variables () =
- print_variable_declarations amplitudes in
-
- let constants_module =
- { module_name = name ^ "_constants";
- used_modules = used_modules ();
- default_accessibility = Public;
- public_symbols = [];
- print_declarations = [print_declarations];
- print_implementations = [] } in
-
- let variables_module =
- { module_name = name ^ "_variables";
- used_modules = used_modules ();
- default_accessibility = Public;
- public_symbols = [];
- print_declarations = [print_variables];
- print_implementations = [] } in
-
- let dictionary = CF.dictionary amplitudes in
-
- let print_compute_fusions (n, fusions) () =
- if not !amp_triv then begin
- if !openmp then begin
- printf " subroutine compute_fusions_%04d (%s)" n openmp_tld; nl ();
- printf " @[<5>type(%s), intent(inout) :: %s" openmp_tld_type openmp_tld; nl ();
- end else begin
- printf " @[<5>subroutine compute_fusions_%04d ()" n; nl ();
- end;
- print_fusions dictionary fusions;
- printf " end subroutine compute_fusions_%04d" n; nl ();
- end in
-
- let print_compute_brakets (n, processes) () =
- if not !amp_triv then begin
- if !openmp then begin
- printf " subroutine compute_brakets_%04d (%s)" n openmp_tld; nl ();
- printf " @[<5>type(%s), intent(inout) :: %s" openmp_tld_type openmp_tld; nl ();
- end else begin
- printf " @[<5>subroutine compute_brakets_%04d ()" n; nl ();
- end;
- List.iter (print_brakets dictionary) processes;
- printf " end subroutine compute_brakets_%04d" n; nl ();
- end in
-
- let fusions_module (n, _ as fusions) =
- let tag = Printf.sprintf "_fusions_%04d" n in
- { module_name = name ^ tag;
- used_modules = (used_modules () @
- [Full constants_module.module_name;
- Full variables_module.module_name]);
- default_accessibility = Private;
- public_symbols = ["compute" ^ tag];
- print_declarations = [];
- print_implementations = [print_compute_fusions fusions] } in
-
- let brakets_module (n, _ as processes) =
- let tag = Printf.sprintf "_brakets_%04d" n in
- { module_name = name ^ tag;
- used_modules = (used_modules () @
- [Full constants_module.module_name;
- Full variables_module.module_name]);
- default_accessibility = Private;
- public_symbols = ["compute" ^ tag];
- print_declarations = [];
- print_implementations = [print_compute_brakets processes] } in
-
- let chopped_fusions, chopped_brakets =
- chop_amplitudes size amplitudes in
-
- let fusions_modules =
- List.map fusions_module chopped_fusions in
-
- let brakets_modules =
- List.map brakets_module chopped_brakets in
-
- let print_implementations () =
- print_interface amplitudes;
- print_calculate_amplitudes
- (fun () -> ())
- (print_compute_chops chopped_fusions chopped_brakets)
- amplitudes in
-
- let public_module =
- { module_name = name;
- used_modules = (used_modules () @
- [Full constants_module.module_name;
- Full variables_module.module_name ] @
- List.map
- (fun m -> Full m.module_name)
- (fusions_modules @ brakets_modules));
- default_accessibility = Private;
- public_symbols = public_symbols ();
- print_declarations = [];
- print_implementations = [print_implementations] }
- and private_modules =
- [constants_module; variables_module] @
- fusions_modules @ brakets_modules in
- (public_module, private_modules)
-
- let amplitudes_to_channel_single_file cmdline oc size amplitudes =
- let public_module, private_modules =
- modules_of_amplitudes cmdline oc size amplitudes in
- Format_Fortran.set_formatter_out_channel ~width:!line_length oc;
- print_description cmdline amplitudes ();
- print_modules (private_modules @ [public_module])
-
- let amplitudes_to_channel_multi_file cmdline oc size amplitudes =
- let public_module, private_modules =
- modules_of_amplitudes cmdline oc size amplitudes in
- modules_to_file !line_length oc
- (print_description cmdline amplitudes)
- (public_module :: private_modules)
-
-(* \thocwmodulesubsection{Dispatch} *)
-
- let amplitudes_to_channel cmdline oc diagnostics amplitudes =
- parse_diagnostics diagnostics;
- let ufo_fusions =
- let ufo_fusions_set = ufo_fusions_used amplitudes in
- if Sets.String.is_empty ufo_fusions_set then
- None
- else
- Some ufo_fusions_set in
- begin match ufo_fusions with
- | Some only ->
- let name = !module_name ^ "_ufo"
- and fortran_module = Fermions.use_module in
- use_modules := name :: !use_modules;
- UFO.Targets.Fortran.lorentz_module
- ~only ~name ~fortran_module ~parameter_module:!parameter_module
- (Format_Fortran.formatter_of_out_channel oc) ()
- | None -> ()
- end;
- match !output_mode with
- | Single_Function ->
- amplitudes_to_channel_single_function cmdline oc amplitudes
- | Single_Module size ->
- amplitudes_to_channel_single_module cmdline oc size amplitudes
- | Single_File size ->
- amplitudes_to_channel_single_file cmdline oc size amplitudes
- | Multi_File size ->
- amplitudes_to_channel_multi_file cmdline oc size amplitudes
-
- let parameters_to_channel oc =
- parameters_to_fortran oc (CM.parameters ())
-
- end
-
-module Fortran = Make_Fortran(Fortran_Fermions)
-
-(* \thocwmodulesubsection{Majorana Fermions} *)
-
-(* \begin{JR}
- For this function we need a different approach due to our aim of
- implementing the fermion vertices with the right line as ingoing (in a
- calculational sense) and the left line in a fusion as outgoing. In
- defining all external lines and the fermionic wavefunctions built out of
- them as ingoing we have to invert the left lines to make them outgoing.
- This happens by multiplying them with the inverse charge conjugation
- matrix in an appropriate representation and then transposing it. We must
- distinguish whether the direction of calculation and the physical direction
- of the fermion number flow are parallel or antiparallel. In the first case
- we can use the "normal" Feynman rules for Dirac particles, while in the
- second, according to the paper of Denner et al., we have to reverse the
- sign of the vector and antisymmetric bilinears of the Dirac spinors, cf.
- the [Coupling] module.
-
- Note the subtlety for the left- and righthanded couplings: Only the vector
- part of these couplings changes in the appropriate cases its sign,
- changing the chirality to the negative of the opposite.
- \end{JR} *)
-
-module Fortran_Majorana_Fermions : Fermions =
- struct
- open Coupling
- open Format
-
- let psi_type = "bispinor"
- let psibar_type = "bispinor"
- let chi_type = "bispinor"
- let grav_type = "vectorspinor"
-
-(* \begin{JR}
- Because of our rules for fermions we are going to give all incoming fermions
- a [u] spinor and all outgoing fermions a [v] spinor, no matter whether they
- are Dirac fermions, antifermions or Majorana fermions.
- \end{JR} *)
-
- let psi_incoming = "u"
- let brs_psi_incoming = "brs_u"
- let psibar_incoming = "u"
- let brs_psibar_incoming = "brs_u"
- let chi_incoming = "u"
- let brs_chi_incoming = "brs_u"
- let grav_incoming = "ueps"
-
- let psi_outgoing = "v"
- let brs_psi_outgoing = "brs_v"
- let psibar_outgoing = "v"
- let brs_psibar_outgoing = "brs_v"
- let chi_outgoing = "v"
- let brs_chi_outgoing = "brs_v"
- let grav_outgoing = "veps"
-
- let psi_propagator = "pr_psi"
- let psibar_propagator = "pr_psi"
- let chi_propagator = "pr_psi"
- let grav_propagator = "pr_grav"
-
- let psi_projector = "pj_psi"
- let psibar_projector = "pj_psi"
- let chi_projector = "pj_psi"
- let grav_projector = "pj_grav"
-
- let psi_gauss = "pg_psi"
- let psibar_gauss = "pg_psi"
- let chi_gauss = "pg_psi"
- let grav_gauss = "pg_grav"
-
- let format_coupling coeff c =
- match coeff with
- | 1 -> c
- | -1 -> "(-" ^ c ^")"
- | coeff -> string_of_int coeff ^ "*" ^ c
-
- let format_coupling_2 coeff c =
- match coeff with
- | 1 -> c
- | -1 -> "-" ^ c
- | coeff -> string_of_int coeff ^ "*" ^ c
-
-(* \begin{dubious}
- JR's coupling constant HACK, necessitated by tho's bad design descition.
- \end{dubious} *)
-
- let fastener s i =
- try
- let offset = (String.index s '(') in
- if ((String.get s (String.length s - 1)) != ')') then
- failwith "fastener: wrong usage of parentheses"
- else
- let func_name = (String.sub s 0 offset) and
- tail =
- (String.sub s (succ offset) (String.length s - offset - 2)) in
- if (String.contains func_name ')') ||
- (String.contains tail '(') ||
- (String.contains tail ')') then
- failwith "fastener: wrong usage of parentheses"
- else
- func_name ^ "(" ^ string_of_int i ^ "," ^ tail ^ ")"
- with
- | Not_found ->
- if (String.contains s ')') then
- failwith "fastener: wrong usage of parentheses"
- else
- s ^ "(" ^ string_of_int i ^ ")"
-
- let print_fermion_current coeff f c wf1 wf2 fusion =
- let c = format_coupling coeff c in
- match fusion with
- | F13 | F31 -> printf "%s_ff(%s,%s,%s)" f c wf1 wf2
- | F23 | F21 -> printf "f_%sf(%s,%s,%s)" f c wf1 wf2
- | F32 | F12 -> printf "f_%sf(%s,%s,%s)" f c wf2 wf1
-
- let print_fermion_current2 coeff f c wf1 wf2 fusion =
- let c = format_coupling_2 coeff c in
- let c1 = fastener c 1 and
- c2 = fastener c 2 in
- match fusion with
- | F13 | F31 -> printf "%s_ff(%s,%s,%s,%s)" f c1 c2 wf1 wf2
- | F23 | F21 -> printf "f_%sf(%s,%s,%s,%s)" f c1 c2 wf1 wf2
- | F32 | F12 -> printf "f_%sf(%s,%s,%s,%s)" f c1 c2 wf2 wf1
-
- let print_fermion_current_mom_v1 coeff f c wf1 wf2 p1 p2 p12 fusion =
- let c = format_coupling coeff c in
- let c1 = fastener c 1 and
- c2 = fastener c 2 in
- match fusion with
- | F13 -> printf "%s_ff(%s,%s,%s,%s)" f c1 c2 wf1 wf2
- | F31 -> printf "%s_ff(-(%s),%s,%s,%s)" f c1 c2 wf1 wf2
- | F23 -> printf "f_%sf(%s,%s,%s,%s)" f c1 c2 wf1 wf2
- | F32 -> printf "f_%sf(%s,%s,%s,%s)" f c1 c2 wf2 wf1
- | F12 -> printf "f_f%s(-(%s),%s,%s,%s)" f c1 c2 wf2 wf1
- | F21 -> printf "f_f%s(-(%s),%s,%s,%s)" f c1 c2 wf1 wf2
-
- let print_fermion_current_mom_v1_chiral coeff f c wf1 wf2 p1 p2 p12 fusion =
- let c = format_coupling coeff c in
- let c1 = fastener c 1 and
- c2 = fastener c 2 in
- match fusion with
- | F13 -> printf "%s_ff(%s,%s,%s,%s)" f c1 c2 wf1 wf2
- | F31 -> printf "%s_ff(-(%s),-(%s),%s,%s)" f c2 c1 wf1 wf2
- | F23 -> printf "f_%sf(%s,%s,%s,%s)" f c1 c2 wf1 wf2
- | F32 -> printf "f_%sf(%s,%s,%s,%s)" f c1 c2 wf2 wf1
- | F12 -> printf "f_f%s(-(%s),-(%s),%s,%s)" f c2 c1 wf2 wf1
- | F21 -> printf "f_f%s(-(%s),-(%s),%s,%s)" f c2 c1 wf2 wf1
-
- let print_fermion_current_mom_v2 coeff f c wf1 wf2 p1 p2 p12 fusion =
- let c = format_coupling coeff c in
- let c1 = fastener c 1 and
- c2 = fastener c 2 in
- match fusion with
- | F13 -> printf "%s_ff(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p12
- | F31 -> printf "%s_ff(-(%s),%s,%s,%s,%s)" f c1 c2 wf1 wf2 p12
- | F23 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p1
- | F32 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf2 wf1 p2
- | F12 -> printf "f_f%s(-(%s),%s,%s,%s,%s)" f c1 c2 wf2 wf1 p2
- | F21 -> printf "f_f%s(-(%s),%s,%s,%s,%s)" f c1 c2 wf1 wf2 p1
-
- let print_fermion_current_mom_v2_chiral coeff f c wf1 wf2 p1 p2 p12 fusion =
- let c = format_coupling coeff c in
- let c1 = fastener c 1 and
- c2 = fastener c 2 in
- match fusion with
- | F13 -> printf "%s_ff(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p12
- | F31 -> printf "%s_ff(-(%s),-(%s),%s,%s,%s)" f c2 c1 wf2 wf1 p12
- | F23 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p1
- | F32 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf2 wf1 p2
- | F12 -> printf "f_f%s(-(%s),-(%s),%s,%s,%s)" f c2 c1 wf1 wf2 p2
- | F21 -> printf "f_f%s(-(%s),-(%s),%s,%s,%s)" f c2 c1 wf2 wf1 p1
-
- let print_fermion_current_vector coeff f c wf1 wf2 fusion =
- let c = format_coupling coeff c in
- match fusion with
- | F13 -> printf "%s_ff(%s,%s,%s)" f c wf1 wf2
- | F31 -> printf "%s_ff(-%s,%s,%s)" f c wf1 wf2
- | F23 -> printf "f_%sf(%s,%s,%s)" f c wf1 wf2
- | F32 -> printf "f_%sf(%s,%s,%s)" f c wf2 wf1
- | F12 -> printf "f_%sf(-%s,%s,%s)" f c wf2 wf1
- | F21 -> printf "f_%sf(-%s,%s,%s)" f c wf1 wf2
-
- let print_fermion_current2_vector coeff f c wf1 wf2 fusion =
- let c = format_coupling_2 coeff c in
- let c1 = fastener c 1 and
- c2 = fastener c 2 in
- match fusion with
- | F13 -> printf "%s_ff(%s,%s,%s,%s)" f c1 c2 wf1 wf2
- | F31 -> printf "%s_ff(-(%s),%s,%s,%s)" f c1 c2 wf1 wf2
- | F23 -> printf "f_%sf(%s,%s,%s,%s)" f c1 c2 wf1 wf2
- | F32 -> printf "f_%sf(%s,%s,%s,%s)" f c1 c2 wf2 wf1
- | F12 -> printf "f_%sf(-(%s),%s,%s,%s)" f c1 c2 wf2 wf1
- | F21 -> printf "f_%sf(-(%s),%s,%s,%s)" f c1 c2 wf1 wf2
-
- let print_fermion_current_chiral coeff f1 f2 c wf1 wf2 fusion =
- let c = format_coupling coeff c in
- match fusion with
- | F13 -> printf "%s_ff(%s,%s,%s)" f1 c wf1 wf2
- | F31 -> printf "%s_ff(-%s,%s,%s)" f2 c wf1 wf2
- | F23 -> printf "f_%sf(%s,%s,%s)" f1 c wf1 wf2
- | F32 -> printf "f_%sf(%s,%s,%s)" f1 c wf2 wf1
- | F12 -> printf "f_%sf(-%s,%s,%s)" f2 c wf2 wf1
- | F21 -> printf "f_%sf(-%s,%s,%s)" f2 c wf1 wf2
-
- let print_fermion_current2_chiral coeff f c wf1 wf2 fusion =
- let c = format_coupling_2 coeff c in
- let c1 = fastener c 1 and
- c2 = fastener c 2 in
- match fusion with
- | F13 -> printf "%s_ff(%s,%s,%s,%s)" f c1 c2 wf1 wf2
- | F31 -> printf "%s_ff(-(%s),-(%s),%s,%s)" f c2 c1 wf1 wf2
- | F23 -> printf "f_%sf(%s,%s,%s,%s)" f c1 c2 wf1 wf2
- | F32 -> printf "f_%sf(%s,%s,%s,%s)" f c1 c2 wf2 wf1
- | F12 -> printf "f_%sf(-(%s),-(%s),%s,%s)" f c2 c1 wf2 wf1
- | F21 -> printf "f_%sf(-(%s),-(%s),%s,%s)" f c2 c1 wf1 wf2
-
- let print_current = function
- | coeff, _, VA, _ -> print_fermion_current2_vector coeff "va"
- | coeff, _, V, _ -> print_fermion_current_vector coeff "v"
- | coeff, _, A, _ -> print_fermion_current coeff "a"
- | coeff, _, VL, _ -> print_fermion_current_chiral coeff "vl" "vr"
- | coeff, _, VR, _ -> print_fermion_current_chiral coeff "vr" "vl"
- | coeff, _, VLR, _ -> print_fermion_current2_chiral coeff "vlr"
- | coeff, _, SP, _ -> print_fermion_current2 coeff "sp"
- | coeff, _, S, _ -> print_fermion_current coeff "s"
- | coeff, _, P, _ -> print_fermion_current coeff "p"
- | coeff, _, SL, _ -> print_fermion_current coeff "sl"
- | coeff, _, SR, _ -> print_fermion_current coeff "sr"
- | coeff, _, SLR, _ -> print_fermion_current2 coeff "slr"
- | coeff, _, POT, _ -> print_fermion_current_vector coeff "pot"
- | _, _, _, _ -> invalid_arg
- "Targets.Fortran_Majorana_Fermions: Not needed in the models"
-
- let print_current_p = function
- | coeff, Psi, SL, Psi -> print_fermion_current coeff "sl"
- | coeff, Psi, SR, Psi -> print_fermion_current coeff "sr"
- | coeff, Psi, SLR, Psi -> print_fermion_current2 coeff "slr"
- | _, _, _, _ -> invalid_arg
- "Targets.Fortran_Majorana_Fermions: Not needed in the used models"
-
- let print_current_b = function
- | coeff, Psibar, SL, Psibar -> print_fermion_current coeff "sl"
- | coeff, Psibar, SR, Psibar -> print_fermion_current coeff "sr"
- | coeff, Psibar, SLR, Psibar -> print_fermion_current2 coeff "slr"
- | _, _, _, _ -> invalid_arg
- "Targets.Fortran_Majorana_Fermions: Not needed in the used models"
-
-(* This function is for the vertices with three particles including two
- fermions but also a momentum, therefore with a dimensionful coupling
- constant, e.g. the gravitino vertices. One has to dinstinguish between
- the two kinds of canonical orders in the string of gamma matrices. Of
- course, the direction of the string of gamma matrices is reversed if one
- goes from the [Gravbar, _, Psi] to the [Psibar, _, Grav] vertices, and
- the same is true for the couplings of the gravitino to the Majorana
- fermions. For more details see the tables in the [coupling]
- implementation. *)
-
-(* We now have to fix the directions of the momenta. For making the compiler
- happy and because we don't want to make constructions of infinite
- complexity we list the momentum including vertices without gravitinos
- here; the pattern matching says that's better. Perhaps we have to find a
- better name now.
-
- For the cases of $MOM$, $MOM5$, $MOML$ and $MOMR$ which arise only in
- BRST transformations we take the mass as a coupling constant. For
- $VMOM$ we don't need a mass either. These vertices are like kinetic terms
- and so need not have a coupling constant. By this we avoid a strange and
- awful construction with a new variable. But be careful with a
- generalization if you want to use these vertices for other purposes.
-*)
-
- let format_coupling_mom coeff c =
- match coeff with
- | 1 -> c
- | -1 -> "(-" ^ c ^")"
- | coeff -> string_of_int coeff ^ "*" ^ c
-
- let commute_proj f =
- match f with
- | "moml" -> "lmom"
- | "momr" -> "rmom"
- | "lmom" -> "moml"
- | "rmom" -> "momr"
- | "svl" -> "svr"
- | "svr" -> "svl"
- | "sl" -> "sr"
- | "sr" -> "sl"
- | "s" -> "s"
- | "p" -> "p"
- | _ -> invalid_arg "Targets:Fortran_Majorana_Fermions: wrong case"
-
- let print_fermion_current_mom coeff f c wf1 wf2 p1 p2 p12 fusion =
- let c = format_coupling_mom coeff c in
- let c1 = fastener c 1 and
- c2 = fastener c 2 in
- match fusion with
- | F13 -> printf "%s_ff(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p12
- | F31 -> printf "%s_ff(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p12
- | F23 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p1
- | F32 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf2 wf1 p2
- | F12 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf2 wf1 p2
- | F21 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p1
-
- (*i unused value
- let print_fermion_current_mom_vector coeff f c wf1 wf2 p1 p2 p12 fusion =
- let c = format_coupling_mom coeff c in
- let c1 = fastener c 1 and
- c2 = fastener c 2 in
- match fusion with
- | F13 -> printf "%s_ff(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p12
- | F31 -> printf "%s_ff(-%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p12
- | F23 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p1
- | F32 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf2 wf1 p2
- | F12 -> printf "f_%sf(-%s,%s,%s,%s,%s)" f c1 c2 wf2 wf1 p2
- | F21 -> printf "f_%sf(-%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p1
- i*)
-
- let print_fermion_current_mom_sign coeff f c wf1 wf2 p1 p2 p12 fusion =
- let c = format_coupling_mom coeff c in
- let c1 = fastener c 1 and
- c2 = fastener c 2 in
- match fusion with
- | F13 -> printf "%s_ff(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p12
- | F31 -> printf "%s_ff(%s,%s,%s,%s,-(%s))" f c1 c2 wf1 wf2 p12
- | F23 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p1
- | F32 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf2 wf1 p2
- | F12 -> printf "f_%sf(%s,%s,%s,%s,-(%s))" f c1 c2 wf2 wf1 p2
- | F21 -> printf "f_%sf(%s,%s,%s,%s,-(%s))" f c1 c2 wf1 wf2 p1
-
- let print_fermion_current_mom_sign_1 coeff f c wf1 wf2 p1 p2 p12 fusion =
- let c = format_coupling coeff c in
- match fusion with
- | F13 -> printf "%s_ff(%s,%s,%s,%s)" f c wf1 wf2 p12
- | F31 -> printf "%s_ff(%s,%s,%s,-(%s))" f c wf1 wf2 p12
- | F23 -> printf "f_%sf(%s,%s,%s,%s)" f c wf1 wf2 p1
- | F32 -> printf "f_%sf(%s,%s,%s,%s)" f c wf2 wf1 p2
- | F12 -> printf "f_%sf(%s,%s,%s,-(%s))" f c wf2 wf1 p2
- | F21 -> printf "f_%sf(%s,%s,%s,-(%s))" f c wf1 wf2 p1
-
- let print_fermion_current_mom_chiral coeff f c wf1 wf2 p1 p2 p12 fusion =
- let c = format_coupling_mom coeff c and
- cf = commute_proj f in
- let c1 = fastener c 1 and
- c2 = fastener c 2 in
- match fusion with
- | F13 -> printf "%s_ff(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p12
- | F31 -> printf "%s_ff(%s,%s,%s, %s,-(%s))" cf c1 c2 wf1 wf2 p12
- | F23 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p1
- | F32 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf2 wf1 p2
- | F12 -> printf "f_%sf(%s,%s,%s,%s,-(%s))" cf c1 c2 wf2 wf1 p2
- | F21 -> printf "f_%sf(%s,%s,%s,%s,-(%s))" cf c1 c2 wf1 wf2 p1
-
- let print_fermion_g_current coeff f c wf1 wf2 p1 p2 p12 fusion =
- let c = format_coupling coeff c in
- match fusion with
- | F13 -> printf "%s_grf(%s,%s,%s,%s)" f c wf1 wf2 p12
- | F31 -> printf "%s_fgr(%s,%s,%s,%s)" f c wf1 wf2 p12
- | F23 -> printf "gr_%sf(%s,%s,%s,%s)" f c wf1 wf2 p1
- | F32 -> printf "gr_%sf(%s,%s,%s,%s)" f c wf2 wf1 p2
- | F12 -> printf "f_%sgr(%s,%s,%s,%s)" f c wf2 wf1 p2
- | F21 -> printf "f_%sgr(%s,%s,%s,%s)" f c wf1 wf2 p1
-
- let print_fermion_g_2_current coeff f c wf1 wf2 p1 p2 p12 fusion =
- let c = format_coupling coeff c in
- match fusion with
- | F13 -> printf "%s_grf(%s(1),%s(2),%s,%s,%s)" f c c wf1 wf2 p12
- | F31 -> printf "%s_fgr(%s(1),%s(2),%s,%s,%s)" f c c wf1 wf2 p12
- | F23 -> printf "gr_%sf(%s(1),%s(2),%s,%s,%s)" f c c wf1 wf2 p1
- | F32 -> printf "gr_%sf(%s(1),%s(2),%s,%s,%s)" f c c wf2 wf1 p2
- | F12 -> printf "f_%sgr(%s(1),%s(2),%s,%s,%s)" f c c wf2 wf1 p2
- | F21 -> printf "f_%sgr(%s(1),%s(2),%s,%s,%s)" f c c wf1 wf2 p1
-
- let print_fermion_g_current_rev coeff f c wf1 wf2 p1 p2 p12 fusion =
- let c = format_coupling coeff c in
- match fusion with
- | F13 -> printf "%s_fgr(%s,%s,%s,%s)" f c wf1 wf2 p12
- | F31 -> printf "%s_grf(%s,%s,%s,%s)" f c wf1 wf2 p12
- | F23 -> printf "f_%sgr(%s,%s,%s,%s)" f c wf1 wf2 p1
- | F32 -> printf "f_%sgr(%s,%s,%s,%s)" f c wf2 wf1 p2
- | F12 -> printf "gr_%sf(%s,%s,%s,%s)" f c wf2 wf1 p2
- | F21 -> printf "gr_%sf(%s,%s,%s,%s)" f c wf1 wf2 p1
-
- let print_fermion_g_2_current_rev coeff f c wf1 wf2 p1 p2 p12 fusion =
- let c = format_coupling coeff c in
- match fusion with
- | F13 -> printf "%s_fgr(%s(1),%s(2),%s,%s,%s)" f c c wf1 wf2 p12
- | F31 -> printf "%s_grf(%s(1),%s(2),%s,%s,%s)" f c c wf1 wf2 p12
- | F23 -> printf "f_%sgr(%s(1),%s(2),%s,%s,%s)" f c c wf1 wf2 p1
- | F32 -> printf "f_%sgr(%s(1),%s(2),%s,%s,%s)" f c c wf2 wf1 p2
- | F12 -> printf "gr_%sf(%s(1),%s(2),%s,%s,%s)" f c c wf2 wf1 p2
- | F21 -> printf "gr_%sf(%s(1),%s(2),%s,%s,%s)" f c c wf1 wf2 p1
-
- let print_fermion_g_current_vector coeff f c wf1 wf2 _ _ _ fusion =
- let c = format_coupling coeff c in
- match fusion with
- | F13 -> printf "%s_grf(%s,%s,%s)" f c wf1 wf2
- | F31 -> printf "%s_fgr(-%s,%s,%s)" f c wf1 wf2
- | F23 -> printf "gr_%sf(%s,%s,%s)" f c wf1 wf2
- | F32 -> printf "gr_%sf(%s,%s,%s)" f c wf2 wf1
- | F12 -> printf "f_%sgr(-%s,%s,%s)" f c wf2 wf1
- | F21 -> printf "f_%sgr(-%s,%s,%s)" f c wf1 wf2
-
- let print_fermion_g_current_vector_rev coeff f c wf1 wf2 _ _ _ fusion =
- let c = format_coupling coeff c in
- match fusion with
- | F13 -> printf "%s_fgr(%s,%s,%s)" f c wf1 wf2
- | F31 -> printf "%s_grf(-%s,%s,%s)" f c wf1 wf2
- | F23 -> printf "f_%sgr(%s,%s,%s)" f c wf1 wf2
- | F32 -> printf "f_%sgr(%s,%s,%s)" f c wf2 wf1
- | F12 -> printf "gr_%sf(-%s,%s,%s)" f c wf2 wf1
- | F21 -> printf "gr_%sf(-%s,%s,%s)" f c wf1 wf2
-
- let print_current_g = function
- | coeff, _, MOM, _ -> print_fermion_current_mom_sign coeff "mom"
- | coeff, _, MOM5, _ -> print_fermion_current_mom coeff "mom5"
- | coeff, _, MOML, _ -> print_fermion_current_mom_chiral coeff "moml"
- | coeff, _, MOMR, _ -> print_fermion_current_mom_chiral coeff "momr"
- | coeff, _, LMOM, _ -> print_fermion_current_mom_chiral coeff "lmom"
- | coeff, _, RMOM, _ -> print_fermion_current_mom_chiral coeff "rmom"
- | coeff, _, VMOM, _ -> print_fermion_current_mom_sign_1 coeff "vmom"
- | coeff, Gravbar, S, _ -> print_fermion_g_current coeff "s"
- | coeff, Gravbar, SL, _ -> print_fermion_g_current coeff "sl"
- | coeff, Gravbar, SR, _ -> print_fermion_g_current coeff "sr"
- | coeff, Gravbar, SLR, _ -> print_fermion_g_2_current coeff "slr"
- | coeff, Gravbar, P, _ -> print_fermion_g_current coeff "p"
- | coeff, Gravbar, V, _ -> print_fermion_g_current coeff "v"
- | coeff, Gravbar, VLR, _ -> print_fermion_g_2_current coeff "vlr"
- | coeff, Gravbar, POT, _ -> print_fermion_g_current_vector coeff "pot"
- | coeff, _, S, Grav -> print_fermion_g_current_rev coeff "s"
- | coeff, _, SL, Grav -> print_fermion_g_current_rev coeff "sl"
- | coeff, _, SR, Grav -> print_fermion_g_current_rev coeff "sr"
- | coeff, _, SLR, Grav -> print_fermion_g_2_current_rev coeff "slr"
- | coeff, _, P, Grav -> print_fermion_g_current_rev (-coeff) "p"
- | coeff, _, V, Grav -> print_fermion_g_current_rev coeff "v"
- | coeff, _, VLR, Grav -> print_fermion_g_2_current_rev coeff "vlr"
- | coeff, _, POT, Grav -> print_fermion_g_current_vector_rev coeff "pot"
- | _, _, _, _ -> invalid_arg
- "Targets.Fortran_Majorana_Fermions: not used in the models"
-
- let print_current_mom = function
- | coeff, _, TVA, _ -> print_fermion_current_mom_v1 coeff "tva"
- | coeff, _, TVAM, _ -> print_fermion_current_mom_v2 coeff "tvam"
- | coeff, _, TLR, _ -> print_fermion_current_mom_v1_chiral coeff "tlr"
- | coeff, _, TLRM, _ -> print_fermion_current_mom_v2_chiral coeff "tlrm"
- | _, _, _, _ -> invalid_arg
- "Targets.Fortran_Majorana_Fermions: Not needed in the models"
-
-(* We need support for dimension-5 vertices with two fermions and two
- bosons, appearing in theories of supergravity and also together with in
- insertions of the supersymmetric current. There is a canonical order
- [fermionbar], [boson_1], [boson_2], [fermion], so what one has to do is a
- mapping from the fusions [F123] etc. to the order of the three wave
- functions [wf1], [wf2] and [wf3]. *)
-
-(* The function [d_p] (for distinct the particle) distinguishes which particle
- (scalar or vector) must be fused to in the special functions. *)
-
- let d_p = function
- | 1, ("sv"|"pv"|"svl"|"svr"|"slrv") -> "1"
- | 1, _ -> ""
- | 2, ("sv"|"pv"|"svl"|"svr"|"slrv") -> "2"
- | 2, _ -> ""
- | _, _ -> invalid_arg "Targets.Fortran_Majorana_Fermions: not used"
-
- let wf_of_f wf1 wf2 wf3 f =
- match f with
- | (F123|F423) -> [wf2; wf3; wf1]
- | (F213|F243|F143|F142|F413|F412) -> [wf1; wf3; wf2]
- | (F132|F432) -> [wf3; wf2; wf1]
- | (F231|F234|F134|F124|F431|F421) -> [wf1; wf2; wf3]
- | (F312|F342) -> [wf3; wf1; wf2]
- | (F321|F324|F314|F214|F341|F241) -> [wf2; wf1; wf3]
-
- let print_fermion_g4_brs_vector_current coeff f c wf1 wf2 wf3 fusion =
- let cf = commute_proj f and
- cp = format_coupling coeff c and
- cm = if f = "pv" then
- format_coupling coeff c
- else
- format_coupling (-coeff) c
- and
- d1 = d_p (1,f) and
- d2 = d_p (2,f) and
- f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
- f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
- f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
- match fusion with
- | (F123|F213|F132|F231|F312|F321) ->
- printf "f_%sf(%s,%s,%s,%s)" cf cm f1 f2 f3
- | (F423|F243|F432|F234|F342|F324) ->
- printf "f_%sf(%s,%s,%s,%s)" f cp f1 f2 f3
- | (F134|F143|F314) -> printf "%s%s_ff(%s,%s,%s,%s)" f d1 cp f1 f2 f3
- | (F124|F142|F214) -> printf "%s%s_ff(%s,%s,%s,%s)" f d2 cp f1 f2 f3
- | (F413|F431|F341) -> printf "%s%s_ff(%s,%s,%s,%s)" cf d1 cm f1 f2 f3
- | (F241|F412|F421) -> printf "%s%s_ff(%s,%s,%s,%s)" cf d2 cm f1 f2 f3
-
- let print_fermion_g4_svlr_current coeff _ c wf1 wf2 wf3 fusion =
- let c = format_coupling_2 coeff c and
- f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
- f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
- f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
- let c1 = fastener c 1 and
- c2 = fastener c 2 in
- match fusion with
- | (F123|F213|F132|F231|F312|F321) ->
- printf "f_svlrf(-(%s),-(%s),%s,%s,%s)" c2 c1 f1 f2 f3
- | (F423|F243|F432|F234|F342|F324) ->
- printf "f_svlrf(%s,%s,%s,%s,%s)" c1 c2 f1 f2 f3
- | (F134|F143|F314) ->
- printf "svlr2_ff(%s,%s,%s,%s,%s)" c1 c2 f1 f2 f3
- | (F124|F142|F214) ->
- printf "svlr1_ff(%s,%s,%s,%s,%s)" c1 c2 f1 f2 f3
- | (F413|F431|F341) ->
- printf "svlr2_ff(-(%s),-(%s),%s,%s,%s)" c2 c1 f1 f2 f3
- | (F241|F412|F421) ->
- printf "svlr1_ff(-(%s),-(%s),%s,%s,%s)" c2 c1 f1 f2 f3
-
- let print_fermion_s2_current coeff f c wf1 wf2 wf3 fusion =
- let cp = format_coupling coeff c and
- cm = if f = "p" then
- format_coupling (-coeff) c
- else
- format_coupling coeff c
- and
- cf = commute_proj f and
- f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
- f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
- f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
- match fusion with
- | (F123|F213|F132|F231|F312|F321) ->
- printf "%s * f_%sf(%s,%s,%s)" f1 cf cm f2 f3
- | (F423|F243|F432|F234|F342|F324) ->
- printf "%s * f_%sf(%s,%s,%s)" f1 f cp f2 f3
- | (F134|F143|F314) ->
- printf "%s * %s_ff(%s,%s,%s)" f2 f cp f1 f3
- | (F124|F142|F214) ->
- printf "%s * %s_ff(%s,%s,%s)" f2 f cp f1 f3
- | (F413|F431|F341) ->
- printf "%s * %s_ff(%s,%s,%s)" f2 cf cm f1 f3
- | (F241|F412|F421) ->
- printf "%s * %s_ff(%s,%s,%s)" f2 cf cm f1 f3
-
- let print_fermion_s2p_current coeff f c wf1 wf2 wf3 fusion =
- let c = format_coupling_2 coeff c and
- f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
- f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
- f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
- let c1 = fastener c 1 and
- c2 = fastener c 2 in
- match fusion with
- | (F123|F213|F132|F231|F312|F321) ->
- printf "%s * f_%sf(%s,-(%s),%s,%s)" f1 f c1 c2 f2 f3
- | (F423|F243|F432|F234|F342|F324) ->
- printf "%s * f_%sf(%s,%s,%s,%s)" f1 f c1 c2 f2 f3
- | (F134|F143|F314) ->
- printf "%s * %s_ff(%s,%s,%s,%s)" f2 f c1 c2 f1 f3
- | (F124|F142|F214) ->
- printf "%s * %s_ff(%s,%s,%s,%s)" f2 f c1 c2 f1 f3
- | (F413|F431|F341) ->
- printf "%s * %s_ff(%s,-(%s),%s,%s)" f2 f c1 c2 f1 f3
- | (F241|F412|F421) ->
- printf "%s * %s_ff(%s,-(%s),%s,%s)" f2 f c1 c2 f1 f3
-
- let print_fermion_s2lr_current coeff f c wf1 wf2 wf3 fusion =
- let c = format_coupling_2 coeff c and
- f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
- f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
- f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
- let c1 = fastener c 1 and
- c2 = fastener c 2 in
- match fusion with
- | (F123|F213|F132|F231|F312|F321) ->
- printf "%s * f_%sf(%s,%s,%s,%s)" f1 f c2 c1 f2 f3
- | (F423|F243|F432|F234|F342|F324) ->
- printf "%s * f_%sf(%s,%s,%s,%s)" f1 f c1 c2 f2 f3
- | (F134|F143|F314) ->
- printf "%s * %s_ff(%s,%s,%s,%s)" f2 f c1 c2 f1 f3
- | (F124|F142|F214) ->
- printf "%s * %s_ff(%s,%s,%s,%s)" f2 f c1 c2 f1 f3
- | (F413|F431|F341) ->
- printf "%s * %s_ff(%s,%s,%s,%s)" f2 f c2 c1 f1 f3
- | (F241|F412|F421) ->
- printf "%s * %s_ff(%s,%s,%s,%s)" f2 f c2 c1 f1 f3
-
- let print_fermion_g4_current coeff f c wf1 wf2 wf3 fusion =
- let c = format_coupling coeff c and
- f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
- f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
- f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
- match fusion with
- | (F123|F213|F132|F231|F312|F321) ->
- printf "f_%sgr(-%s,%s,%s,%s)" f c f1 f2 f3
- | (F423|F243|F432|F234|F342|F324) ->
- printf "gr_%sf(%s,%s,%s,%s)" f c f1 f2 f3
- | (F134|F143|F314|F124|F142|F214) ->
- printf "%s_grf(%s,%s,%s,%s)" f c f1 f2 f3
- | (F413|F431|F341|F241|F412|F421) ->
- printf "%s_fgr(-%s,%s,%s,%s)" f c f1 f2 f3
-
- (*i unused value
- let print_fermion_2_g4_current coeff f c wf1 wf2 wf3 fusion =
- let f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
- f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
- f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
- let c = format_coupling_2 coeff c in
- let c1 = fastener c 1 and
- c2 = fastener c 2 in
- match fusion with
- | (F123|F213|F132|F231|F312|F321) ->
- printf "f_%sgr(-(%s),-(%s),%s,%s,%s)" f c2 c1 f1 f2 f3
- | (F423|F243|F432|F234|F342|F324) ->
- printf "gr_%sf(%s,%s,%s,%s,%s)" f c1 c2 f1 f2 f3
- | (F134|F143|F314|F124|F142|F214) ->
- printf "%s_grf(%s,%s,%s,%s,%s)" f c1 c2 f1 f2 f3
- | (F413|F431|F341|F241|F412|F421) ->
- printf "%s_fgr(-(%s),-(%s),%s,%s,%s)" f c2 c1 f1 f2 f3
- i*)
-
- let print_fermion_2_g4_current coeff f c wf1 wf2 wf3 fusion =
- let f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
- f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
- f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
- let c = format_coupling_2 coeff c in
- let c1 = fastener c 1 and
- c2 = fastener c 2 in
- match fusion with
- | (F123|F213|F132|F231|F312|F321) ->
- printf "f_%sgr(-(%s),-(%s),%s,%s,%s)" f c2 c1 f1 f2 f3
- | (F423|F243|F432|F234|F342|F324) ->
- printf "gr_%sf(%s,%s,%s,%s,%s)" f c1 c2 f1 f2 f3
- | (F134|F143|F314|F124|F142|F214) ->
- printf "%s_grf(%s,%s,%s,%s,%s)" f c1 c2 f1 f2 f3
- | (F413|F431|F341|F241|F412|F421) ->
- printf "%s_fgr(-(%s),-(%s),%s,%s,%s)" f c2 c1 f1 f2 f3
-
-
- let print_fermion_g4_current_rev coeff f c wf1 wf2 wf3 fusion =
- let c = format_coupling coeff c and
- f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
- f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
- f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
- match fusion with
- | (F123|F213|F132|F231|F312|F321) ->
- printf "f_%sgr(%s,%s,%s,%s)" f c f1 f2 f3
- | (F423|F243|F432|F234|F342|F324) ->
- printf "gr_%sf(-%s,%s,%s,%s)" f c f1 f2 f3
- | (F134|F143|F314|F124|F142|F214) ->
- printf "%s_grf(-%s,%s,%s,%s)" f c f1 f2 f3
- | (F413|F431|F341|F241|F412|F421) ->
- printf "%s_fgr(%s,%s,%s,%s)" f c f1 f2 f3
-
-(* Here we have to distinguish which of the two bosons is produced in the
- fusion of three particles which include both fermions. *)
-
- let print_fermion_g4_vector_current coeff f c wf1 wf2 wf3 fusion =
- let c = format_coupling coeff c and
- d1 = d_p (1,f) and
- d2 = d_p (2,f) and
- f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
- f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
- f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
- match fusion with
- | (F123|F213|F132|F231|F312|F321) ->
- printf "f_%sgr(%s,%s,%s,%s)" f c f1 f2 f3
- | (F423|F243|F432|F234|F342|F324) ->
- printf "gr_%sf(%s,%s,%s,%s)" f c f1 f2 f3
- | (F134|F143|F314) -> printf "%s%s_grf(%s,%s,%s,%s)" f d1 c f1 f2 f3
- | (F124|F142|F214) -> printf "%s%s_grf(%s,%s,%s,%s)" f d2 c f1 f2 f3
- | (F413|F431|F341) -> printf "%s%s_fgr(%s,%s,%s,%s)" f d1 c f1 f2 f3
- | (F241|F412|F421) -> printf "%s%s_fgr(%s,%s,%s,%s)" f d2 c f1 f2 f3
-
- let print_fermion_2_g4_vector_current coeff f c wf1 wf2 wf3 fusion =
- let d1 = d_p (1,f) and
- d2 = d_p (2,f) and
- f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
- f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
- f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
- let c = format_coupling_2 coeff c in
- let c1 = fastener c 1 and
- c2 = fastener c 2 in
- match fusion with
- | (F123|F213|F132|F231|F312|F321) ->
- printf "f_%sgr(%s,%s,%s,%s,%s)" f c1 c2 f1 f2 f3
- | (F423|F243|F432|F234|F342|F324) ->
- printf "gr_%sf(%s,%s,%s,%s,%s)" f c1 c2 f1 f2 f3
- | (F134|F143|F314) -> printf "%s%s_grf(%s,%s,%s,%s,%s)" f d1 c1 c2 f1 f2 f3
- | (F124|F142|F214) -> printf "%s%s_grf(%s,%s,%s,%s,%s)" f d2 c1 c2 f1 f2 f3
- | (F413|F431|F341) -> printf "%s%s_fgr(%s,%s,%s,%s,%s)" f d1 c1 c2 f1 f2 f3
- | (F241|F412|F421) -> printf "%s%s_fgr(%s,%s,%s,%s,%s)" f d2 c1 c2 f1 f2 f3
-
- let print_fermion_g4_vector_current_rev coeff f c wf1 wf2 wf3 fusion =
- let c = format_coupling coeff c and
- d1 = d_p (1,f) and
- d2 = d_p (2,f) and
- f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
- f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
- f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
- match fusion with
- | (F123|F213|F132|F231|F312|F321) ->
- printf "gr_%sf(%s,%s,%s,%s)" f c f1 f2 f3
- | (F423|F243|F432|F234|F342|F324) ->
- printf "f_%sgr(%s,%s,%s,%s)" f c f1 f2 f3
- | (F134|F143|F314) -> printf "%s%s_fgr(%s,%s,%s,%s)" f d1 c f1 f2 f3
- | (F124|F142|F214) -> printf "%s%s_fgr(%s,%s,%s,%s)" f d2 c f1 f2 f3
- | (F413|F431|F341) -> printf "%s%s_grf(%s,%s,%s,%s)" f d1 c f1 f2 f3
- | (F241|F412|F421) -> printf "%s%s_grf(%s,%s,%s,%s)" f d2 c f1 f2 f3
-
- let print_fermion_2_g4_current_rev coeff f c wf1 wf2 wf3 fusion =
- let c = format_coupling_2 coeff c in
- let c1 = fastener c 1 and
- c2 = fastener c 2 and
- d1 = d_p (1,f) and
- d2 = d_p (2,f) in
- let f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
- f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
- f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
- match fusion with
- | (F123|F213|F132|F231|F312|F321) ->
- printf "gr_%sf(%s,%s,%s,%s,%s)" f c1 c2 f1 f2 f3
- | (F423|F243|F432|F234|F342|F324) ->
- printf "f_%sgr(-(%s),-(%s),%s,%s,%s)" f c1 c2 f1 f2 f3
- | (F134|F143|F314) ->
- printf "%s%s_fgr(-(%s),-(%s),%s,%s,%s)" f d1 c1 c2 f1 f2 f3
- | (F124|F142|F214) ->
- printf "%s%s_fgr(-(%s),-(%s),%s,%s,%s)" f d2 c1 c2 f1 f2 f3
- | (F413|F431|F341) ->
- printf "%s%s_grf(%s,%s,%s,%s,%s)" f d1 c1 c2 f1 f2 f3
- | (F241|F412|F421) ->
- printf "%s%s_grf(%s,%s,%s,%s,%s)" f d2 c1 c2 f1 f2 f3
-
- let print_fermion_2_g4_vector_current_rev coeff f c wf1 wf2 wf3 fusion =
- (* Here we put in the extra minus sign from the coeff. *)
- let c = format_coupling coeff c in
- let c1 = fastener c 1 and
- c2 = fastener c 2 in
- let d1 = d_p (1,f) and
- d2 = d_p (2,f) and
- f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
- f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
- f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
- match fusion with
- | (F123|F213|F132|F231|F312|F321) ->
- printf "gr_%sf(%s,%s,%s,%s,%s)" f c1 c2 f1 f2 f3
- | (F423|F243|F432|F234|F342|F324) ->
- printf "f_%sgr(%s,%s,%s,%s,%s)" f c1 c2 f1 f2 f3
- | (F134|F143|F314) -> printf "%s%s_fgr(%s,%s,%s,%s,%s)" f d1 c1 c2 f1 f2 f3
- | (F124|F142|F214) -> printf "%s%s_fgr(%s,%s,%s,%s,%s)" f d2 c1 c2 f1 f2 f3
- | (F413|F431|F341) -> printf "%s%s_grf(%s,%s,%s,%s,%s)" f d1 c1 c2 f1 f2 f3
- | (F241|F412|F421) -> printf "%s%s_grf(%s,%s,%s,%s,%s)" f d2 c1 c2 f1 f2 f3
-
-
- let print_current_g4 = function
- | coeff, Gravbar, S2, _ -> print_fermion_g4_current coeff "s2"
- | coeff, Gravbar, SV, _ -> print_fermion_g4_vector_current coeff "sv"
- | coeff, Gravbar, SLV, _ -> print_fermion_g4_vector_current coeff "slv"
- | coeff, Gravbar, SRV, _ -> print_fermion_g4_vector_current coeff "srv"
- | coeff, Gravbar, SLRV, _ -> print_fermion_2_g4_vector_current coeff "slrv"
- | coeff, Gravbar, PV, _ -> print_fermion_g4_vector_current coeff "pv"
- | coeff, Gravbar, V2, _ -> print_fermion_g4_current coeff "v2"
- | coeff, Gravbar, V2LR, _ -> print_fermion_2_g4_current coeff "v2lr"
- | _, Gravbar, _, _ -> invalid_arg "print_current_g4: not implemented"
- | coeff, _, S2, Grav -> print_fermion_g4_current_rev coeff "s2"
- | coeff, _, SV, Grav -> print_fermion_g4_vector_current_rev (-coeff) "sv"
- | coeff, _, SLV, Grav -> print_fermion_g4_vector_current_rev (-coeff) "slv"
- | coeff, _, SRV, Grav -> print_fermion_g4_vector_current_rev (-coeff) "srv"
- | coeff, _, SLRV, Grav -> print_fermion_2_g4_vector_current_rev coeff "slrv"
- | coeff, _, PV, Grav -> print_fermion_g4_vector_current_rev coeff "pv"
- | coeff, _, V2, Grav -> print_fermion_g4_vector_current_rev coeff "v2"
- | coeff, _, V2LR, Grav -> print_fermion_2_g4_current_rev coeff "v2lr"
- | _, _, _, Grav -> invalid_arg "print_current_g4: not implemented"
- | coeff, _, S2, _ -> print_fermion_s2_current coeff "s"
- | coeff, _, P2, _ -> print_fermion_s2_current coeff "p"
- | coeff, _, S2P, _ -> print_fermion_s2p_current coeff "sp"
- | coeff, _, S2L, _ -> print_fermion_s2_current coeff "sl"
- | coeff, _, S2R, _ -> print_fermion_s2_current coeff "sr"
- | coeff, _, S2LR, _ -> print_fermion_s2lr_current coeff "slr"
- | coeff, _, V2, _ -> print_fermion_g4_brs_vector_current coeff "v2"
- | coeff, _, SV, _ -> print_fermion_g4_brs_vector_current coeff "sv"
- | coeff, _, PV, _ -> print_fermion_g4_brs_vector_current coeff "pv"
- | coeff, _, SLV, _ -> print_fermion_g4_brs_vector_current coeff "svl"
- | coeff, _, SRV, _ -> print_fermion_g4_brs_vector_current coeff "svr"
- | coeff, _, SLRV, _ -> print_fermion_g4_svlr_current coeff "svlr"
- | _, _, V2LR, _ -> invalid_arg "Targets.print_current: not available"
-
- let reverse_braket vintage bra ket =
- if vintage then
- false
- else
- match bra, ket with
- | Majorana, Majorana :: _ -> true
- | _, _ -> false
-
- let use_module = "omega95_bispinors"
- let require_library =
- ["omega_bispinors_2010_01_A"; "omega_bispinor_cpls_2010_01_A"]
- end
-
-module Fortran_Majorana = Make_Fortran(Fortran_Majorana_Fermions)
-
(* \thocwmodulesubsection{\texttt{FORTRAN\,77}} *)
module Fortran77 = Dummy
(* \thocwmodulesection{\texttt{C}} *)
module C = Dummy
(* \thocwmodulesubsection{\texttt{C++}} *)
module Cpp = Dummy
(* \thocwmodulesubsection{Java} *)
module Java = Dummy
(* \thocwmodulesection{O'Caml} *)
module Ocaml = Dummy
(* \thocwmodulesection{\LaTeX} *)
module LaTeX = Dummy
Index: trunk/omega/src/modellib_Zprime.ml
===================================================================
--- trunk/omega/src/modellib_Zprime.ml (revision 8899)
+++ trunk/omega/src/modellib_Zprime.ml (revision 8900)
@@ -1,631 +1,635 @@
(* modellib_Zprime.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
(* \thocwmodulesection{SM with additional Z'} *)
module type SM_flags =
sig
val include_anomalous : bool
val k_matrix : bool
end
module SM_no_anomalous : SM_flags =
struct
let include_anomalous = false
let k_matrix = false
end
module Zprime (Flags : SM_flags) =
struct
open Coupling
let default_width = ref Timelike
let use_fudged_width = ref false
let options = Options.create
[ "constant_width", Arg.Unit (fun () -> default_width := Constant),
"use constant width (also in t-channel)";
"fudged_width", Arg.Set use_fudged_width,
"use fudge factor for charge particle width";
"custom_width", Arg.String (fun f -> default_width := Custom f),
"use custom width";
"cancel_widths", Arg.Unit (fun () -> default_width := Vanishing),
"use vanishing width";
"running_width", Arg.Unit (fun () -> default_width := Running),
"use running width" ]
let caveats () = []
(* We do not introduce the Goldstones for the heavy vectors here. *)
type matter_field = L of int | N of int | U of int | D of int
type gauge_boson = Ga | Wp | Wm | Z | Gl | ZH
type other = Phip | Phim | Phi0 | H
type flavor = M of matter_field | G of gauge_boson | O of other
let matter_field f = M f
let gauge_boson f = G f
let other f = O f
type field =
| Matter of matter_field
| Gauge of gauge_boson
| Other of other
let field = function
| M f -> Matter f
| G f -> Gauge f
| O f -> Other f
type gauge = unit
let gauge_symbol () =
failwith "Models.Zprime.gauge_symbol: internal error"
let family n = List.map matter_field [ L n; N n; U n; D n ]
let external_flavors () =
[ "1st Generation", ThoList.flatmap family [1; -1];
"2nd Generation", ThoList.flatmap family [2; -2];
"3rd Generation", ThoList.flatmap family [3; -3];
"Gauge Bosons", List.map gauge_boson [Ga; Z; Wp; Wm; Gl; ZH];
"Higgs", [O H];
"Goldstone Bosons", List.map other [Phip; Phim; Phi0] ]
let flavors () = ThoList.flatmap snd (external_flavors ())
let spinor n =
if n >= 0 then
Spinor
else
ConjSpinor
let lorentz = function
| M f ->
begin match f with
| L n -> spinor n | N n -> spinor n
| U n -> spinor n | D n -> spinor n
end
| G f ->
begin match f with
| Ga | Gl -> Vector
| Wp | Wm | Z | ZH -> Massive_Vector
end
| O f ->
Scalar
let color = function
| M (U n) -> Color.SUN (if n > 0 then 3 else -3)
| M (D n) -> Color.SUN (if n > 0 then 3 else -3)
| G Gl -> Color.AdjSUN 3
| _ -> Color.Singlet
let nc () = 3
let prop_spinor n =
if n >= 0 then
Prop_Spinor
else
Prop_ConjSpinor
let propagator = function
| M f ->
begin match f with
| L n -> prop_spinor n | N n -> prop_spinor n
| U n -> prop_spinor n | D n -> prop_spinor n
end
| G f ->
begin match f with
| Ga | Gl -> Prop_Feynman
| Wp | Wm | Z | ZH -> Prop_Unitarity
end
| O f ->
begin match f with
| Phip | Phim | Phi0 -> Only_Insertion
| H -> Prop_Scalar
end
(* Optionally, ask for the fudge factor treatment for the widths of
charged particles. Currently, this only applies to $W^\pm$ and top. *)
let width f =
if !use_fudged_width then
match f with
| G Wp | G Wm | M (U 3) | M (U (-3))
| _ -> !default_width
else
!default_width
let goldstone = function
| G f ->
begin match f with
| Wp -> Some (O Phip, Coupling.Integer 1)
| Wm -> Some (O Phim, Coupling.Integer 1)
| Z -> Some (O Phi0, Coupling.Integer 1)
| _ -> None
end
| _ -> None
let conjugate = function
| M f ->
M (begin match f with
| L n -> L (-n) | N n -> N (-n)
| U n -> U (-n) | D n -> D (-n)
end)
| G f ->
G (begin match f with
| Gl -> Gl | Ga -> Ga | Z -> Z
| Wp -> Wm | Wm -> Wp | ZH -> ZH
end)
| O f ->
O (begin match f with
| Phip -> Phim | Phim -> Phip | Phi0 -> Phi0
| H -> H
end)
let fermion = function
| M f ->
begin match f with
| L n -> if n > 0 then 1 else -1
| N n -> if n > 0 then 1 else -1
| U n -> if n > 0 then 1 else -1
| D n -> if n > 0 then 1 else -1
end
| G f ->
begin match f with
| Gl | Ga | Z | Wp | Wm | ZH -> 0
end
| O _ -> 0
(* Electrical charge, lepton number, baryon number. We could avoid the
rationals altogether by multiplying the first and last by 3 \ldots *)
module Ch = Charges.QQ
let ( // ) = Algebra.Small_Rational.make
let generation' = function
| 1 -> [ 1//1; 0//1; 0//1]
| 2 -> [ 0//1; 1//1; 0//1]
| 3 -> [ 0//1; 0//1; 1//1]
| -1 -> [-1//1; 0//1; 0//1]
| -2 -> [ 0//1; -1//1; 0//1]
| -3 -> [ 0//1; 0//1; -1//1]
| n -> invalid_arg ("Zprime.generation': " ^ string_of_int n)
let generation f =
match f with
| M (L n | N n | U n | D n) -> generation' n
| G _ | O _ -> [0//1; 0//1; 0//1]
let charge = function
| M f ->
begin match f with
| L n -> if n > 0 then -1//1 else 1//1
| N n -> 0//1
| U n -> if n > 0 then 2//3 else -2//3
| D n -> if n > 0 then -1//3 else 1//3
end
| G f ->
begin match f with
| Gl | Ga | Z | ZH -> 0//1
| Wp -> 1//1
| Wm -> -1//1
end
| O f ->
begin match f with
| H | Phi0 -> 0//1
| Phip -> 1//1
| Phim -> -1//1
end
let lepton = function
| M f ->
begin match f with
| L n | N n -> if n > 0 then 1//1 else -1//1
| U _ | D _ -> 0//1
end
| G _ | O _ -> 0//1
let baryon = function
| M f ->
begin match f with
| L _ | N _ -> 0//1
| U n | D n -> if n > 0 then 1//1 else -1//1
end
| G _ | O _ -> 0//1
let charges f =
[ charge f; lepton f; baryon f] @ generation f
type constant =
| Unit | Pi | Alpha_QED | Sin2thw
| Sinthw | Costhw | E | G_weak | Vev
| Q_lepton | Q_up | Q_down | G_CC
| G_NC_neutrino | G_NC_lepton | G_NC_up | G_NC_down
| G_NC_h_neutrino | G_NC_h_lepton | G_NC_h_up | G_NC_h_down
| I_Q_W | I_G_ZWW | I_G_WWW
| G_WWWW | G_ZZWW | G_AZWW | G_AAWW
| G_HWW | G_HHWW | G_HZZ | G_HHZZ
| G_Htt | G_Hbb | G_Hcc | G_Htautau | G_H3 | G_H4
| Gs | I_Gs | G2
| Mass of flavor | Width of flavor
(* Two integer counters for the QCD and EW order of the couplings. *)
- type orders = int * int
+ type coupling_order = QCD | EW
+ let all_coupling_orders () = [QCD; EW]
+ let coupling_order_to_string = function
+ | QCD -> "QCD"
+ | EW -> "EW"
- let orders = function
- | _ -> (0,0)
+ let coupling_orders = function
+ | _ -> failwith "Modellib_Zprime.Zprime.orders: not implemented yet!"
let input_parameters =
[]
let derived_parameters =
[]
let g_over_2_costh =
Quot (Neg (Atom G_weak), Prod [Integer 2; Atom Costhw])
let nc_coupling c t3 q =
(Real_Array c,
[Prod [g_over_2_costh; Diff (t3, Prod [Integer 2; q; Atom Sin2thw])];
Prod [g_over_2_costh; t3]])
let half = Quot (Integer 1, Integer 2)
let derived_parameter_arrays =
[ nc_coupling G_NC_neutrino half (Integer 0);
nc_coupling G_NC_lepton (Neg half) (Integer (-1));
nc_coupling G_NC_up half (Quot (Integer 2, Integer 3));
nc_coupling G_NC_down (Neg half) (Quot (Integer (-1), Integer 3));
nc_coupling G_NC_h_neutrino half (Integer 0);
nc_coupling G_NC_h_lepton (Neg half) (Integer (-1));
nc_coupling G_NC_h_up half (Quot (Integer 2, Integer 3));
nc_coupling G_NC_h_down (Neg half) (Quot (Integer (-1), Integer 3)) ]
let parameters () =
{ input = input_parameters;
derived = derived_parameters;
derived_arrays = derived_parameter_arrays }
module F = Modeltools.Fusions (struct
type f = flavor
type c = constant
let compare = compare
let conjugate = conjugate
end)
(* \begin{equation}
\mathcal{L}_{\textrm{EM}} =
- e \sum_i q_i \bar\psi_i\fmslash{A}\psi_i
\end{equation} *)
let mgm ((m1, g, m2), fbf, c) = ((M m1, G g, M m2), fbf, c)
let mom ((m1, o, m2), fbf, c) = ((M m1, O o, M m2), fbf, c)
let electromagnetic_currents n =
List.map mgm
[ ((L (-n), Ga, L n), FBF (1, Psibar, V, Psi), Q_lepton);
((U (-n), Ga, U n), FBF (1, Psibar, V, Psi), Q_up);
((D (-n), Ga, D n), FBF (1, Psibar, V, Psi), Q_down) ]
let color_currents n =
List.map mgm
[ ((U (-n), Gl, U n), FBF (1, Psibar, V, Psi), Gs);
((D (-n), Gl, D n), FBF (1, Psibar, V, Psi), Gs) ]
(* \begin{equation}
\mathcal{L}_{\textrm{NC}} =
- \frac{g}{2\cos\theta_W}
\sum_i \bar\psi_i\fmslash{Z}(g_V^i-g_A^i\gamma_5)\psi_i
\end{equation} *)
let neutral_currents n =
List.map mgm
[ ((L (-n), Z, L n), FBF (1, Psibar, VA, Psi), G_NC_lepton);
((N (-n), Z, N n), FBF (1, Psibar, VA, Psi), G_NC_neutrino);
((U (-n), Z, U n), FBF (1, Psibar, VA, Psi), G_NC_up);
((D (-n), Z, D n), FBF (1, Psibar, VA, Psi), G_NC_down) ]
(* We want to allow for (almost) completely general couplings but maintain
universality (generation independence). Maybe we should also separate the
coupling to the top quark since the third generation is somewhat special.
*)
let neutral_heavy_currents n =
List.map mgm
[ ((L (-n), ZH, L n), FBF (1, Psibar, VA, Psi), G_NC_h_lepton);
((N (-n), ZH, N n), FBF (1, Psibar, VA, Psi), G_NC_h_neutrino);
((U (-n), ZH, U n), FBF (1, Psibar, VA, Psi), G_NC_h_up);
((D (-n), ZH, D n), FBF (1, Psibar, VA, Psi), G_NC_h_down);
]
(* \begin{equation}
\mathcal{L}_{\textrm{CC}} =
- \frac{g}{2\sqrt2} \sum_i \bar\psi_i
(T^+\fmslash{W}^+ + T^-\fmslash{W}^-)(1-\gamma_5)\psi_i
\end{equation} *)
let charged_currents n =
List.map mgm
[ ((L (-n), Wm, N n), FBF (1, Psibar, VL, Psi), G_CC);
((N (-n), Wp, L n), FBF (1, Psibar, VL, Psi), G_CC);
((D (-n), Wm, U n), FBF (1, Psibar, VL, Psi), G_CC);
((U (-n), Wp, D n), FBF (1, Psibar, VL, Psi), G_CC) ]
let yukawa =
[ ((M (U (-3)), O H, M (U 3)), FBF (1, Psibar, S, Psi), G_Htt);
((M (D (-3)), O H, M (D 3)), FBF (1, Psibar, S, Psi), G_Hbb);
((M (U (-2)), O H, M (U 2)), FBF (1, Psibar, S, Psi), G_Hcc);
((M (L (-3)), O H, M (L 3)), FBF (1, Psibar, S, Psi), G_Htautau) ]
(* \begin{equation}
\mathcal{L}_{\textrm{TGC}} =
- e \partial_\mu A_\nu W_+^\mu W_-^\nu + \ldots
- e \cot\theta_w \partial_\mu Z_\nu W_+^\mu W_-^\nu + \ldots
\end{equation} *)
let tgc ((g1, g2, g3), t, c) = ((G g1, G g2, G g3), t, c)
let triple_gauge =
List.map tgc
[ ((Ga, Wm, Wp), Gauge_Gauge_Gauge 1, I_Q_W);
((Z, Wm, Wp), Gauge_Gauge_Gauge 1, I_G_ZWW);
((Gl, Gl, Gl), Gauge_Gauge_Gauge 1, I_Gs)]
let qgc ((g1, g2, g3, g4), t, c) = ((G g1, G g2, G g3, G g4), t, c)
let gauge4 = Vector4 [(2, C_13_42); (-1, C_12_34); (-1, C_14_23)]
let minus_gauge4 = Vector4 [(-2, C_13_42); (1, C_12_34); (1, C_14_23)]
let quartic_gauge =
List.map qgc
[ (Wm, Wp, Wm, Wp), gauge4, G_WWWW;
(Wm, Z, Wp, Z), minus_gauge4, G_ZZWW;
(Wm, Z, Wp, Ga), minus_gauge4, G_AZWW;
(Wm, Ga, Wp, Ga), minus_gauge4, G_AAWW;
(Gl, Gl, Gl, Gl), gauge4, G2 ]
let gauge_higgs =
[ ((O H, G Wp, G Wm), Scalar_Vector_Vector 1, G_HWW);
((O H, G Z, G Z), Scalar_Vector_Vector 1, G_HZZ) ]
let gauge_higgs4 =
[ (O H, O H, G Wp, G Wm), Scalar2_Vector2 1, G_HHWW;
(O H, O H, G Z, G Z), Scalar2_Vector2 1, G_HHZZ ]
let higgs =
[ (O H, O H, O H), Scalar_Scalar_Scalar 1, G_H3 ]
let higgs4 =
[ (O H, O H, O H, O H), Scalar4 1, G_H4 ]
let goldstone_vertices =
[ ((O Phi0, G Wm, G Wp), Scalar_Vector_Vector 1, I_G_ZWW);
((O Phip, G Ga, G Wm), Scalar_Vector_Vector 1, I_Q_W);
((O Phip, G Z, G Wm), Scalar_Vector_Vector 1, I_G_ZWW);
((O Phim, G Wp, G Ga), Scalar_Vector_Vector 1, I_Q_W);
((O Phim, G Wp, G Z), Scalar_Vector_Vector 1, I_G_ZWW) ]
let vertices3 =
(ThoList.flatmap electromagnetic_currents [1;2;3] @
ThoList.flatmap color_currents [1;2;3] @
ThoList.flatmap neutral_currents [1;2;3] @
ThoList.flatmap neutral_heavy_currents [1;2;3] @
ThoList.flatmap charged_currents [1;2;3] @
yukawa @ triple_gauge @
gauge_higgs @ higgs @ goldstone_vertices)
let vertices4 =
quartic_gauge @ gauge_higgs4 @ higgs4
let vertices () = (vertices3, vertices4, [])
(* For efficiency, make sure that [F.of_vertices vertices] is
evaluated only once. *)
let table = F.of_vertices (vertices ())
let fuse2 = F.fuse2 table
let fuse3 = F.fuse3 table
let fuse = F.fuse table
let max_degree () = 4
let flavor_of_string = function
| "e-" -> M (L 1) | "e+" -> M (L (-1))
| "mu-" -> M (L 2) | "mu+" -> M (L (-2))
| "tau-" -> M (L 3) | "tau+" -> M (L (-3))
| "nue" -> M (N 1) | "nuebar" -> M (N (-1))
| "numu" -> M (N 2) | "numubar" -> M (N (-2))
| "nutau" -> M (N 3) | "nutaubar" -> M (N (-3))
| "u" -> M (U 1) | "ubar" -> M (U (-1))
| "c" -> M (U 2) | "cbar" -> M (U (-2))
| "t" -> M (U 3) | "tbar" -> M (U (-3))
| "d" -> M (D 1) | "dbar" -> M (D (-1))
| "s" -> M (D 2) | "sbar" -> M (D (-2))
| "b" -> M (D 3) | "bbar" -> M (D (-3))
| "g" | "gl" -> G Gl
| "A" -> G Ga | "Z" | "Z0" -> G Z
| "ZH" | "ZH0" | "Zh" | "Zh0" -> G ZH
| "W+" -> G Wp | "W-" -> G Wm
| "H" -> O H
| _ -> invalid_arg "Models.Zprime.flavor_of_string"
let flavor_to_string = function
| M f ->
begin match f with
| L 1 -> "e-" | L (-1) -> "e+"
| L 2 -> "mu-" | L (-2) -> "mu+"
| L 3 -> "tau-" | L (-3) -> "tau+"
| L _ -> invalid_arg
"Models.Zprime.flavor_to_string: invalid lepton"
| N 1 -> "nue" | N (-1) -> "nuebar"
| N 2 -> "numu" | N (-2) -> "numubar"
| N 3 -> "nutau" | N (-3) -> "nutaubar"
| N _ -> invalid_arg
"Models.Zprime.flavor_to_string: invalid neutrino"
| U 1 -> "u" | U (-1) -> "ubar"
| U 2 -> "c" | U (-2) -> "cbar"
| U 3 -> "t" | U (-3) -> "tbar"
| U _ -> invalid_arg
"Models.Zprime.flavor_to_string: invalid up type quark"
| D 1 -> "d" | D (-1) -> "dbar"
| D 2 -> "s" | D (-2) -> "sbar"
| D 3 -> "b" | D (-3) -> "bbar"
| D _ -> invalid_arg
"Models.Zprime.flavor_to_string: invalid down type quark"
end
| G f ->
begin match f with
| Gl -> "g"
| Ga -> "A" | Z -> "Z"
| Wp -> "W+" | Wm -> "W-"
| ZH -> "ZH"
end
| O f ->
begin match f with
| Phip -> "phi+" | Phim -> "phi-" | Phi0 -> "phi0"
| H -> "H"
end
let flavor_to_TeX = function
| M f ->
begin match f with
| L 1 -> "e^-" | L (-1) -> "e^+"
| L 2 -> "\\mu-" | L (-2) -> "\\mu^+"
| L 3 -> "\\tau^-" | L (-3) -> "\\tau^+"
| L _ -> invalid_arg
"Models.Zprime.flavor_to_TeX: invalid lepton"
| N 1 -> "\\nu_e" | N (-1) -> "\\bar{\\nu}_e"
| N 2 -> "\\nu_\\mu" | N (-2) -> "\\bar{\\nu}_\\mu"
| N 3 -> "\\nu_\\tau" | N (-3) -> "\\bar{\\nu}_\\tau"
| N _ -> invalid_arg
"Models.Zprime.flavor_to_TeX: invalid neutrino"
| U 1 -> "u" | U (-1) -> "\\bar{u}"
| U 2 -> "c" | U (-2) -> "\\bar{c}"
| U 3 -> "t" | U (-3) -> "\\bar{t}"
| U _ -> invalid_arg
"Models.Zprime.flavor_to_TeX: invalid up type quark"
| D 1 -> "d" | D (-1) -> "\\bar{d}"
| D 2 -> "s" | D (-2) -> "\\bar{s}"
| D 3 -> "b" | D (-3) -> "\\bar{b}"
| D _ -> invalid_arg
"Models.Zprime.flavor_to_TeX: invalid down type quark"
end
| G f ->
begin match f with
| Gl -> "g"
| Ga -> "\\gamma" | Z -> "Z"
| Wp -> "W^+" | Wm -> "W^-"
| ZH -> "Z_H"
end
| O f ->
begin match f with
| Phip -> "phi+" | Phim -> "phi-" | Phi0 -> "phi0"
| H -> "H"
end
let flavor_symbol = function
| M f ->
begin match f with
| L n when n > 0 -> "l" ^ string_of_int n
| L n -> "l" ^ string_of_int (abs n) ^ "b"
| N n when n > 0 -> "n" ^ string_of_int n
| N n -> "n" ^ string_of_int (abs n) ^ "b"
| U n when n > 0 -> "u" ^ string_of_int n
| U n -> "u" ^ string_of_int (abs n) ^ "b"
| D n when n > 0 -> "d" ^ string_of_int n
| D n -> "d" ^ string_of_int (abs n) ^ "b"
end
| G f ->
begin match f with
| Gl -> "gl"
| Ga -> "a" | Z -> "z"
| Wp -> "wp" | Wm -> "wm"
| ZH -> "zh"
end
| O f ->
begin match f with
| Phip -> "pp" | Phim -> "pm" | Phi0 -> "p0"
| H -> "h"
end
(* There are PDG numbers for Z', Z'', W', 32-34, respectively.
We just introduce a number 38 for Y0 as a Z'''.
As well, there is the number 8 for a t'.
*)
let pdg = function
| M f ->
begin match f with
| L n when n > 0 -> 9 + 2*n
| L n -> - 9 + 2*n
| N n when n > 0 -> 10 + 2*n
| N n -> - 10 + 2*n
| U n when n > 0 -> 2*n
| U n -> 2*n
| D n when n > 0 -> - 1 + 2*n
| D n -> 1 + 2*n
end
| G f ->
begin match f with
| Gl -> 21
| Ga -> 22 | Z -> 23
| Wp -> 24 | Wm -> (-24)
| ZH -> 32
end
| O f ->
begin match f with
| Phip | Phim -> 27 | Phi0 -> 26
| H -> 25
end
let mass_symbol f =
"mass(" ^ string_of_int (abs (pdg f)) ^ ")"
let width_symbol f =
"width(" ^ string_of_int (abs (pdg f)) ^ ")"
let constant_symbol = function
| Unit -> "unit" | Pi -> "PI"
| Alpha_QED -> "alpha" | E -> "e" | G_weak -> "g" | Vev -> "vev"
| Sin2thw -> "sin2thw" | Sinthw -> "sinthw" | Costhw -> "costhw"
| Q_lepton -> "qlep" | Q_up -> "qup" | Q_down -> "qdwn"
| G_NC_lepton -> "gnclep" | G_NC_neutrino -> "gncneu"
| G_NC_up -> "gncup" | G_NC_down -> "gncdwn"
| G_CC -> "gcc"
| G_NC_h_lepton -> "gnchlep" | G_NC_h_neutrino -> "gnchneu"
| G_NC_h_up -> "gnchup" | G_NC_h_down -> "gnchdwn"
| I_Q_W -> "iqw" | I_G_ZWW -> "igzww" | I_G_WWW -> "igwww"
| G_WWWW -> "gw4" | G_ZZWW -> "gzzww"
| G_AZWW -> "gazww" | G_AAWW -> "gaaww"
| G_HWW -> "ghww" | G_HZZ -> "ghzz"
| G_HHWW -> "ghhww" | G_HHZZ -> "ghhzz"
| G_Htt -> "ghtt" | G_Hbb -> "ghbb"
| G_Htautau -> "ghtautau" | G_Hcc -> "ghcc"
| G_H3 -> "gh3" | G_H4 -> "gh4"
| Gs -> "gs" | I_Gs -> "igs" | G2 -> "gs**2"
| Mass f -> "mass" ^ flavor_symbol f
| Width f -> "width" ^ flavor_symbol f
end
Index: trunk/omega/src/orders_syntax.mli
===================================================================
--- trunk/omega/src/orders_syntax.mli (revision 0)
+++ trunk/omega/src/orders_syntax.mli (revision 8900)
@@ -0,0 +1,60 @@
+(* orders_syntax.mli --
+
+ Copyright (C) 1999-2023 by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+
+ 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. *)
+
+(* We represent coupling orders simply as [string]s so that lexing and
+ parsing are independent of the model. Checking for validity is done
+ later in the functor [Orders.Conditions] that depends on the model. *)
+
+type co = string
+
+type co_set =
+ | Set of co list
+ | Diff of co_set * co_set
+ | Complement of co_set
+
+type range =
+ | Range of int * int
+ | Min of int
+ | Max of int
+
+(* We distinguish intervals and slices:
+ \begin{itemize}
+ \item for the slice \texttt{QCD = \{2..4\}} all amplitudes
+ with 2, 3 and 4 QCD couplings are generated separately and
+ \item for the interval \texttt{QCD = \lbrack 2..4\rbrack},
+ these are summed up.
+ \end{itemize}
+ Obviously, for one coupling order, there is no difference
+ between interval and slice. *)
+
+type atom =
+ | Interval of co_set * range
+ | Slices of co_set * range
+ | Exact of co_set * int
+ | Null of co_set
+
+type t =
+ | Atom of atom
+ | And of t list
+ | Or of t list
+
+exception Syntax_Error of string * int * int
Index: trunk/omega/src/omega_QED.ml
===================================================================
--- trunk/omega/src/omega_QED.ml (revision 8899)
+++ trunk/omega/src/omega_QED.ml (revision 8900)
@@ -1,26 +1,26 @@
(* omega_QED.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Binary(Targets.Fortran)(Modellib_SM.QED)
+module O = Omega.Binary(Target_Fortran.Make)(Modellib_SM.QED)
let _ = O.main ()
Index: trunk/omega/src/targets_vintage.ml
===================================================================
--- trunk/omega/src/targets_vintage.ml (revision 0)
+++ trunk/omega/src/targets_vintage.ml (revision 8900)
@@ -0,0 +1,3372 @@
+(* targets_vintage.ml --
+
+ Copyright (C) 1999-2023 by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+ with contributions from
+ Christian Speckner <cnspeckn@googlemail.com>
+ Fabian Bach <fabian.bach@t-online.de> (only parts of this file)
+ Marco Sekulla <marco.sekulla@kit.edu> (only parts of this file)
+ Bijan Chokoufe Nejad <bijan.chokoufe@desy.de> (only parts of this file)
+ So Young Shim <soyoung.shim@desy.de>
+
+ WHIZARD is free software; you can redistribute it and/or modify it
+ under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ WHIZARD is distributed in the hope that it will be useful, but
+ WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
+
+(* \thocwmodulesection{\texttt{Fortran\,90/95}} *)
+
+(* \thocwmodulesubsection{Dirac Fermions}
+ We factor out the code for fermions so that we can use the simpler
+ implementation for Dirac fermions if the model contains no Majorana
+ fermions. *)
+
+module type Fermions =
+ sig
+ open Coupling
+ val print_current : int * fermionbar * boson * fermion ->
+ string -> string -> string -> fuse2 -> unit
+ val print_current_mom : int * fermionbar * boson * fermion ->
+ string -> string -> string -> string -> string -> string
+ -> fuse2 -> unit
+ val print_current_p : int * fermion * boson * fermion ->
+ string -> string -> string -> fuse2 -> unit
+ val print_current_b : int * fermionbar * boson * fermionbar ->
+ string -> string -> string -> fuse2 -> unit
+ val print_current_g : int * fermionbar * boson * fermion ->
+ string -> string -> string -> string -> string -> string
+ -> fuse2 -> unit
+ val print_current_g4 : int * fermionbar * boson2 * fermion ->
+ string -> string -> string -> string -> fuse3 -> unit
+ val reverse_braket : bool -> lorentz -> lorentz list -> bool
+ end
+
+module type Fermion_Maker = functor (N : Target_Fortran_Names.T) -> Fermions
+
+module Fortran_Fermions (Names : Target_Fortran_Names.T) : Fermions =
+ struct
+
+ open Coupling
+ open Format
+
+ let format_coupling coeff c =
+ match coeff with
+ | 1 -> c
+ | -1 -> "(-" ^ c ^")"
+ | coeff -> string_of_int coeff ^ "*" ^ c
+
+ let format_coupling_2 coeff c =
+ match coeff with
+ | 1 -> c
+ | -1 -> "-" ^ c
+ | coeff -> string_of_int coeff ^ "*" ^ c
+
+(* \begin{dubious}
+ JR's coupling constant HACK, necessitated by tho's bad design descition.
+ \end{dubious} *)
+
+ let fastener s i ?p ?q () =
+ try
+ let offset = (String.index s '(') in
+ if ((String.get s (String.length s - 1)) != ')') then
+ failwith "fastener: wrong usage of parentheses"
+ else
+ let func_name = (String.sub s 0 offset) and
+ tail =
+ (String.sub s (succ offset) (String.length s - offset - 2)) in
+ if (String.contains func_name ')') ||
+ (String.contains tail '(') ||
+ (String.contains tail ')') then
+ failwith "fastener: wrong usage of parentheses"
+ else
+ func_name ^ "(" ^ string_of_int i ^ "," ^ tail ^ ")"
+ with
+ | Not_found ->
+ if (String.contains s ')') then
+ failwith "fastener: wrong usage of parentheses"
+ else
+ match p with
+ | None -> s ^ "(" ^ string_of_int i ^ ")"
+ | Some p ->
+ match q with
+ | None -> s ^ "(" ^ p ^ "*" ^ p ^ "," ^ string_of_int i ^ ")"
+ | Some q -> s ^ "(" ^ p ^ "," ^ q ^ "," ^ string_of_int i ^ ")"
+
+ let print_fermion_current coeff f c wf1 wf2 fusion =
+ let c = format_coupling coeff c in
+ match fusion with
+ | F13 -> printf "%s_ff(%s,%s,%s)" f c wf1 wf2
+ | F31 -> printf "%s_ff(%s,%s,%s)" f c wf2 wf1
+ | F23 -> printf "f_%sf(%s,%s,%s)" f c wf1 wf2
+ | F32 -> printf "f_%sf(%s,%s,%s)" f c wf2 wf1
+ | F12 -> printf "f_f%s(%s,%s,%s)" f c wf1 wf2
+ | F21 -> printf "f_f%s(%s,%s,%s)" f c wf2 wf1
+
+(* \begin{dubious}
+ Using a two element array for the combined vector-axial and scalar-pseudo
+ couplings helps to support HELAS as well. Since we will probably never
+ support general boson couplings with HELAS, it might be retired in favor
+ of two separate variables. For this [Model.constant_symbol] has to be
+ generalized.
+ \end{dubious} *)
+
+(* \begin{dubious}
+ NB: passing the array instead of two separate constants would be a
+ \emph{bad} idea, because the support for Majorana spinors below will
+ have to flip signs!
+ \end{dubious} *)
+
+ let print_fermion_current2 coeff f c wf1 wf2 fusion =
+ let c = format_coupling_2 coeff c in
+ let c1 = fastener c 1 ()
+ and c2 = fastener c 2 () in
+ match fusion with
+ | F13 -> printf "%s_ff(%s,%s,%s,%s)" f c1 c2 wf1 wf2
+ | F31 -> printf "%s_ff(%s,%s,%s,%s)" f c1 c2 wf2 wf1
+ | F23 -> printf "f_%sf(%s,%s,%s,%s)" f c1 c2 wf1 wf2
+ | F32 -> printf "f_%sf(%s,%s,%s,%s)" f c1 c2 wf2 wf1
+ | F12 -> printf "f_f%s(%s,%s,%s,%s)" f c1 c2 wf1 wf2
+ | F21 -> printf "f_f%s(%s,%s,%s,%s)" f c1 c2 wf2 wf1
+
+ let print_fermion_current_mom_v1 coeff f c wf1 wf2 p1 p2 p12 fusion =
+ let c = format_coupling coeff c in
+ let c1 = fastener c 1 and
+ c2 = fastener c 2 in
+ match fusion with
+ | F13 -> printf "%s_ff(%s,%s,%s,%s)" f (c1 ~p:p12 ()) (c2 ~p:p12 ()) wf1 wf2
+ | F31 -> printf "%s_ff(%s,%s,%s,%s)" f (c1 ~p:p12 ()) (c2 ~p:p12 ()) wf2 wf1
+ | F23 -> printf "f_%sf(%s,%s,%s,%s)" f (c1 ~p:p1 ()) (c2 ~p:p1 ()) wf1 wf2
+ | F32 -> printf "f_%sf(%s,%s,%s,%s)" f (c1 ~p:p2 ()) (c2 ~p:p2 ()) wf2 wf1
+ | F12 -> printf "f_f%s(%s,%s,%s,%s)" f (c1 ~p:p2 ()) (c2 ~p:p2 ()) wf1 wf2
+ | F21 -> printf "f_f%s(%s,%s,%s,%s)" f (c1 ~p:p1 ()) (c2 ~p:p1 ()) wf2 wf1
+
+ let print_fermion_current_mom_v2 coeff f c wf1 wf2 p1 p2 p12 fusion =
+ let c = format_coupling coeff c in
+ let c1 = fastener c 1 and
+ c2 = fastener c 2 in
+ match fusion with
+ | F13 -> printf "%s_ff(%s,%s,@,%s,%s,%s)" f (c1 ~p:p12 ()) (c2 ~p:p12 ()) wf1 wf2 p12
+ | F31 -> printf "%s_ff(%s,%s,@,%s,%s,%s)" f (c1 ~p:p12 ()) (c2 ~p:p12 ()) wf2 wf1 p12
+ | F23 -> printf "f_%sf(%s,%s,@,%s,%s,%s)" f (c1 ~p:p1 ()) (c2 ~p:p1 ()) wf1 wf2 p1
+ | F32 -> printf "f_%sf(%s,%s,@,%s,%s,%s)" f (c1 ~p:p2 ()) (c2 ~p:p2 ()) wf2 wf1 p2
+ | F12 -> printf "f_f%s(%s,%s,@,%s,%s,%s)" f (c1 ~p:p2 ()) (c2 ~p:p2 ()) wf1 wf2 p2
+ | F21 -> printf "f_f%s(%s,%s,@,%s,%s,%s)" f (c1 ~p:p1 ()) (c2 ~p:p1 ()) wf2 wf1 p1
+
+ let print_fermion_current_mom_ff coeff f c wf1 wf2 p1 p2 p12 fusion =
+ let c = format_coupling coeff c in
+ let c1 = fastener c 1 and
+ c2 = fastener c 2 in
+ match fusion with
+ | F13 -> printf "%s_ff(%s,%s,%s,%s)" f (c1 ~p:p1 ~q:p2 ()) (c2 ~p:p1 ~q:p2 ()) wf1 wf2
+ | F31 -> printf "%s_ff(%s,%s,%s,%s)" f (c1 ~p:p1 ~q:p2 ()) (c2 ~p:p1 ~q:p2 ()) wf2 wf1
+ | F23 -> printf "f_%sf(%s,%s,%s,%s)" f (c1 ~p:p12 ~q:p2 ()) (c2 ~p:p12 ~q:p2 ()) wf1 wf2
+ | F32 -> printf "f_%sf(%s,%s,%s,%s)" f (c1 ~p:p12 ~q:p1 ()) (c2 ~p:p12 ~q:p1 ()) wf2 wf1
+ | F12 -> printf "f_f%s(%s,%s,%s,%s)" f (c1 ~p:p12 ~q:p1 ()) (c2 ~p:p12 ~q:p1 ()) wf1 wf2
+ | F21 -> printf "f_f%s(%s,%s,%s,%s)" f (c1 ~p:p12 ~q:p2 ()) (c2 ~p:p12 ~q:p2 ()) wf2 wf1
+
+ let print_current = function
+ | coeff, Psibar, VA, Psi -> print_fermion_current2 coeff "va"
+ | coeff, Psibar, VA2, Psi -> print_fermion_current coeff "va2"
+ | coeff, Psibar, VA3, Psi -> print_fermion_current coeff "va3"
+ | coeff, Psibar, V, Psi -> print_fermion_current coeff "v"
+ | coeff, Psibar, A, Psi -> print_fermion_current coeff "a"
+ | coeff, Psibar, VL, Psi -> print_fermion_current coeff "vl"
+ | coeff, Psibar, VR, Psi -> print_fermion_current coeff "vr"
+ | coeff, Psibar, VLR, Psi -> print_fermion_current2 coeff "vlr"
+ | coeff, Psibar, SP, Psi -> print_fermion_current2 coeff "sp"
+ | coeff, Psibar, S, Psi -> print_fermion_current coeff "s"
+ | coeff, Psibar, P, Psi -> print_fermion_current coeff "p"
+ | coeff, Psibar, SL, Psi -> print_fermion_current coeff "sl"
+ | coeff, Psibar, SR, Psi -> print_fermion_current coeff "sr"
+ | coeff, Psibar, SLR, Psi -> print_fermion_current2 coeff "slr"
+ | _, Psibar, _, Psi -> invalid_arg
+ "Targets.Fortran_Fermions: no superpotential here"
+ | _, Chibar, _, _ | _, _, _, Chi -> invalid_arg
+ "Targets.Fortran_Fermions: Majorana spinors not handled"
+ | _, Gravbar, _, _ | _, _, _, Grav -> invalid_arg
+ "Targets.Fortran_Fermions: Gravitinos not handled"
+
+ let print_current_mom = function
+ | coeff, Psibar, VLRM, Psi -> print_fermion_current_mom_v1 coeff "vlr"
+ | coeff, Psibar, VAM, Psi -> print_fermion_current_mom_ff coeff "va"
+ | coeff, Psibar, VA3M, Psi -> print_fermion_current_mom_ff coeff "va3"
+ | coeff, Psibar, SPM, Psi -> print_fermion_current_mom_v1 coeff "sp"
+ | coeff, Psibar, TVA, Psi -> print_fermion_current_mom_v1 coeff "tva"
+ | coeff, Psibar, TVAM, Psi -> print_fermion_current_mom_v2 coeff "tvam"
+ | coeff, Psibar, TLR, Psi -> print_fermion_current_mom_v1 coeff "tlr"
+ | coeff, Psibar, TLRM, Psi -> print_fermion_current_mom_v2 coeff "tlrm"
+ | coeff, Psibar, TRL, Psi -> print_fermion_current_mom_v1 coeff "trl"
+ | coeff, Psibar, TRLM, Psi -> print_fermion_current_mom_v2 coeff "trlm"
+ | _, Psibar, _, Psi -> invalid_arg
+ "Targets.Fortran_Fermions: only sigma tensor coupling here"
+ | _, Chibar, _, _ | _, _, _, Chi -> invalid_arg
+ "Targets.Fortran_Fermions: Majorana spinors not handled"
+ | _, Gravbar, _, _ | _, _, _, Grav -> invalid_arg
+ "Targets.Fortran_Fermions: Gravitinos not handled"
+
+ let print_current_p = function
+ | _, _, _, _ -> invalid_arg
+ "Targets.Fortran_Fermions: No clashing arrows here"
+
+ let print_current_b = function
+ | _, _, _, _ -> invalid_arg
+ "Targets.Fortran_Fermions: No clashing arrows here"
+
+ let print_current_g = function
+ | _, _, _, _ -> invalid_arg
+ "Targets.Fortran_Fermions: No gravitinos here"
+
+ let print_current_g4 = function
+ | _, _, _, _ -> invalid_arg
+ "Targets.Fortran_Fermions: No gravitinos here"
+
+ let reverse_braket vintage bra ket =
+ match bra with
+ | Spinor -> true
+ | _ -> false
+
+ end
+
+(* \thocwmodulesubsection{Majorana Fermions} *)
+
+(* \begin{JR}
+ For this function we need a different approach due to our aim of
+ implementing the fermion vertices with the right line as ingoing (in a
+ calculational sense) and the left line in a fusion as outgoing. In
+ defining all external lines and the fermionic wavefunctions built out of
+ them as ingoing we have to invert the left lines to make them outgoing.
+ This happens by multiplying them with the inverse charge conjugation
+ matrix in an appropriate representation and then transposing it. We must
+ distinguish whether the direction of calculation and the physical direction
+ of the fermion number flow are parallel or antiparallel. In the first case
+ we can use the "normal" Feynman rules for Dirac particles, while in the
+ second, according to the paper of Denner et al., we have to reverse the
+ sign of the vector and antisymmetric bilinears of the Dirac spinors, cf.
+ the [Coupling] module.
+
+ Note the subtlety for the left- and righthanded couplings: Only the vector
+ part of these couplings changes in the appropriate cases its sign,
+ changing the chirality to the negative of the opposite.
+ \end{JR} *)
+
+module Fortran_Majorana_Fermions (Names : Target_Fortran_Names.T) : Fermions =
+ struct
+
+ open Coupling
+ open Format
+
+ let format_coupling coeff c =
+ match coeff with
+ | 1 -> c
+ | -1 -> "(-" ^ c ^")"
+ | coeff -> string_of_int coeff ^ "*" ^ c
+
+ let format_coupling_2 coeff c =
+ match coeff with
+ | 1 -> c
+ | -1 -> "-" ^ c
+ | coeff -> string_of_int coeff ^ "*" ^ c
+
+(* \begin{dubious}
+ JR's coupling constant HACK, necessitated by tho's bad design descition.
+ \end{dubious} *)
+
+ let fastener s i =
+ try
+ let offset = (String.index s '(') in
+ if ((String.get s (String.length s - 1)) != ')') then
+ failwith "fastener: wrong usage of parentheses"
+ else
+ let func_name = (String.sub s 0 offset) and
+ tail =
+ (String.sub s (succ offset) (String.length s - offset - 2)) in
+ if (String.contains func_name ')') ||
+ (String.contains tail '(') ||
+ (String.contains tail ')') then
+ failwith "fastener: wrong usage of parentheses"
+ else
+ func_name ^ "(" ^ string_of_int i ^ "," ^ tail ^ ")"
+ with
+ | Not_found ->
+ if (String.contains s ')') then
+ failwith "fastener: wrong usage of parentheses"
+ else
+ s ^ "(" ^ string_of_int i ^ ")"
+
+ let print_fermion_current coeff f c wf1 wf2 fusion =
+ let c = format_coupling coeff c in
+ match fusion with
+ | F13 | F31 -> printf "%s_ff(%s,%s,%s)" f c wf1 wf2
+ | F23 | F21 -> printf "f_%sf(%s,%s,%s)" f c wf1 wf2
+ | F32 | F12 -> printf "f_%sf(%s,%s,%s)" f c wf2 wf1
+
+ let print_fermion_current2 coeff f c wf1 wf2 fusion =
+ let c = format_coupling_2 coeff c in
+ let c1 = fastener c 1 and
+ c2 = fastener c 2 in
+ match fusion with
+ | F13 | F31 -> printf "%s_ff(%s,%s,%s,%s)" f c1 c2 wf1 wf2
+ | F23 | F21 -> printf "f_%sf(%s,%s,%s,%s)" f c1 c2 wf1 wf2
+ | F32 | F12 -> printf "f_%sf(%s,%s,%s,%s)" f c1 c2 wf2 wf1
+
+ let print_fermion_current_mom_v1 coeff f c wf1 wf2 p1 p2 p12 fusion =
+ let c = format_coupling coeff c in
+ let c1 = fastener c 1 and
+ c2 = fastener c 2 in
+ match fusion with
+ | F13 -> printf "%s_ff(%s,%s,%s,%s)" f c1 c2 wf1 wf2
+ | F31 -> printf "%s_ff(-(%s),%s,%s,%s)" f c1 c2 wf1 wf2
+ | F23 -> printf "f_%sf(%s,%s,%s,%s)" f c1 c2 wf1 wf2
+ | F32 -> printf "f_%sf(%s,%s,%s,%s)" f c1 c2 wf2 wf1
+ | F12 -> printf "f_f%s(-(%s),%s,%s,%s)" f c1 c2 wf2 wf1
+ | F21 -> printf "f_f%s(-(%s),%s,%s,%s)" f c1 c2 wf1 wf2
+
+ let print_fermion_current_mom_v1_chiral coeff f c wf1 wf2 p1 p2 p12 fusion =
+ let c = format_coupling coeff c in
+ let c1 = fastener c 1 and
+ c2 = fastener c 2 in
+ match fusion with
+ | F13 -> printf "%s_ff(%s,%s,%s,%s)" f c1 c2 wf1 wf2
+ | F31 -> printf "%s_ff(-(%s),-(%s),%s,%s)" f c2 c1 wf1 wf2
+ | F23 -> printf "f_%sf(%s,%s,%s,%s)" f c1 c2 wf1 wf2
+ | F32 -> printf "f_%sf(%s,%s,%s,%s)" f c1 c2 wf2 wf1
+ | F12 -> printf "f_f%s(-(%s),-(%s),%s,%s)" f c2 c1 wf2 wf1
+ | F21 -> printf "f_f%s(-(%s),-(%s),%s,%s)" f c2 c1 wf2 wf1
+
+ let print_fermion_current_mom_v2 coeff f c wf1 wf2 p1 p2 p12 fusion =
+ let c = format_coupling coeff c in
+ let c1 = fastener c 1 and
+ c2 = fastener c 2 in
+ match fusion with
+ | F13 -> printf "%s_ff(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p12
+ | F31 -> printf "%s_ff(-(%s),%s,%s,%s,%s)" f c1 c2 wf1 wf2 p12
+ | F23 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p1
+ | F32 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf2 wf1 p2
+ | F12 -> printf "f_f%s(-(%s),%s,%s,%s,%s)" f c1 c2 wf2 wf1 p2
+ | F21 -> printf "f_f%s(-(%s),%s,%s,%s,%s)" f c1 c2 wf1 wf2 p1
+
+ let print_fermion_current_mom_v2_chiral coeff f c wf1 wf2 p1 p2 p12 fusion =
+ let c = format_coupling coeff c in
+ let c1 = fastener c 1 and
+ c2 = fastener c 2 in
+ match fusion with
+ | F13 -> printf "%s_ff(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p12
+ | F31 -> printf "%s_ff(-(%s),-(%s),%s,%s,%s)" f c2 c1 wf2 wf1 p12
+ | F23 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p1
+ | F32 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf2 wf1 p2
+ | F12 -> printf "f_f%s(-(%s),-(%s),%s,%s,%s)" f c2 c1 wf1 wf2 p2
+ | F21 -> printf "f_f%s(-(%s),-(%s),%s,%s,%s)" f c2 c1 wf2 wf1 p1
+
+ let print_fermion_current_vector coeff f c wf1 wf2 fusion =
+ let c = format_coupling coeff c in
+ match fusion with
+ | F13 -> printf "%s_ff(%s,%s,%s)" f c wf1 wf2
+ | F31 -> printf "%s_ff(-%s,%s,%s)" f c wf1 wf2
+ | F23 -> printf "f_%sf(%s,%s,%s)" f c wf1 wf2
+ | F32 -> printf "f_%sf(%s,%s,%s)" f c wf2 wf1
+ | F12 -> printf "f_%sf(-%s,%s,%s)" f c wf2 wf1
+ | F21 -> printf "f_%sf(-%s,%s,%s)" f c wf1 wf2
+
+ let print_fermion_current2_vector coeff f c wf1 wf2 fusion =
+ let c = format_coupling_2 coeff c in
+ let c1 = fastener c 1 and
+ c2 = fastener c 2 in
+ match fusion with
+ | F13 -> printf "%s_ff(%s,%s,%s,%s)" f c1 c2 wf1 wf2
+ | F31 -> printf "%s_ff(-(%s),%s,%s,%s)" f c1 c2 wf1 wf2
+ | F23 -> printf "f_%sf(%s,%s,%s,%s)" f c1 c2 wf1 wf2
+ | F32 -> printf "f_%sf(%s,%s,%s,%s)" f c1 c2 wf2 wf1
+ | F12 -> printf "f_%sf(-(%s),%s,%s,%s)" f c1 c2 wf2 wf1
+ | F21 -> printf "f_%sf(-(%s),%s,%s,%s)" f c1 c2 wf1 wf2
+
+ let print_fermion_current_chiral coeff f1 f2 c wf1 wf2 fusion =
+ let c = format_coupling coeff c in
+ match fusion with
+ | F13 -> printf "%s_ff(%s,%s,%s)" f1 c wf1 wf2
+ | F31 -> printf "%s_ff(-%s,%s,%s)" f2 c wf1 wf2
+ | F23 -> printf "f_%sf(%s,%s,%s)" f1 c wf1 wf2
+ | F32 -> printf "f_%sf(%s,%s,%s)" f1 c wf2 wf1
+ | F12 -> printf "f_%sf(-%s,%s,%s)" f2 c wf2 wf1
+ | F21 -> printf "f_%sf(-%s,%s,%s)" f2 c wf1 wf2
+
+ let print_fermion_current2_chiral coeff f c wf1 wf2 fusion =
+ let c = format_coupling_2 coeff c in
+ let c1 = fastener c 1 and
+ c2 = fastener c 2 in
+ match fusion with
+ | F13 -> printf "%s_ff(%s,%s,%s,%s)" f c1 c2 wf1 wf2
+ | F31 -> printf "%s_ff(-(%s),-(%s),%s,%s)" f c2 c1 wf1 wf2
+ | F23 -> printf "f_%sf(%s,%s,%s,%s)" f c1 c2 wf1 wf2
+ | F32 -> printf "f_%sf(%s,%s,%s,%s)" f c1 c2 wf2 wf1
+ | F12 -> printf "f_%sf(-(%s),-(%s),%s,%s)" f c2 c1 wf2 wf1
+ | F21 -> printf "f_%sf(-(%s),-(%s),%s,%s)" f c2 c1 wf1 wf2
+
+ let print_current = function
+ | coeff, _, VA, _ -> print_fermion_current2_vector coeff "va"
+ | coeff, _, V, _ -> print_fermion_current_vector coeff "v"
+ | coeff, _, A, _ -> print_fermion_current coeff "a"
+ | coeff, _, VL, _ -> print_fermion_current_chiral coeff "vl" "vr"
+ | coeff, _, VR, _ -> print_fermion_current_chiral coeff "vr" "vl"
+ | coeff, _, VLR, _ -> print_fermion_current2_chiral coeff "vlr"
+ | coeff, _, SP, _ -> print_fermion_current2 coeff "sp"
+ | coeff, _, S, _ -> print_fermion_current coeff "s"
+ | coeff, _, P, _ -> print_fermion_current coeff "p"
+ | coeff, _, SL, _ -> print_fermion_current coeff "sl"
+ | coeff, _, SR, _ -> print_fermion_current coeff "sr"
+ | coeff, _, SLR, _ -> print_fermion_current2 coeff "slr"
+ | coeff, _, POT, _ -> print_fermion_current_vector coeff "pot"
+ | _, _, _, _ -> invalid_arg
+ "Targets.Fortran_Majorana_Fermions: Not needed in the models"
+
+ let print_current_p = function
+ | coeff, Psi, SL, Psi -> print_fermion_current coeff "sl"
+ | coeff, Psi, SR, Psi -> print_fermion_current coeff "sr"
+ | coeff, Psi, SLR, Psi -> print_fermion_current2 coeff "slr"
+ | _, _, _, _ -> invalid_arg
+ "Targets.Fortran_Majorana_Fermions: Not needed in the used models"
+
+ let print_current_b = function
+ | coeff, Psibar, SL, Psibar -> print_fermion_current coeff "sl"
+ | coeff, Psibar, SR, Psibar -> print_fermion_current coeff "sr"
+ | coeff, Psibar, SLR, Psibar -> print_fermion_current2 coeff "slr"
+ | _, _, _, _ -> invalid_arg
+ "Targets.Fortran_Majorana_Fermions: Not needed in the used models"
+
+(* This function is for the vertices with three particles including two
+ fermions but also a momentum, therefore with a dimensionful coupling
+ constant, e.g. the gravitino vertices. One has to dinstinguish between
+ the two kinds of canonical orders in the string of gamma matrices. Of
+ course, the direction of the string of gamma matrices is reversed if one
+ goes from the [Gravbar, _, Psi] to the [Psibar, _, Grav] vertices, and
+ the same is true for the couplings of the gravitino to the Majorana
+ fermions. For more details see the tables in the [coupling]
+ implementation. *)
+
+(* We now have to fix the directions of the momenta. For making the compiler
+ happy and because we don't want to make constructions of infinite
+ complexity we list the momentum including vertices without gravitinos
+ here; the pattern matching says that's better. Perhaps we have to find a
+ better name now.
+
+ For the cases of $MOM$, $MOM5$, $MOML$ and $MOMR$ which arise only in
+ BRST transformations we take the mass as a coupling constant. For
+ $VMOM$ we don't need a mass either. These vertices are like kinetic terms
+ and so need not have a coupling constant. By this we avoid a strange and
+ awful construction with a new variable. But be careful with a
+ generalization if you want to use these vertices for other purposes.
+*)
+
+ let format_coupling_mom coeff c =
+ match coeff with
+ | 1 -> c
+ | -1 -> "(-" ^ c ^")"
+ | coeff -> string_of_int coeff ^ "*" ^ c
+
+ let commute_proj f =
+ match f with
+ | "moml" -> "lmom"
+ | "momr" -> "rmom"
+ | "lmom" -> "moml"
+ | "rmom" -> "momr"
+ | "svl" -> "svr"
+ | "svr" -> "svl"
+ | "sl" -> "sr"
+ | "sr" -> "sl"
+ | "s" -> "s"
+ | "p" -> "p"
+ | _ -> invalid_arg "Targets:Fortran_Majorana_Fermions: wrong case"
+
+ let print_fermion_current_mom coeff f c wf1 wf2 p1 p2 p12 fusion =
+ let c = format_coupling_mom coeff c in
+ let c1 = fastener c 1 and
+ c2 = fastener c 2 in
+ match fusion with
+ | F13 -> printf "%s_ff(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p12
+ | F31 -> printf "%s_ff(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p12
+ | F23 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p1
+ | F32 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf2 wf1 p2
+ | F12 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf2 wf1 p2
+ | F21 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p1
+
+ (*i unused value
+ let print_fermion_current_mom_vector coeff f c wf1 wf2 p1 p2 p12 fusion =
+ let c = format_coupling_mom coeff c in
+ let c1 = fastener c 1 and
+ c2 = fastener c 2 in
+ match fusion with
+ | F13 -> printf "%s_ff(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p12
+ | F31 -> printf "%s_ff(-%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p12
+ | F23 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p1
+ | F32 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf2 wf1 p2
+ | F12 -> printf "f_%sf(-%s,%s,%s,%s,%s)" f c1 c2 wf2 wf1 p2
+ | F21 -> printf "f_%sf(-%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p1
+ i*)
+
+ let print_fermion_current_mom_sign coeff f c wf1 wf2 p1 p2 p12 fusion =
+ let c = format_coupling_mom coeff c in
+ let c1 = fastener c 1 and
+ c2 = fastener c 2 in
+ match fusion with
+ | F13 -> printf "%s_ff(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p12
+ | F31 -> printf "%s_ff(%s,%s,%s,%s,-(%s))" f c1 c2 wf1 wf2 p12
+ | F23 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p1
+ | F32 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf2 wf1 p2
+ | F12 -> printf "f_%sf(%s,%s,%s,%s,-(%s))" f c1 c2 wf2 wf1 p2
+ | F21 -> printf "f_%sf(%s,%s,%s,%s,-(%s))" f c1 c2 wf1 wf2 p1
+
+ let print_fermion_current_mom_sign_1 coeff f c wf1 wf2 p1 p2 p12 fusion =
+ let c = format_coupling coeff c in
+ match fusion with
+ | F13 -> printf "%s_ff(%s,%s,%s,%s)" f c wf1 wf2 p12
+ | F31 -> printf "%s_ff(%s,%s,%s,-(%s))" f c wf1 wf2 p12
+ | F23 -> printf "f_%sf(%s,%s,%s,%s)" f c wf1 wf2 p1
+ | F32 -> printf "f_%sf(%s,%s,%s,%s)" f c wf2 wf1 p2
+ | F12 -> printf "f_%sf(%s,%s,%s,-(%s))" f c wf2 wf1 p2
+ | F21 -> printf "f_%sf(%s,%s,%s,-(%s))" f c wf1 wf2 p1
+
+ let print_fermion_current_mom_chiral coeff f c wf1 wf2 p1 p2 p12 fusion =
+ let c = format_coupling_mom coeff c and
+ cf = commute_proj f in
+ let c1 = fastener c 1 and
+ c2 = fastener c 2 in
+ match fusion with
+ | F13 -> printf "%s_ff(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p12
+ | F31 -> printf "%s_ff(%s,%s,%s, %s,-(%s))" cf c1 c2 wf1 wf2 p12
+ | F23 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf1 wf2 p1
+ | F32 -> printf "f_%sf(%s,%s,%s,%s,%s)" f c1 c2 wf2 wf1 p2
+ | F12 -> printf "f_%sf(%s,%s,%s,%s,-(%s))" cf c1 c2 wf2 wf1 p2
+ | F21 -> printf "f_%sf(%s,%s,%s,%s,-(%s))" cf c1 c2 wf1 wf2 p1
+
+ let print_fermion_g_current coeff f c wf1 wf2 p1 p2 p12 fusion =
+ let c = format_coupling coeff c in
+ match fusion with
+ | F13 -> printf "%s_grf(%s,%s,%s,%s)" f c wf1 wf2 p12
+ | F31 -> printf "%s_fgr(%s,%s,%s,%s)" f c wf1 wf2 p12
+ | F23 -> printf "gr_%sf(%s,%s,%s,%s)" f c wf1 wf2 p1
+ | F32 -> printf "gr_%sf(%s,%s,%s,%s)" f c wf2 wf1 p2
+ | F12 -> printf "f_%sgr(%s,%s,%s,%s)" f c wf2 wf1 p2
+ | F21 -> printf "f_%sgr(%s,%s,%s,%s)" f c wf1 wf2 p1
+
+ let print_fermion_g_2_current coeff f c wf1 wf2 p1 p2 p12 fusion =
+ let c = format_coupling coeff c in
+ match fusion with
+ | F13 -> printf "%s_grf(%s(1),%s(2),%s,%s,%s)" f c c wf1 wf2 p12
+ | F31 -> printf "%s_fgr(%s(1),%s(2),%s,%s,%s)" f c c wf1 wf2 p12
+ | F23 -> printf "gr_%sf(%s(1),%s(2),%s,%s,%s)" f c c wf1 wf2 p1
+ | F32 -> printf "gr_%sf(%s(1),%s(2),%s,%s,%s)" f c c wf2 wf1 p2
+ | F12 -> printf "f_%sgr(%s(1),%s(2),%s,%s,%s)" f c c wf2 wf1 p2
+ | F21 -> printf "f_%sgr(%s(1),%s(2),%s,%s,%s)" f c c wf1 wf2 p1
+
+ let print_fermion_g_current_rev coeff f c wf1 wf2 p1 p2 p12 fusion =
+ let c = format_coupling coeff c in
+ match fusion with
+ | F13 -> printf "%s_fgr(%s,%s,%s,%s)" f c wf1 wf2 p12
+ | F31 -> printf "%s_grf(%s,%s,%s,%s)" f c wf1 wf2 p12
+ | F23 -> printf "f_%sgr(%s,%s,%s,%s)" f c wf1 wf2 p1
+ | F32 -> printf "f_%sgr(%s,%s,%s,%s)" f c wf2 wf1 p2
+ | F12 -> printf "gr_%sf(%s,%s,%s,%s)" f c wf2 wf1 p2
+ | F21 -> printf "gr_%sf(%s,%s,%s,%s)" f c wf1 wf2 p1
+
+ let print_fermion_g_2_current_rev coeff f c wf1 wf2 p1 p2 p12 fusion =
+ let c = format_coupling coeff c in
+ match fusion with
+ | F13 -> printf "%s_fgr(%s(1),%s(2),%s,%s,%s)" f c c wf1 wf2 p12
+ | F31 -> printf "%s_grf(%s(1),%s(2),%s,%s,%s)" f c c wf1 wf2 p12
+ | F23 -> printf "f_%sgr(%s(1),%s(2),%s,%s,%s)" f c c wf1 wf2 p1
+ | F32 -> printf "f_%sgr(%s(1),%s(2),%s,%s,%s)" f c c wf2 wf1 p2
+ | F12 -> printf "gr_%sf(%s(1),%s(2),%s,%s,%s)" f c c wf2 wf1 p2
+ | F21 -> printf "gr_%sf(%s(1),%s(2),%s,%s,%s)" f c c wf1 wf2 p1
+
+ let print_fermion_g_current_vector coeff f c wf1 wf2 _ _ _ fusion =
+ let c = format_coupling coeff c in
+ match fusion with
+ | F13 -> printf "%s_grf(%s,%s,%s)" f c wf1 wf2
+ | F31 -> printf "%s_fgr(-%s,%s,%s)" f c wf1 wf2
+ | F23 -> printf "gr_%sf(%s,%s,%s)" f c wf1 wf2
+ | F32 -> printf "gr_%sf(%s,%s,%s)" f c wf2 wf1
+ | F12 -> printf "f_%sgr(-%s,%s,%s)" f c wf2 wf1
+ | F21 -> printf "f_%sgr(-%s,%s,%s)" f c wf1 wf2
+
+ let print_fermion_g_current_vector_rev coeff f c wf1 wf2 _ _ _ fusion =
+ let c = format_coupling coeff c in
+ match fusion with
+ | F13 -> printf "%s_fgr(%s,%s,%s)" f c wf1 wf2
+ | F31 -> printf "%s_grf(-%s,%s,%s)" f c wf1 wf2
+ | F23 -> printf "f_%sgr(%s,%s,%s)" f c wf1 wf2
+ | F32 -> printf "f_%sgr(%s,%s,%s)" f c wf2 wf1
+ | F12 -> printf "gr_%sf(-%s,%s,%s)" f c wf2 wf1
+ | F21 -> printf "gr_%sf(-%s,%s,%s)" f c wf1 wf2
+
+ let print_current_g = function
+ | coeff, _, MOM, _ -> print_fermion_current_mom_sign coeff "mom"
+ | coeff, _, MOM5, _ -> print_fermion_current_mom coeff "mom5"
+ | coeff, _, MOML, _ -> print_fermion_current_mom_chiral coeff "moml"
+ | coeff, _, MOMR, _ -> print_fermion_current_mom_chiral coeff "momr"
+ | coeff, _, LMOM, _ -> print_fermion_current_mom_chiral coeff "lmom"
+ | coeff, _, RMOM, _ -> print_fermion_current_mom_chiral coeff "rmom"
+ | coeff, _, VMOM, _ -> print_fermion_current_mom_sign_1 coeff "vmom"
+ | coeff, Gravbar, S, _ -> print_fermion_g_current coeff "s"
+ | coeff, Gravbar, SL, _ -> print_fermion_g_current coeff "sl"
+ | coeff, Gravbar, SR, _ -> print_fermion_g_current coeff "sr"
+ | coeff, Gravbar, SLR, _ -> print_fermion_g_2_current coeff "slr"
+ | coeff, Gravbar, P, _ -> print_fermion_g_current coeff "p"
+ | coeff, Gravbar, V, _ -> print_fermion_g_current coeff "v"
+ | coeff, Gravbar, VLR, _ -> print_fermion_g_2_current coeff "vlr"
+ | coeff, Gravbar, POT, _ -> print_fermion_g_current_vector coeff "pot"
+ | coeff, _, S, Grav -> print_fermion_g_current_rev coeff "s"
+ | coeff, _, SL, Grav -> print_fermion_g_current_rev coeff "sl"
+ | coeff, _, SR, Grav -> print_fermion_g_current_rev coeff "sr"
+ | coeff, _, SLR, Grav -> print_fermion_g_2_current_rev coeff "slr"
+ | coeff, _, P, Grav -> print_fermion_g_current_rev (-coeff) "p"
+ | coeff, _, V, Grav -> print_fermion_g_current_rev coeff "v"
+ | coeff, _, VLR, Grav -> print_fermion_g_2_current_rev coeff "vlr"
+ | coeff, _, POT, Grav -> print_fermion_g_current_vector_rev coeff "pot"
+ | _, _, _, _ -> invalid_arg
+ "Targets.Fortran_Majorana_Fermions: not used in the models"
+
+ let print_current_mom = function
+ | coeff, _, TVA, _ -> print_fermion_current_mom_v1 coeff "tva"
+ | coeff, _, TVAM, _ -> print_fermion_current_mom_v2 coeff "tvam"
+ | coeff, _, TLR, _ -> print_fermion_current_mom_v1_chiral coeff "tlr"
+ | coeff, _, TLRM, _ -> print_fermion_current_mom_v2_chiral coeff "tlrm"
+ | _, _, _, _ -> invalid_arg
+ "Targets.Fortran_Majorana_Fermions: Not needed in the models"
+
+(* We need support for dimension-5 vertices with two fermions and two
+ bosons, appearing in theories of supergravity and also together with in
+ insertions of the supersymmetric current. There is a canonical order
+ [fermionbar], [boson_1], [boson_2], [fermion], so what one has to do is a
+ mapping from the fusions [F123] etc. to the order of the three wave
+ functions [wf1], [wf2] and [wf3]. *)
+
+(* The function [d_p] (for distinct the particle) distinguishes which particle
+ (scalar or vector) must be fused to in the special functions. *)
+
+ let d_p = function
+ | 1, ("sv"|"pv"|"svl"|"svr"|"slrv") -> "1"
+ | 1, _ -> ""
+ | 2, ("sv"|"pv"|"svl"|"svr"|"slrv") -> "2"
+ | 2, _ -> ""
+ | _, _ -> invalid_arg "Targets.Fortran_Majorana_Fermions: not used"
+
+ let wf_of_f wf1 wf2 wf3 f =
+ match f with
+ | (F123|F423) -> [wf2; wf3; wf1]
+ | (F213|F243|F143|F142|F413|F412) -> [wf1; wf3; wf2]
+ | (F132|F432) -> [wf3; wf2; wf1]
+ | (F231|F234|F134|F124|F431|F421) -> [wf1; wf2; wf3]
+ | (F312|F342) -> [wf3; wf1; wf2]
+ | (F321|F324|F314|F214|F341|F241) -> [wf2; wf1; wf3]
+
+ let print_fermion_g4_brs_vector_current coeff f c wf1 wf2 wf3 fusion =
+ let cf = commute_proj f and
+ cp = format_coupling coeff c and
+ cm = if f = "pv" then
+ format_coupling coeff c
+ else
+ format_coupling (-coeff) c
+ and
+ d1 = d_p (1,f) and
+ d2 = d_p (2,f) and
+ f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
+ f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
+ f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
+ match fusion with
+ | (F123|F213|F132|F231|F312|F321) ->
+ printf "f_%sf(%s,%s,%s,%s)" cf cm f1 f2 f3
+ | (F423|F243|F432|F234|F342|F324) ->
+ printf "f_%sf(%s,%s,%s,%s)" f cp f1 f2 f3
+ | (F134|F143|F314) -> printf "%s%s_ff(%s,%s,%s,%s)" f d1 cp f1 f2 f3
+ | (F124|F142|F214) -> printf "%s%s_ff(%s,%s,%s,%s)" f d2 cp f1 f2 f3
+ | (F413|F431|F341) -> printf "%s%s_ff(%s,%s,%s,%s)" cf d1 cm f1 f2 f3
+ | (F241|F412|F421) -> printf "%s%s_ff(%s,%s,%s,%s)" cf d2 cm f1 f2 f3
+
+ let print_fermion_g4_svlr_current coeff _ c wf1 wf2 wf3 fusion =
+ let c = format_coupling_2 coeff c and
+ f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
+ f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
+ f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
+ let c1 = fastener c 1 and
+ c2 = fastener c 2 in
+ match fusion with
+ | (F123|F213|F132|F231|F312|F321) ->
+ printf "f_svlrf(-(%s),-(%s),%s,%s,%s)" c2 c1 f1 f2 f3
+ | (F423|F243|F432|F234|F342|F324) ->
+ printf "f_svlrf(%s,%s,%s,%s,%s)" c1 c2 f1 f2 f3
+ | (F134|F143|F314) ->
+ printf "svlr2_ff(%s,%s,%s,%s,%s)" c1 c2 f1 f2 f3
+ | (F124|F142|F214) ->
+ printf "svlr1_ff(%s,%s,%s,%s,%s)" c1 c2 f1 f2 f3
+ | (F413|F431|F341) ->
+ printf "svlr2_ff(-(%s),-(%s),%s,%s,%s)" c2 c1 f1 f2 f3
+ | (F241|F412|F421) ->
+ printf "svlr1_ff(-(%s),-(%s),%s,%s,%s)" c2 c1 f1 f2 f3
+
+ let print_fermion_s2_current coeff f c wf1 wf2 wf3 fusion =
+ let cp = format_coupling coeff c and
+ cm = if f = "p" then
+ format_coupling (-coeff) c
+ else
+ format_coupling coeff c
+ and
+ cf = commute_proj f and
+ f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
+ f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
+ f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
+ match fusion with
+ | (F123|F213|F132|F231|F312|F321) ->
+ printf "%s * f_%sf(%s,%s,%s)" f1 cf cm f2 f3
+ | (F423|F243|F432|F234|F342|F324) ->
+ printf "%s * f_%sf(%s,%s,%s)" f1 f cp f2 f3
+ | (F134|F143|F314) ->
+ printf "%s * %s_ff(%s,%s,%s)" f2 f cp f1 f3
+ | (F124|F142|F214) ->
+ printf "%s * %s_ff(%s,%s,%s)" f2 f cp f1 f3
+ | (F413|F431|F341) ->
+ printf "%s * %s_ff(%s,%s,%s)" f2 cf cm f1 f3
+ | (F241|F412|F421) ->
+ printf "%s * %s_ff(%s,%s,%s)" f2 cf cm f1 f3
+
+ let print_fermion_s2p_current coeff f c wf1 wf2 wf3 fusion =
+ let c = format_coupling_2 coeff c and
+ f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
+ f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
+ f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
+ let c1 = fastener c 1 and
+ c2 = fastener c 2 in
+ match fusion with
+ | (F123|F213|F132|F231|F312|F321) ->
+ printf "%s * f_%sf(%s,-(%s),%s,%s)" f1 f c1 c2 f2 f3
+ | (F423|F243|F432|F234|F342|F324) ->
+ printf "%s * f_%sf(%s,%s,%s,%s)" f1 f c1 c2 f2 f3
+ | (F134|F143|F314) ->
+ printf "%s * %s_ff(%s,%s,%s,%s)" f2 f c1 c2 f1 f3
+ | (F124|F142|F214) ->
+ printf "%s * %s_ff(%s,%s,%s,%s)" f2 f c1 c2 f1 f3
+ | (F413|F431|F341) ->
+ printf "%s * %s_ff(%s,-(%s),%s,%s)" f2 f c1 c2 f1 f3
+ | (F241|F412|F421) ->
+ printf "%s * %s_ff(%s,-(%s),%s,%s)" f2 f c1 c2 f1 f3
+
+ let print_fermion_s2lr_current coeff f c wf1 wf2 wf3 fusion =
+ let c = format_coupling_2 coeff c and
+ f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
+ f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
+ f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
+ let c1 = fastener c 1 and
+ c2 = fastener c 2 in
+ match fusion with
+ | (F123|F213|F132|F231|F312|F321) ->
+ printf "%s * f_%sf(%s,%s,%s,%s)" f1 f c2 c1 f2 f3
+ | (F423|F243|F432|F234|F342|F324) ->
+ printf "%s * f_%sf(%s,%s,%s,%s)" f1 f c1 c2 f2 f3
+ | (F134|F143|F314) ->
+ printf "%s * %s_ff(%s,%s,%s,%s)" f2 f c1 c2 f1 f3
+ | (F124|F142|F214) ->
+ printf "%s * %s_ff(%s,%s,%s,%s)" f2 f c1 c2 f1 f3
+ | (F413|F431|F341) ->
+ printf "%s * %s_ff(%s,%s,%s,%s)" f2 f c2 c1 f1 f3
+ | (F241|F412|F421) ->
+ printf "%s * %s_ff(%s,%s,%s,%s)" f2 f c2 c1 f1 f3
+
+ let print_fermion_g4_current coeff f c wf1 wf2 wf3 fusion =
+ let c = format_coupling coeff c and
+ f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
+ f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
+ f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
+ match fusion with
+ | (F123|F213|F132|F231|F312|F321) ->
+ printf "f_%sgr(-%s,%s,%s,%s)" f c f1 f2 f3
+ | (F423|F243|F432|F234|F342|F324) ->
+ printf "gr_%sf(%s,%s,%s,%s)" f c f1 f2 f3
+ | (F134|F143|F314|F124|F142|F214) ->
+ printf "%s_grf(%s,%s,%s,%s)" f c f1 f2 f3
+ | (F413|F431|F341|F241|F412|F421) ->
+ printf "%s_fgr(-%s,%s,%s,%s)" f c f1 f2 f3
+
+ (*i unused value
+ let print_fermion_2_g4_current coeff f c wf1 wf2 wf3 fusion =
+ let f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
+ f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
+ f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
+ let c = format_coupling_2 coeff c in
+ let c1 = fastener c 1 and
+ c2 = fastener c 2 in
+ match fusion with
+ | (F123|F213|F132|F231|F312|F321) ->
+ printf "f_%sgr(-(%s),-(%s),%s,%s,%s)" f c2 c1 f1 f2 f3
+ | (F423|F243|F432|F234|F342|F324) ->
+ printf "gr_%sf(%s,%s,%s,%s,%s)" f c1 c2 f1 f2 f3
+ | (F134|F143|F314|F124|F142|F214) ->
+ printf "%s_grf(%s,%s,%s,%s,%s)" f c1 c2 f1 f2 f3
+ | (F413|F431|F341|F241|F412|F421) ->
+ printf "%s_fgr(-(%s),-(%s),%s,%s,%s)" f c2 c1 f1 f2 f3
+ i*)
+
+ let print_fermion_2_g4_current coeff f c wf1 wf2 wf3 fusion =
+ let f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
+ f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
+ f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
+ let c = format_coupling_2 coeff c in
+ let c1 = fastener c 1 and
+ c2 = fastener c 2 in
+ match fusion with
+ | (F123|F213|F132|F231|F312|F321) ->
+ printf "f_%sgr(-(%s),-(%s),%s,%s,%s)" f c2 c1 f1 f2 f3
+ | (F423|F243|F432|F234|F342|F324) ->
+ printf "gr_%sf(%s,%s,%s,%s,%s)" f c1 c2 f1 f2 f3
+ | (F134|F143|F314|F124|F142|F214) ->
+ printf "%s_grf(%s,%s,%s,%s,%s)" f c1 c2 f1 f2 f3
+ | (F413|F431|F341|F241|F412|F421) ->
+ printf "%s_fgr(-(%s),-(%s),%s,%s,%s)" f c2 c1 f1 f2 f3
+
+
+ let print_fermion_g4_current_rev coeff f c wf1 wf2 wf3 fusion =
+ let c = format_coupling coeff c and
+ f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
+ f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
+ f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
+ match fusion with
+ | (F123|F213|F132|F231|F312|F321) ->
+ printf "f_%sgr(%s,%s,%s,%s)" f c f1 f2 f3
+ | (F423|F243|F432|F234|F342|F324) ->
+ printf "gr_%sf(-%s,%s,%s,%s)" f c f1 f2 f3
+ | (F134|F143|F314|F124|F142|F214) ->
+ printf "%s_grf(-%s,%s,%s,%s)" f c f1 f2 f3
+ | (F413|F431|F341|F241|F412|F421) ->
+ printf "%s_fgr(%s,%s,%s,%s)" f c f1 f2 f3
+
+(* Here we have to distinguish which of the two bosons is produced in the
+ fusion of three particles which include both fermions. *)
+
+ let print_fermion_g4_vector_current coeff f c wf1 wf2 wf3 fusion =
+ let c = format_coupling coeff c and
+ d1 = d_p (1,f) and
+ d2 = d_p (2,f) and
+ f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
+ f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
+ f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
+ match fusion with
+ | (F123|F213|F132|F231|F312|F321) ->
+ printf "f_%sgr(%s,%s,%s,%s)" f c f1 f2 f3
+ | (F423|F243|F432|F234|F342|F324) ->
+ printf "gr_%sf(%s,%s,%s,%s)" f c f1 f2 f3
+ | (F134|F143|F314) -> printf "%s%s_grf(%s,%s,%s,%s)" f d1 c f1 f2 f3
+ | (F124|F142|F214) -> printf "%s%s_grf(%s,%s,%s,%s)" f d2 c f1 f2 f3
+ | (F413|F431|F341) -> printf "%s%s_fgr(%s,%s,%s,%s)" f d1 c f1 f2 f3
+ | (F241|F412|F421) -> printf "%s%s_fgr(%s,%s,%s,%s)" f d2 c f1 f2 f3
+
+ let print_fermion_2_g4_vector_current coeff f c wf1 wf2 wf3 fusion =
+ let d1 = d_p (1,f) and
+ d2 = d_p (2,f) and
+ f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
+ f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
+ f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
+ let c = format_coupling_2 coeff c in
+ let c1 = fastener c 1 and
+ c2 = fastener c 2 in
+ match fusion with
+ | (F123|F213|F132|F231|F312|F321) ->
+ printf "f_%sgr(%s,%s,%s,%s,%s)" f c1 c2 f1 f2 f3
+ | (F423|F243|F432|F234|F342|F324) ->
+ printf "gr_%sf(%s,%s,%s,%s,%s)" f c1 c2 f1 f2 f3
+ | (F134|F143|F314) -> printf "%s%s_grf(%s,%s,%s,%s,%s)" f d1 c1 c2 f1 f2 f3
+ | (F124|F142|F214) -> printf "%s%s_grf(%s,%s,%s,%s,%s)" f d2 c1 c2 f1 f2 f3
+ | (F413|F431|F341) -> printf "%s%s_fgr(%s,%s,%s,%s,%s)" f d1 c1 c2 f1 f2 f3
+ | (F241|F412|F421) -> printf "%s%s_fgr(%s,%s,%s,%s,%s)" f d2 c1 c2 f1 f2 f3
+
+ let print_fermion_g4_vector_current_rev coeff f c wf1 wf2 wf3 fusion =
+ let c = format_coupling coeff c and
+ d1 = d_p (1,f) and
+ d2 = d_p (2,f) and
+ f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
+ f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
+ f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
+ match fusion with
+ | (F123|F213|F132|F231|F312|F321) ->
+ printf "gr_%sf(%s,%s,%s,%s)" f c f1 f2 f3
+ | (F423|F243|F432|F234|F342|F324) ->
+ printf "f_%sgr(%s,%s,%s,%s)" f c f1 f2 f3
+ | (F134|F143|F314) -> printf "%s%s_fgr(%s,%s,%s,%s)" f d1 c f1 f2 f3
+ | (F124|F142|F214) -> printf "%s%s_fgr(%s,%s,%s,%s)" f d2 c f1 f2 f3
+ | (F413|F431|F341) -> printf "%s%s_grf(%s,%s,%s,%s)" f d1 c f1 f2 f3
+ | (F241|F412|F421) -> printf "%s%s_grf(%s,%s,%s,%s)" f d2 c f1 f2 f3
+
+ let print_fermion_2_g4_current_rev coeff f c wf1 wf2 wf3 fusion =
+ let c = format_coupling_2 coeff c in
+ let c1 = fastener c 1 and
+ c2 = fastener c 2 and
+ d1 = d_p (1,f) and
+ d2 = d_p (2,f) in
+ let f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
+ f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
+ f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
+ match fusion with
+ | (F123|F213|F132|F231|F312|F321) ->
+ printf "gr_%sf(%s,%s,%s,%s,%s)" f c1 c2 f1 f2 f3
+ | (F423|F243|F432|F234|F342|F324) ->
+ printf "f_%sgr(-(%s),-(%s),%s,%s,%s)" f c1 c2 f1 f2 f3
+ | (F134|F143|F314) ->
+ printf "%s%s_fgr(-(%s),-(%s),%s,%s,%s)" f d1 c1 c2 f1 f2 f3
+ | (F124|F142|F214) ->
+ printf "%s%s_fgr(-(%s),-(%s),%s,%s,%s)" f d2 c1 c2 f1 f2 f3
+ | (F413|F431|F341) ->
+ printf "%s%s_grf(%s,%s,%s,%s,%s)" f d1 c1 c2 f1 f2 f3
+ | (F241|F412|F421) ->
+ printf "%s%s_grf(%s,%s,%s,%s,%s)" f d2 c1 c2 f1 f2 f3
+
+ let print_fermion_2_g4_vector_current_rev coeff f c wf1 wf2 wf3 fusion =
+ (* Here we put in the extra minus sign from the coeff. *)
+ let c = format_coupling coeff c in
+ let c1 = fastener c 1 and
+ c2 = fastener c 2 in
+ let d1 = d_p (1,f) and
+ d2 = d_p (2,f) and
+ f1 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 0) and
+ f2 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 1) and
+ f3 = (List.nth (wf_of_f wf1 wf2 wf3 fusion) 2) in
+ match fusion with
+ | (F123|F213|F132|F231|F312|F321) ->
+ printf "gr_%sf(%s,%s,%s,%s,%s)" f c1 c2 f1 f2 f3
+ | (F423|F243|F432|F234|F342|F324) ->
+ printf "f_%sgr(%s,%s,%s,%s,%s)" f c1 c2 f1 f2 f3
+ | (F134|F143|F314) -> printf "%s%s_fgr(%s,%s,%s,%s,%s)" f d1 c1 c2 f1 f2 f3
+ | (F124|F142|F214) -> printf "%s%s_fgr(%s,%s,%s,%s,%s)" f d2 c1 c2 f1 f2 f3
+ | (F413|F431|F341) -> printf "%s%s_grf(%s,%s,%s,%s,%s)" f d1 c1 c2 f1 f2 f3
+ | (F241|F412|F421) -> printf "%s%s_grf(%s,%s,%s,%s,%s)" f d2 c1 c2 f1 f2 f3
+
+
+ let print_current_g4 = function
+ | coeff, Gravbar, S2, _ -> print_fermion_g4_current coeff "s2"
+ | coeff, Gravbar, SV, _ -> print_fermion_g4_vector_current coeff "sv"
+ | coeff, Gravbar, SLV, _ -> print_fermion_g4_vector_current coeff "slv"
+ | coeff, Gravbar, SRV, _ -> print_fermion_g4_vector_current coeff "srv"
+ | coeff, Gravbar, SLRV, _ -> print_fermion_2_g4_vector_current coeff "slrv"
+ | coeff, Gravbar, PV, _ -> print_fermion_g4_vector_current coeff "pv"
+ | coeff, Gravbar, V2, _ -> print_fermion_g4_current coeff "v2"
+ | coeff, Gravbar, V2LR, _ -> print_fermion_2_g4_current coeff "v2lr"
+ | _, Gravbar, _, _ -> invalid_arg "print_current_g4: not implemented"
+ | coeff, _, S2, Grav -> print_fermion_g4_current_rev coeff "s2"
+ | coeff, _, SV, Grav -> print_fermion_g4_vector_current_rev (-coeff) "sv"
+ | coeff, _, SLV, Grav -> print_fermion_g4_vector_current_rev (-coeff) "slv"
+ | coeff, _, SRV, Grav -> print_fermion_g4_vector_current_rev (-coeff) "srv"
+ | coeff, _, SLRV, Grav -> print_fermion_2_g4_vector_current_rev coeff "slrv"
+ | coeff, _, PV, Grav -> print_fermion_g4_vector_current_rev coeff "pv"
+ | coeff, _, V2, Grav -> print_fermion_g4_vector_current_rev coeff "v2"
+ | coeff, _, V2LR, Grav -> print_fermion_2_g4_current_rev coeff "v2lr"
+ | _, _, _, Grav -> invalid_arg "print_current_g4: not implemented"
+ | coeff, _, S2, _ -> print_fermion_s2_current coeff "s"
+ | coeff, _, P2, _ -> print_fermion_s2_current coeff "p"
+ | coeff, _, S2P, _ -> print_fermion_s2p_current coeff "sp"
+ | coeff, _, S2L, _ -> print_fermion_s2_current coeff "sl"
+ | coeff, _, S2R, _ -> print_fermion_s2_current coeff "sr"
+ | coeff, _, S2LR, _ -> print_fermion_s2lr_current coeff "slr"
+ | coeff, _, V2, _ -> print_fermion_g4_brs_vector_current coeff "v2"
+ | coeff, _, SV, _ -> print_fermion_g4_brs_vector_current coeff "sv"
+ | coeff, _, PV, _ -> print_fermion_g4_brs_vector_current coeff "pv"
+ | coeff, _, SLV, _ -> print_fermion_g4_brs_vector_current coeff "svl"
+ | coeff, _, SRV, _ -> print_fermion_g4_brs_vector_current coeff "svr"
+ | coeff, _, SLRV, _ -> print_fermion_g4_svlr_current coeff "svlr"
+ | _, _, V2LR, _ -> invalid_arg "Targets.print_current: not available"
+
+ let reverse_braket vintage bra ket =
+ if vintage then
+ false
+ else
+ match bra, ket with
+ | Majorana, Majorana :: _ -> true
+ | _, _ -> false
+
+ end
+
+(* \thocwmodulesubsection{Currents for [Coupling.V3] and [Coupling.V4]} *)
+
+module type T =
+ sig
+ type amplitude
+ type constant
+ type wf
+ type rhs
+ val print_current_V3 :
+ (amplitude -> (amplitude -> wf -> int) -> wf -> string) -> (wf -> string) ->
+ amplitude -> (amplitude -> wf -> int) -> rhs ->
+ constant Coupling.vertex3 -> Coupling.fuse2 -> constant -> unit
+ val print_current_V4 :
+ (amplitude -> (amplitude -> wf -> int) -> wf -> string) -> (wf -> string) ->
+ amplitude -> (amplitude -> wf -> int) -> rhs ->
+ constant Coupling.vertex4 -> Coupling.fuse3 -> constant -> unit
+ end
+
+module type Maker =
+ functor (N : Target_Fortran_Names.T) -> functor (F : Fermion_Maker) ->
+ functor (FM : Fusion.Maker) -> functor (P : Momentum.T) -> functor (M : Model.T) -> T
+ with type amplitude = Fusion.Multi(FM)(P)(M).amplitude
+ and type constant = Orders.Slice(Colorize.It(M)).constant
+ and type wf = FM(P)(M).wf
+ and type rhs = FM(P)(M).rhs
+
+module Make_Fortran (Names : Target_Fortran_Names.T) (Fermion_Maker : Fermion_Maker)
+ (FM : Fusion.Maker) (P : Momentum.T) (M : Model.T) =
+ struct
+
+ open Coupling
+ open Format
+
+ module Fermions = Fermion_Maker(Names)
+
+ module CM = Colorize.It(M)
+ module SCM = Orders.Slice(Colorize.It(M))
+ module F = FM(P)(M)
+ module CF = Fusion.Multi(FM)(P)(M)
+
+ type amplitude = CF.amplitude
+ type constant = Orders.Slice(Colorize.It(M)).constant
+ type wf = F.wf
+ type rhs = F.rhs
+
+ let children2 rhs =
+ match F.children rhs with
+ | [wf1; wf2] -> (wf1, wf2)
+ | _ -> failwith "Targets.children2: can't happen"
+
+ let children3 rhs =
+ match F.children rhs with
+ | [wf1; wf2; wf3] -> (wf1, wf2, wf3)
+ | _ -> invalid_arg "Targets.children3: can't happen"
+
+(* Note that it is (marginally) faster to multiply the two scalar products
+ with the coupling constant than the four vector components.
+ \begin{dubious}
+ This could be part of \verb+omegalib+ as well \ldots
+ \end{dubious} *)
+
+ let format_coeff = function
+ | 1 -> ""
+ | -1 -> "-"
+ | coeff -> "(" ^ string_of_int coeff ^ ")*"
+
+ let format_coupling coeff c =
+ match coeff with
+ | 1 -> c
+ | -1 -> "(-" ^ c ^")"
+ | coeff -> string_of_int coeff ^ "*" ^ c
+
+(* \begin{dubious}
+ The following is error prone and should be generated automagically.
+ \end{dubious} *)
+
+ let print_vector4 c wf1 wf2 wf3 fusion (coeff, contraction) =
+ match contraction, fusion with
+ | C_12_34, (F341|F431|F342|F432|F123|F213|F124|F214)
+ | C_13_42, (F241|F421|F243|F423|F132|F312|F134|F314)
+ | C_14_23, (F231|F321|F234|F324|F142|F412|F143|F413) ->
+ printf "((%s%s)*(%s*%s))*%s" (format_coeff coeff) c wf1 wf2 wf3
+ | C_12_34, (F134|F143|F234|F243|F312|F321|F412|F421)
+ | C_13_42, (F124|F142|F324|F342|F213|F231|F413|F431)
+ | C_14_23, (F123|F132|F423|F432|F214|F241|F314|F341) ->
+ printf "((%s%s)*(%s*%s))*%s" (format_coeff coeff) c wf2 wf3 wf1
+ | C_12_34, (F314|F413|F324|F423|F132|F231|F142|F241)
+ | C_13_42, (F214|F412|F234|F432|F123|F321|F143|F341)
+ | C_14_23, (F213|F312|F243|F342|F124|F421|F134|F431) ->
+ printf "((%s%s)*(%s*%s))*%s" (format_coeff coeff) c wf1 wf3 wf2
+
+ let print_vector4_t_0 c wf1 p1 wf2 p2 wf3 p3 fusion (coeff, contraction) =
+ match contraction, fusion with
+ | C_12_34, (F234|F243|F134|F143|F421|F321|F412|F312)
+ | C_13_42, (F324|F342|F124|F142|F431|F231|F413|F213)
+ | C_14_23, (F423|F432|F123|F132|F341|F241|F314|F214) ->
+ printf "g_dim8g3_t_0(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | C_12_34, (F324|F314|F423|F413|F142|F132|F241|F231)
+ | C_13_42, (F234|F214|F432|F412|F143|F123|F341|F321)
+ | C_14_23, (F243|F213|F342|F312|F134|F124|F431|F421) ->
+ printf "g_dim8g3_t_0(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | C_12_34, (F342|F341|F432|F431|F124|F123|F214|F213)
+ | C_13_42, (F243|F241|F423|F421|F134|F132|F314|F312)
+ | C_14_23, (F234|F231|F324|F321|F143|F142|F413|F412) ->
+ printf "g_dim8g3_t_0(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+
+ let print_vector4_t_1 c wf1 p1 wf2 p2 wf3 p3 fusion (coeff, contraction) =
+ match contraction, fusion with
+ | C_12_34, (F234|F243|F134|F143|F421|F321|F412|F312)
+ | C_13_42, (F324|F342|F124|F142|F431|F231|F413|F213)
+ | C_14_23, (F423|F432|F123|F132|F341|F241|F314|F214) ->
+ printf "g_dim8g3_t_1(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | C_12_34, (F324|F314|F423|F413|F142|F132|F241|F231)
+ | C_13_42, (F234|F214|F432|F412|F143|F123|F341|F321)
+ | C_14_23, (F243|F213|F342|F312|F134|F124|F431|F421) ->
+ printf "g_dim8g3_t_1(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | C_12_34, (F342|F341|F432|F431|F124|F123|F214|F213)
+ | C_13_42, (F243|F241|F423|F421|F134|F132|F314|F312)
+ | C_14_23, (F234|F231|F324|F321|F143|F142|F413|F412) ->
+ printf "g_dim8g3_t_1(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+
+ let print_vector4_t_2 c wf1 p1 wf2 p2 wf3 p3 fusion (coeff, contraction) =
+ match contraction, fusion with
+ | C_12_34, (F234|F243|F134|F143|F421|F321|F412|F312)
+ | C_13_42, (F324|F342|F124|F142|F431|F231|F413|F213)
+ | C_14_23, (F423|F432|F123|F132|F341|F241|F314|F214) ->
+ printf "g_dim8g3_t_2(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | C_12_34, (F324|F314|F423|F413|F142|F132|F241|F231)
+ | C_13_42, (F234|F214|F432|F412|F143|F123|F341|F321)
+ | C_14_23, (F243|F213|F342|F312|F134|F124|F431|F421) ->
+ printf "g_dim8g3_t_2(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | C_12_34, (F342|F341|F432|F431|F124|F123|F214|F213)
+ | C_13_42, (F243|F241|F423|F421|F134|F132|F314|F312)
+ | C_14_23, (F234|F231|F324|F321|F143|F142|F413|F412) ->
+ printf "g_dim8g3_t_2(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+
+ let print_vector4_m_0 c wf1 p1 wf2 p2 wf3 p3 fusion (coeff, contraction) =
+ match contraction, fusion with
+ | C_12_34, (F234|F243|F134|F143|F421|F321|F412|F312)
+ | C_13_42, (F324|F342|F124|F142|F431|F231|F413|F213)
+ | C_14_23, (F423|F432|F123|F132|F341|F241|F314|F214) ->
+ printf "g_dim8g3_m_0(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | C_12_34, (F324|F314|F423|F413|F142|F132|F241|F231)
+ | C_13_42, (F234|F214|F432|F412|F143|F123|F341|F321)
+ | C_14_23, (F243|F213|F342|F312|F134|F124|F431|F421) ->
+ printf "g_dim8g3_m_0(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | C_12_34, (F342|F341|F432|F431|F124|F123|F214|F213)
+ | C_13_42, (F243|F241|F423|F421|F134|F132|F314|F312)
+ | C_14_23, (F234|F231|F324|F321|F143|F142|F413|F412) ->
+ printf "g_dim8g3_m_0(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+
+ let print_vector4_m_1 c wf1 p1 wf2 p2 wf3 p3 fusion (coeff, contraction) =
+ match contraction, fusion with
+ | C_12_34, (F234|F243|F134|F143|F421|F321|F412|F312)
+ | C_13_42, (F324|F342|F124|F142|F431|F231|F413|F213)
+ | C_14_23, (F423|F432|F123|F132|F341|F241|F314|F214) ->
+ printf "g_dim8g3_m_1(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | C_12_34, (F324|F314|F423|F413|F142|F132|F241|F231)
+ | C_13_42, (F234|F214|F432|F412|F143|F123|F341|F321)
+ | C_14_23, (F243|F213|F342|F312|F134|F124|F431|F421) ->
+ printf "g_dim8g3_m_1(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | C_12_34, (F342|F341|F432|F431|F124|F123|F214|F213)
+ | C_13_42, (F243|F241|F423|F421|F134|F132|F314|F312)
+ | C_14_23, (F234|F231|F324|F321|F143|F142|F413|F412) ->
+ printf "g_dim8g3_m_1(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+
+ let print_vector4_m_7 c wf1 p1 wf2 p2 wf3 p3 fusion (coeff, contraction) =
+ match contraction, fusion with
+ | C_12_34, (F234|F243|F134|F143|F421|F321|F412|F312)
+ | C_13_42, (F324|F342|F124|F142|F431|F231|F413|F213)
+ | C_14_23, (F423|F432|F123|F132|F341|F241|F314|F214) ->
+ printf "g_dim8g3_m_7(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | C_12_34, (F324|F314|F423|F413|F142|F132|F241|F231)
+ | C_13_42, (F234|F214|F432|F412|F143|F123|F341|F321)
+ | C_14_23, (F243|F213|F342|F312|F134|F124|F431|F421) ->
+ printf "g_dim8g3_m_7(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | C_12_34, (F342|F341|F432|F431|F124|F123|F214|F213)
+ | C_13_42, (F243|F241|F423|F421|F134|F132|F314|F312)
+ | C_14_23, (F234|F231|F324|F321|F143|F142|F413|F412) ->
+ printf "g_dim8g3_m_7(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+
+ let print_add_vector4 c wf1 wf2 wf3 fusion (coeff, contraction) =
+ printf "@ + ";
+ print_vector4 c wf1 wf2 wf3 fusion (coeff, contraction)
+
+ let print_vector4_km c pa pb wf1 wf2 wf3 fusion (coeff, contraction) =
+ match contraction, fusion with
+ | C_12_34, (F341|F431|F342|F432|F123|F213|F124|F214)
+ | C_13_42, (F241|F421|F243|F423|F132|F312|F134|F314)
+ | C_14_23, (F231|F321|F234|F324|F142|F412|F143|F413) ->
+ printf "((%s%s%s+%s))*(%s*%s))*%s"
+ (format_coeff coeff) c pa pb wf1 wf2 wf3
+ | C_12_34, (F134|F143|F234|F243|F312|F321|F412|F421)
+ | C_13_42, (F124|F142|F324|F342|F213|F231|F413|F431)
+ | C_14_23, (F123|F132|F423|F432|F214|F241|F314|F341) ->
+ printf "((%s%s%s+%s))*(%s*%s))*%s"
+ (format_coeff coeff) c pa pb wf2 wf3 wf1
+ | C_12_34, (F314|F413|F324|F423|F132|F231|F142|F241)
+ | C_13_42, (F214|F412|F234|F432|F123|F321|F143|F341)
+ | C_14_23, (F213|F312|F243|F342|F124|F421|F134|F431) ->
+ printf "((%s%s%s+%s))*(%s*%s))*%s"
+ (format_coeff coeff) c pa pb wf1 wf3 wf2
+
+ let print_vector4_km_t_0 c pa pb wf1 p1 wf2 p2 wf3 p3 fusion (coeff, contraction) =
+ match contraction, fusion with
+ | C_12_34, (F234|F243|F134|F143|F421|F321|F412|F312)
+ | C_13_42, (F324|F342|F124|F142|F431|F231|F413|F213)
+ | C_14_23, (F423|F432|F123|F132|F341|F241|F314|F214) ->
+ printf "@[(%s%s%s+%s)*g_dim8g3_t_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf1 p1 wf2 p2 wf3 p3
+ | C_12_34, (F324|F314|F423|F413|F142|F132|F241|F231)
+ | C_13_42, (F234|F214|F432|F412|F143|F123|F341|F321)
+ | C_14_23, (F243|F213|F342|F312|F134|F124|F431|F421) ->
+ printf "@[(%s%s%s+%s)*g_dim8g3_t_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf2 p2 wf1 p1 wf3 p3
+ | C_12_34, (F342|F341|F432|F431|F124|F123|F214|F213)
+ | C_13_42, (F243|F241|F423|F421|F134|F132|F314|F312)
+ | C_14_23, (F234|F231|F324|F321|F143|F142|F413|F412) ->
+ printf "@[(%s%s%s+%s)*g_dim8g3_t_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf3 p3 wf1 p1 wf2 p2
+
+ let print_vector4_km_t_1 c pa pb wf1 p1 wf2 p2 wf3 p3 fusion (coeff, contraction) =
+ match contraction, fusion with
+ | C_12_34, (F234|F243|F134|F143|F421|F321|F412|F312)
+ | C_13_42, (F324|F342|F124|F142|F431|F231|F413|F213)
+ | C_14_23, (F423|F432|F123|F132|F341|F241|F314|F214) ->
+ printf "@[(%s%s%s+%s)*g_dim8g3_t_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf1 p1 wf2 p2 wf3 p3
+ | C_12_34, (F324|F314|F423|F413|F142|F132|F241|F231)
+ | C_13_42, (F234|F214|F432|F412|F143|F123|F341|F321)
+ | C_14_23, (F243|F213|F342|F312|F134|F124|F431|F421) ->
+ printf "@[(%s%s%s+%s)*g_dim8g3_t_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf2 p2 wf1 p1 wf3 p3
+ | C_12_34, (F342|F341|F432|F431|F124|F123|F214|F213)
+ | C_13_42, (F243|F241|F423|F421|F134|F132|F314|F312)
+ | C_14_23, (F234|F231|F324|F321|F143|F142|F413|F412) ->
+ printf "@[(%s%s%s+%s)*g_dim8g3_t_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf3 p3 wf1 p1 wf2 p2
+
+ let print_vector4_km_t_2 c pa pb wf1 p1 wf2 p2 wf3 p3 fusion (coeff, contraction) =
+ match contraction, fusion with
+ | C_12_34, (F234|F243|F134|F143|F421|F321|F412|F312)
+ | C_13_42, (F324|F342|F124|F142|F431|F231|F413|F213)
+ | C_14_23, (F423|F432|F123|F132|F341|F241|F314|F214) ->
+ printf "@[(%s%s%s+%s)*g_dim8g3_t_2(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf1 p1 wf2 p2 wf3 p3
+ | C_12_34, (F324|F314|F423|F413|F142|F132|F241|F231)
+ | C_13_42, (F234|F214|F432|F412|F143|F123|F341|F321)
+ | C_14_23, (F243|F213|F342|F312|F134|F124|F431|F421) ->
+ printf "@[(%s%s%s+%s)*g_dim8g3_t_2(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf2 p2 wf1 p1 wf3 p3
+ | C_12_34, (F342|F341|F432|F431|F124|F123|F214|F213)
+ | C_13_42, (F243|F241|F423|F421|F134|F132|F314|F312)
+ | C_14_23, (F234|F231|F324|F321|F143|F142|F413|F412) ->
+ printf "@[(%s%s%s+%s)*g_dim8g3_t_2(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf3 p3 wf1 p1 wf2 p2
+
+ let print_vector4_km_t_rsi c pa pb pc wf1 p1 wf2 p2 wf3 p3 fusion (coeff, contraction) =
+ match contraction, fusion with
+ | C_12_34, (F234|F243|F134|F143|F421|F321|F412|F312)
+ | C_13_42, (F324|F342|F124|F142|F431|F231|F413|F213)
+ | C_14_23, (F423|F432|F123|F132|F341|F241|F314|F214) ->
+ printf "@[(%s%s%s+%s)*g_dim8g3_t_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf1 p1 wf2 p2 wf3 p3
+ | C_12_34, (F324|F314|F423|F413|F142|F132|F241|F231)
+ | C_13_42, (F234|F214|F432|F412|F143|F123|F341|F321)
+ | C_14_23, (F243|F213|F342|F312|F134|F124|F431|F421) ->
+ printf "@[(%s%s%s+%s)*g_dim8g3_t_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))*((%s+%s)*(%s+%s)/((%s+%s)*(%s+%s)))@]"
+ (format_coeff coeff) c pa pb wf2 p2 wf1 p1 wf3 p3 pa pb pa pb pb pc pb pc
+ | C_12_34, (F342|F341|F432|F431|F124|F123|F214|F213)
+ | C_13_42, (F243|F241|F423|F421|F134|F132|F314|F312)
+ | C_14_23, (F234|F231|F324|F321|F143|F142|F413|F412) ->
+ printf "@[(%s%s%s+%s)*g_dim8g3_t_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))*((%s+%s)*(%s+%s)/((%s+%s)*(%s+%s)))@]"
+ (format_coeff coeff) c pa pb wf3 p3 wf1 p1 wf2 p2 pa pb pa pb pa pc pa pc
+
+ let print_vector4_km_m_0 c pa pb wf1 p1 wf2 p2 wf3 p3 fusion (coeff, contraction) =
+ match contraction, fusion with
+ | C_12_34, (F234|F243|F134|F143|F421|F321|F412|F312)
+ | C_13_42, (F324|F342|F124|F142|F431|F231|F413|F213)
+ | C_14_23, (F423|F432|F123|F132|F341|F241|F314|F214) ->
+ if (String.contains c 'w' || String.contains c '4') then
+ printf "@[(%s%s%s+%s)*g_dim8g3_m_0(cmplx(1,kind=default),cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf1 p1 wf2 p2 wf3 p3
+ else
+ printf "@[((%s%s%s+%s))*g_dim8g3_m_0(cmplx(costhw**(-2),kind=default),cmplx(costhw**2,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf1 p1 wf2 p2 wf3 p3
+ | C_12_34, (F324|F314|F423|F413|F142|F132|F241|F231)
+ | C_13_42, (F234|F214|F432|F412|F143|F123|F341|F321)
+ | C_14_23, (F243|F213|F342|F312|F134|F124|F431|F421) ->
+ if (String.contains c 'w' || String.contains c '4') then
+ printf "@[(%s%s%s+%s)*g_dim8g3_m_0(cmplx(1,kind=default),cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf2 p2 wf1 p1 wf3 p3
+ else
+ printf "@[(%s%s%s+%s)*g_dim8g3_m_0(cmplx(costhw**(-2),kind=default),cmplx(costhw**2,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf2 p2 wf1 p1 wf3 p3
+ | C_12_34, (F342|F341|F432|F431|F124|F123|F214|F213)
+ | C_13_42, (F243|F241|F423|F421|F134|F132|F314|F312)
+ | C_14_23, (F234|F231|F324|F321|F143|F142|F413|F412) ->
+ if (String.contains c 'w' || String.contains c '4') then
+ printf "@[(%s%s%s+%s)*g_dim8g3_m_0(cmplx(1,kind=default),cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf3 p3 wf1 p1 wf2 p2
+ else
+ printf "@[(%s%s%s+%s)*g_dim8g3_m_0(cmplx(costhw**(-2),kind=default),cmplx(costhw**2,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf3 p3 wf1 p1 wf2 p2
+
+ let print_vector4_km_m_1 c pa pb wf1 p1 wf2 p2 wf3 p3 fusion (coeff, contraction) =
+ match contraction, fusion with
+ | C_12_34, (F234|F243|F134|F143|F421|F321|F412|F312)
+ | C_13_42, (F324|F342|F124|F142|F431|F231|F413|F213)
+ | C_14_23, (F423|F432|F123|F132|F341|F241|F314|F214) ->
+ if (String.contains c 'w' || String.contains c '4') then
+ printf "@[(%s%s%s+%s)*g_dim8g3_m_1(cmplx(1,kind=default),cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf1 p1 wf2 p2 wf3 p3
+ else
+ printf "@[(%s%s%s+%s)*g_dim8g3_m_1(cmplx(costhw**(-2),kind=default),cmplx(costhw**2,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf1 p1 wf2 p2 wf3 p3
+ | C_12_34, (F324|F314|F423|F413|F142|F132|F241|F231)
+ | C_13_42, (F234|F214|F432|F412|F143|F123|F341|F321)
+ | C_14_23, (F243|F213|F342|F312|F134|F124|F431|F421) ->
+ if (String.contains c 'w' || String.contains c '4') then
+ printf "@[(%s%s%s+%s)*g_dim8g3_m_1(cmplx(1,kind=default),cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf2 p2 wf1 p1 wf3 p3
+ else
+ printf "@[(%s%s%s+%s)*g_dim8g3_m_1(cmplx(costhw**(-2),kind=default),cmplx(costhw**2,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf2 p2 wf1 p1 wf3 p3
+ | C_12_34, (F342|F341|F432|F431|F124|F123|F214|F213)
+ | C_13_42, (F243|F241|F423|F421|F134|F132|F314|F312)
+ | C_14_23, (F234|F231|F324|F321|F143|F142|F413|F412) ->
+ if (String.contains c 'w' || String.contains c '4') then
+ printf "@[(%s%s%s+%s)*g_dim8g3_m_1(cmplx(1,kind=default),cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf3 p3 wf1 p1 wf2 p2
+ else
+ printf "@[(%s%s%s+%s)*g_dim8g3_m_1(cmplx(costhw**(-2),kind=default),cmplx(costhw**2,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf3 p3 wf1 p1 wf2 p2
+
+ let print_vector4_km_m_7 c pa pb wf1 p1 wf2 p2 wf3 p3 fusion (coeff, contraction) =
+ match contraction, fusion with
+ | C_12_34, (F234|F243|F134|F143|F421|F321|F412|F312)
+ | C_13_42, (F324|F342|F124|F142|F431|F231|F413|F213)
+ | C_14_23, (F423|F432|F123|F132|F341|F241|F314|F214) ->
+ if (String.contains c 'w' || String.contains c '4') then
+ printf "@[(%s%s%s+%s)*@ g_dim8g3_m_7(cmplx(1,kind=default),cmplx(1,kind=default),cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf1 p1 wf2 p2 wf3 p3
+ else
+ printf "@[(%s%s%s+%s)*@ g_dim8g3_m_7(cmplx(costhw**(-2),kind=default),cmplx(1,kind=default),cmplx(costhw**2,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf1 p1 wf2 p2 wf3 p3
+ | C_12_34, (F324|F314|F423|F413|F142|F132|F241|F231)
+ | C_13_42, (F234|F214|F432|F412|F143|F123|F341|F321)
+ | C_14_23, (F243|F213|F342|F312|F134|F124|F431|F421) ->
+ if (String.contains c 'w' || String.contains c '4') then
+ printf "@[(%s%s%s+%s)*@ g_dim8g3_m_7(cmplx(1,kind=default),cmplx(1,kind=default),cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf2 p2 wf1 p1 wf3 p3
+ else
+ printf "@[(%s%s%s+%s)*@ g_dim8g3_m_7(cmplx(costhw**(-2),kind=default),cmplx(1,kind=default),cmplx(costhw**2,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf2 p2 wf1 p1 wf3 p3
+ | C_12_34, (F342|F341|F432|F431|F124|F123|F214|F213)
+ | C_13_42, (F243|F241|F423|F421|F134|F132|F314|F312)
+ | C_14_23, (F234|F231|F324|F321|F143|F142|F413|F412) ->
+ if (String.contains c 'w' || String.contains c '4') then
+ printf "@[(%s%s%s+%s)*@ g_dim8g3_m_7(cmplx(1,kind=default),cmplx(1,kind=default),cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf3 p3 wf1 p1 wf2 p2
+ else
+ printf "@[(%s%s%s+%s)*@ g_dim8g3_m_7(cmplx(costhw**(-2),kind=default),cmplx(1,kind=default),cmplx(costhw**2,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf3 p3 wf1 p1 wf2 p2
+
+ let print_add_vector4_km c pa pb wf1 wf2 wf3 fusion (coeff, contraction) =
+ printf "@ + ";
+ print_vector4_km c pa pb wf1 wf2 wf3 fusion (coeff, contraction)
+
+ let print_dscalar4 c wf1 wf2 wf3 p1 p2 p3 p123
+ fusion (coeff, contraction) =
+ match contraction, fusion with
+ | C_12_34, (F341|F431|F342|F432|F123|F213|F124|F214)
+ | C_13_42, (F241|F421|F243|F423|F132|F312|F134|F314)
+ | C_14_23, (F231|F321|F234|F324|F142|F412|F143|F413) ->
+ printf "((%s%s)*(%s*%s)*(%s*%s)*%s*%s*%s)"
+ (format_coeff coeff) c p1 p2 p3 p123 wf1 wf2 wf3
+ | C_12_34, (F134|F143|F234|F243|F312|F321|F412|F421)
+ | C_13_42, (F124|F142|F324|F342|F213|F231|F413|F431)
+ | C_14_23, (F123|F132|F423|F432|F214|F241|F314|F341) ->
+ printf "((%s%s)*(%s*%s)*(%s*%s)*%s*%s*%s)"
+ (format_coeff coeff) c p2 p3 p1 p123 wf1 wf2 wf3
+ | C_12_34, (F314|F413|F324|F423|F132|F231|F142|F241)
+ | C_13_42, (F214|F412|F234|F432|F123|F321|F143|F341)
+ | C_14_23, (F213|F312|F243|F342|F124|F421|F134|F431) ->
+ printf "((%s%s)*(%s*%s)*(%s*%s)*%s*%s*%s)"
+ (format_coeff coeff) c p1 p3 p2 p123 wf1 wf2 wf3
+
+ let print_add_dscalar4 c wf1 wf2 wf3 p1 p2 p3 p123
+ fusion (coeff, contraction) =
+ printf "@ + ";
+ print_dscalar4 c wf1 wf2 wf3 p1 p2 p3 p123 fusion (coeff, contraction)
+
+ let print_dscalar2_vector2 c wf1 wf2 wf3 p1 p2 p3 p123 fusion (coeff, contraction) =
+ match contraction, fusion with
+ | C_12_34, (F123|F213|F124|F214) ->
+ printf "(%s%s)*(%s*%s)*(%s*%s)*%s"
+ (format_coeff coeff) c p1 p2 wf1 wf2 wf3
+ | C_12_34, (F134|F143|F234|F243) ->
+ printf "(%s%s)*(%s*%s)*(%s*%s)*%s"
+ (format_coeff coeff) c p1 p123 wf2 wf3 wf1
+ | C_12_34, (F132|F231|F142|F241) ->
+ printf "(%s%s)*(%s*%s)*(%s*%s)*%s"
+ (format_coeff coeff) c p1 p3 wf1 wf3 wf2
+ | C_12_34, (F312|F321|F412|F421) ->
+ printf "(%s%s)*(%s*%s)*(%s*%s)*%s"
+ (format_coeff coeff) c p2 p3 wf2 wf3 wf1
+ | C_12_34, (F314|F413|F324|F423) ->
+ printf "(%s%s)*(%s*%s)*(%s*%s)*%s"
+ (format_coeff coeff) c p2 p123 wf1 wf3 wf2
+ | C_12_34, (F341|F431|F342|F432) ->
+ printf "(%s%s)*(%s*%s)*(%s*%s)*%s"
+ (format_coeff coeff) c p3 p123 wf1 wf2 wf3
+ | C_13_42, (F123|F214)
+ | C_14_23, (F124|F213) ->
+ printf "((%s%s)*(%s*%s*%s)*%s*%s)"
+ (format_coeff coeff) c wf1 p1 wf3 wf2 p2
+ | C_13_42, (F124|F213)
+ | C_14_23, (F123|F214) ->
+ printf "((%s%s)*(%s*%s*%s)*%s*%s)"
+ (format_coeff coeff) c wf2 p2 wf3 wf1 p1
+ | C_13_42, (F132|F241)
+ | C_14_23, (F142|F231) ->
+ printf "((%s%s)*(%s*%s*%s)*%s*%s)"
+ (format_coeff coeff) c wf1 p1 wf2 wf3 p3
+ | C_13_42, (F142|F231)
+ | C_14_23, (F132|F241) ->
+ printf "((%s%s)*(%s*%s*%s)*%s*%s)"
+ (format_coeff coeff) c wf3 p3 wf2 wf1 p1
+ | C_13_42, (F312|F421)
+ | C_14_23, (F412|F321) ->
+ printf "((%s%s)*(%s*%s*%s)*%s*%s)"
+ (format_coeff coeff) c wf2 p2 wf1 wf3 p3
+ | C_13_42, (F321|F412)
+ | C_14_23, (F421|F312) ->
+ printf "((%s%s)*(%s*%s*%s)*%s*%s)"
+ (format_coeff coeff) c wf3 p3 wf1 wf2 p2
+ | C_13_42, (F134|F243)
+ | C_14_23, (F143|F234) ->
+ printf "((%s%s)*(%s*%s)*(%s*%s*%s))"
+ (format_coeff coeff) c wf3 p123 wf1 p1 wf2
+ | C_13_42, (F143|F234)
+ | C_14_23, (F134|F243) ->
+ printf "((%s%s)*(%s*%s)*(%s*%s*%s))"
+ (format_coeff coeff) c wf2 p123 wf1 p1 wf3
+ | C_13_42, (F314|F423)
+ | C_14_23, (F413|F324) ->
+ printf "((%s%s)*(%s*%s)*(%s*%s*%s))"
+ (format_coeff coeff) c wf3 p123 wf2 p2 wf1
+ | C_13_42, (F324|F413)
+ | C_14_23, (F423|F314) ->
+ printf "((%s%s)*(%s*%s)*(%s*%s*%s))"
+ (format_coeff coeff) c wf1 p123 wf2 p2 wf3
+ | C_13_42, (F341|F432)
+ | C_14_23, (F431|F342) ->
+ printf "((%s%s)*(%s*%s)*(%s*%s*%s))"
+ (format_coeff coeff) c wf2 p123 wf3 p3 wf1
+ | C_13_42, (F342|F431)
+ | C_14_23, (F432|F341) ->
+ printf "((%s%s)*(%s*%s)*(%s*%s*%s))"
+ (format_coeff coeff) c wf1 p123 wf3 p3 wf2
+
+ let print_add_dscalar2_vector2 c wf1 wf2 wf3 p1 p2 p3 p123
+ fusion (coeff, contraction) =
+ printf "@ + ";
+ print_dscalar2_vector2 c wf1 wf2 wf3 p1 p2 p3 p123
+ fusion (coeff, contraction)
+
+ let print_dscalar2_vector2_km c pa pb wf1 wf2 wf3 p1 p2 p3 p123 fusion (coeff, contraction) =
+ match contraction, fusion with
+ | C_12_34, (F123|F213|F124|F214) ->
+ printf "(%s%s%s+%s))*(%s*%s)*(%s*%s)*%s"
+ (format_coeff coeff) c pa pb p1 p2 wf1 wf2 wf3
+ | C_12_34, (F134|F143|F234|F243) ->
+ printf "(%s%s%s+%s))*(%s*%s)*(%s*%s)*%s"
+ (format_coeff coeff) c pa pb p1 p123 wf2 wf3 wf1
+ | C_12_34, (F132|F231|F142|F241) ->
+ printf "(%s%s%s+%s))*(%s*%s)*(%s*%s)*%s"
+ (format_coeff coeff) c pa pb p1 p3 wf1 wf3 wf2
+ | C_12_34, (F312|F321|F412|F421) ->
+ printf "(%s%s%s+%s))*(%s*%s)*(%s*%s)*%s"
+ (format_coeff coeff) c pa pb p2 p3 wf2 wf3 wf1
+ | C_12_34, (F314|F413|F324|F423) ->
+ printf "(%s%s%s+%s))*(%s*%s)*(%s*%s)*%s"
+ (format_coeff coeff) c pa pb p2 p123 wf1 wf3 wf2
+ | C_12_34, (F341|F431|F342|F432) ->
+ printf "(%s%s%s+%s))*(%s*%s)*(%s*%s)*%s"
+ (format_coeff coeff) c pa pb p3 p123 wf1 wf2 wf3
+ | C_13_42, (F123|F214)
+ | C_14_23, (F124|F213) ->
+ printf "((%s%s%s+%s))*(%s*%s*%s)*%s*%s)"
+ (format_coeff coeff) c pa pb wf1 p1 wf3 wf2 p2
+ | C_13_42, (F124|F213)
+ | C_14_23, (F123|F214) ->
+ printf "((%s%s%s+%s))*(%s*%s*%s)*%s*%s)"
+ (format_coeff coeff) c pa pb wf2 p2 wf3 wf1 p1
+ | C_13_42, (F132|F241)
+ | C_14_23, (F142|F231) ->
+ printf "((%s%s%s+%s))*(%s*%s*%s)*%s*%s)"
+ (format_coeff coeff) c pa pb wf1 p1 wf2 wf3 p3
+ | C_13_42, (F142|F231)
+ | C_14_23, (F132|F241) ->
+ printf "((%s%s%s+%s))*(%s*%s*%s)*%s*%s)"
+ (format_coeff coeff) c pa pb wf3 p3 wf2 wf1 p1
+ | C_13_42, (F312|F421)
+ | C_14_23, (F412|F321) ->
+ printf "((%s%s%s+%s))*(%s*%s*%s)*%s*%s)"
+ (format_coeff coeff) c pa pb wf2 p2 wf1 wf3 p3
+ | C_13_42, (F321|F412)
+ | C_14_23, (F421|F312) ->
+ printf "((%s%s%s+%s))*(%s*%s*%s)*%s*%s)"
+ (format_coeff coeff) c pa pb wf3 p3 wf1 wf2 p2
+ | C_13_42, (F134|F243)
+ | C_14_23, (F143|F234) ->
+ printf "((%s%s%s+%s))*(%s*%s)*(%s*%s*%s))"
+ (format_coeff coeff) c pa pb wf3 p123 wf1 p1 wf2
+ | C_13_42, (F143|F234)
+ | C_14_23, (F134|F243) ->
+ printf "((%s%s%s+%s))*(%s*%s)*(%s*%s*%s))"
+ (format_coeff coeff) c pa pb wf2 p123 wf1 p1 wf3
+ | C_13_42, (F314|F423)
+ | C_14_23, (F413|F324) ->
+ printf "((%s%s%s+%s))*(%s*%s)*(%s*%s*%s))"
+ (format_coeff coeff) c pa pb wf3 p123 wf2 p2 wf1
+ | C_13_42, (F324|F413)
+ | C_14_23, (F423|F314) ->
+ printf "((%s%s%s+%s))*(%s*%s)*(%s*%s*%s))"
+ (format_coeff coeff) c pa pb wf1 p123 wf2 p2 wf3
+ | C_13_42, (F341|F432)
+ | C_14_23, (F431|F342) ->
+ printf "((%s%s%s+%s))*(%s*%s)*(%s*%s*%s))"
+ (format_coeff coeff) c pa pb wf2 p123 wf3 p3 wf1
+ | C_13_42, (F342|F431)
+ | C_14_23, (F432|F341) ->
+ printf "((%s%s%s+%s))*(%s*%s)*(%s*%s*%s))"
+ (format_coeff coeff) c pa pb wf1 p123 wf3 p3 wf2
+
+ let print_add_dscalar2_vector2_km c pa pb wf1 wf2 wf3 p1 p2 p3 p123 fusion (coeff, contraction) =
+ printf "@ + ";
+ print_dscalar2_vector2_km c pa pb wf1 wf2 wf3 p1 p2 p3 p123 fusion (coeff, contraction)
+
+ let print_dscalar2_vector2_m_0_km c pa pb wf1 wf2 wf3 p1 p2 p3 fusion (coeff, contraction) =
+ match contraction, fusion with
+ | C_12_34, (F123|F213|F124|F214) ->
+ printf "@[((%s%s%s+%s))*v_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf1 p1 wf2 p2 wf3 p3
+ | C_12_34, (F134|F143|F234|F243) ->
+ printf "@[((%s%s%s+%s))*phi_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf1 p1 wf2 p2 wf3 p3
+ | C_12_34, (F132|F231|F142|F241) ->
+ printf "@[((%s%s%s+%s))*v_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf1 p1 wf3 p3 wf2 p2
+ | C_12_34, (F312|F321|F412|F421) ->
+ printf "@[((%s%s%s+%s))*v_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf3 p3 wf2 p2 wf1 p1
+ | C_12_34, (F314|F413|F324|F423) ->
+ printf "@[((%s%s%s+%s))*phi_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf2 p2 wf1 p1 wf3 p3
+ | C_12_34, (F341|F431|F342|F432) ->
+ printf "@[((%s%s%s+%s))*phi_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf3 p3 wf2 p2 wf1 p1
+ | C_13_42, (F123|F214)
+ | C_14_23, (F124|F213) ->
+ printf "@[((%s%s%s+%s))*v_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf1 p1 wf2 p3 wf3 p2
+ | C_13_42, (F124|F213)
+ | C_14_23, (F123|F214) ->
+ printf "@[((%s%s%s+%s))*v_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf2 p2 wf1 p3 wf3 p1
+ | C_13_42, (F132|F241)
+ | C_14_23, (F142|F231) ->
+ printf "@[((%s%s%s+%s))*v_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf1 p1 wf3 p2 wf2 p3
+ | C_13_42, (F142|F231)
+ | C_14_23, (F132|F241) ->
+ printf "@[((%s%s%s+%s))*v_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf3 p3 wf1 p2 wf2 p1
+ | C_13_42, (F312|F421)
+ | C_14_23, (F412|F321) ->
+ printf "@[((%s%s%s+%s))*v_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf2 p2 wf3 p1 wf1 p3
+ | C_13_42, (F321|F412)
+ | C_14_23, (F421|F312) ->
+ printf "@[((%s%s%s+%s))*v_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf3 p3 wf2 p1 wf1 p2
+ | C_13_42, (F134|F243)
+ | C_14_23, (F143|F234) ->
+ printf "@[((%s%s%s+%s))*phi_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf1 p3 wf3 p1 wf2 p2
+ | C_13_42, (F143|F234)
+ | C_14_23, (F134|F243) ->
+ printf "@[((%s%s%s+%s))*phi_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf1 p2 wf2 p1 wf3 p3
+ | C_13_42, (F314|F423)
+ | C_14_23, (F413|F324) ->
+ printf "@[((%s%s%s+%s))*phi_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf2 p3 wf3 p2 wf1 p1
+ | C_13_42, (F324|F413)
+ | C_14_23, (F423|F314) ->
+ printf "@[((%s%s%s+%s))*phi_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf2 p1 wf1 p2 wf3 p3
+ | C_13_42, (F341|F432)
+ | C_14_23, (F431|F342) ->
+ printf "@[((%s%s%s+%s))*phi_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf3 p2 wf2 p3 wf1 p1
+ | C_13_42, (F342|F431)
+ | C_14_23, (F432|F341) ->
+ printf "@[((%s%s%s+%s))*phi_phi2v_m_0(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf3 p1 wf1 p3 wf2 p2
+
+ let print_add_dscalar2_vector2_m_0_km c pa pb wf1 wf2 wf3 p1 p2 p3 fusion (coeff, contraction) =
+ printf "@ + ";
+ print_dscalar2_vector2_m_0_km c pa pb wf1 wf2 wf3 p1 p2 p3 fusion (coeff, contraction)
+
+ let print_dscalar2_vector2_m_1_km c pa pb wf1 wf2 wf3 p1 p2 p3 fusion (coeff, contraction) =
+ match contraction, fusion with
+ | C_12_34, (F123|F213|F124|F214) ->
+ printf "@[((%s%s%s+%s))*v_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf1 p1 wf2 p2 wf3 p3
+ | C_12_34, (F134|F143|F234|F243) ->
+ printf "@[((%s%s%s+%s))*phi_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf1 p1 wf2 p2 wf3 p3
+ | C_12_34, (F132|F231|F142|F241) ->
+ printf "@[((%s%s%s+%s))*v_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf1 p1 wf3 p3 wf2 p2
+ | C_12_34, (F312|F321|F412|F421) ->
+ printf "@[((%s%s%s+%s))*v_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf3 p3 wf2 p2 wf1 p1
+ | C_12_34, (F314|F413|F324|F423) ->
+ printf "@[((%s%s%s+%s))*phi_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf2 p2 wf1 p1 wf3 p3
+ | C_12_34, (F341|F431|F342|F432) ->
+ printf "@[((%s%s%s+%s))*phi_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf3 p3 wf2 p2 wf1 p1
+ | C_13_42, (F123|F214)
+ | C_14_23, (F124|F213) ->
+ printf "@[((%s%s%s+%s))*v_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf1 p1 wf2 p3 wf3 p2
+ | C_13_42, (F124|F213)
+ | C_14_23, (F123|F214) ->
+ printf "@[((%s%s%s+%s))*v_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf2 p2 wf1 p3 wf3 p1
+ | C_13_42, (F132|F241)
+ | C_14_23, (F142|F231) ->
+ printf "@[((%s%s%s+%s))*v_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf1 p1 wf3 p2 wf2 p3
+ | C_13_42, (F142|F231)
+ | C_14_23, (F132|F241) ->
+ printf "@[((%s%s%s+%s))*v_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf3 p3 wf1 p2 wf2 p1
+ | C_13_42, (F312|F421)
+ | C_14_23, (F412|F321) ->
+ printf "@[((%s%s%s+%s))*v_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf2 p2 wf3 p1 wf1 p3
+ | C_13_42, (F321|F412)
+ | C_14_23, (F421|F312) ->
+ printf "@[((%s%s%s+%s))*v_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf3 p3 wf2 p1 wf1 p2
+ | C_13_42, (F134|F243)
+ | C_14_23, (F143|F234) ->
+ printf "@[((%s%s%s+%s))*phi_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf1 p3 wf3 p1 wf2 p2
+ | C_13_42, (F143|F234)
+ | C_14_23, (F134|F243) ->
+ printf "@[((%s%s%s+%s))*phi_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf1 p2 wf2 p1 wf3 p3
+ | C_13_42, (F314|F423)
+ | C_14_23, (F413|F324) ->
+ printf "@[((%s%s%s+%s))*phi_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf2 p3 wf3 p2 wf1 p1
+ | C_13_42, (F324|F413)
+ | C_14_23, (F423|F314) ->
+ printf "@[((%s%s%s+%s))*phi_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf2 p1 wf1 p2 wf3 p3
+ | C_13_42, (F341|F432)
+ | C_14_23, (F431|F342) ->
+ printf "@[((%s%s%s+%s))*phi_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf3 p2 wf2 p3 wf1 p1
+ | C_13_42, (F342|F431)
+ | C_14_23, (F432|F341) ->
+ printf "@[((%s%s%s+%s))*phi_phi2v_m_1(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf3 p1 wf1 p3 wf2 p2
+
+ let print_add_dscalar2_vector2_m_1_km c pa pb wf1 wf2 wf3 p1 p2 p3 fusion (coeff, contraction) =
+ printf "@ + ";
+ print_dscalar2_vector2_m_1_km c pa pb wf1 wf2 wf3 p1 p2 p3 fusion (coeff, contraction)
+
+ let print_dscalar2_vector2_m_7_km c pa pb wf1 wf2 wf3 p1 p2 p3 fusion (coeff, contraction) =
+ match contraction, fusion with
+ | C_12_34, (F123|F213|F124|F214) ->
+ printf "@[((%s%s%s+%s))*v_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf1 p1 wf2 p2 wf3 p3
+ | C_12_34, (F134|F143|F234|F243) ->
+ printf "@[((%s%s%s+%s))*phi_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf1 p1 wf2 p2 wf3 p3
+ | C_12_34, (F132|F231|F142|F241) ->
+ printf "@[((%s%s%s+%s))*v_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf1 p1 wf3 p3 wf2 p2
+ | C_12_34, (F312|F321|F412|F421) ->
+ printf "@[((%s%s%s+%s))*v_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf3 p3 wf2 p2 wf1 p1
+ | C_12_34, (F314|F413|F324|F423) ->
+ printf "@[((%s%s%s+%s))*phi_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf2 p2 wf1 p1 wf3 p3
+ | C_12_34, (F341|F431|F342|F432) ->
+ printf "@[((%s%s%s+%s))*phi_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf3 p3 wf2 p2 wf1 p1
+ | C_13_42, (F123|F214)
+ | C_14_23, (F124|F213) ->
+ printf "@[((%s%s%s+%s))*v_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf1 p1 wf2 p3 wf3 p2
+ | C_13_42, (F124|F213)
+ | C_14_23, (F123|F214) ->
+ printf "@[((%s%s%s+%s))*v_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf2 p2 wf1 p3 wf3 p1
+ | C_13_42, (F132|F241)
+ | C_14_23, (F142|F231) ->
+ printf "@[((%s%s%s+%s))*v_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf1 p1 wf3 p2 wf2 p3
+ | C_13_42, (F142|F231)
+ | C_14_23, (F132|F241) ->
+ printf "@[((%s%s%s+%s))*v_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf3 p3 wf1 p2 wf2 p1
+ | C_13_42, (F312|F421)
+ | C_14_23, (F412|F321) ->
+ printf "@[((%s%s%s+%s))*v_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf2 p2 wf3 p1 wf1 p3
+ | C_13_42, (F321|F412)
+ | C_14_23, (F421|F312) ->
+ printf "@[((%s%s%s+%s))*v_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf3 p3 wf2 p1 wf1 p2
+ | C_13_42, (F134|F243)
+ | C_14_23, (F143|F234) ->
+ printf "@[((%s%s%s+%s))*phi_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf1 p3 wf3 p1 wf2 p2
+ | C_13_42, (F143|F234)
+ | C_14_23, (F134|F243) ->
+ printf "@[((%s%s%s+%s))*phi_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf1 p2 wf2 p1 wf3 p3
+ | C_13_42, (F314|F423)
+ | C_14_23, (F413|F324) ->
+ printf "@[((%s%s%s+%s))*phi_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf2 p3 wf3 p2 wf1 p1
+ | C_13_42, (F324|F413)
+ | C_14_23, (F423|F314) ->
+ printf "@[((%s%s%s+%s))*phi_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf2 p1 wf1 p2 wf3 p3
+ | C_13_42, (F341|F432)
+ | C_14_23, (F431|F342) ->
+ printf "@[((%s%s%s+%s))*phi_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf3 p2 wf2 p3 wf1 p1
+ | C_13_42, (F342|F431)
+ | C_14_23, (F432|F341) ->
+ printf "@[((%s%s%s+%s))*phi_phi2v_m_7(cmplx(1,kind=default),@ %s,%s,%s,%s,%s,%s))@]"
+ (format_coeff coeff) c pa pb wf3 p1 wf1 p3 wf2 p2
+
+ let print_add_dscalar2_vector2_m_7_km c pa pb wf1 wf2 wf3 p1 p2 p3 fusion (coeff, contraction) =
+ printf "@ + ";
+ print_dscalar2_vector2_m_7_km c pa pb wf1 wf2 wf3 p1 p2 p3 fusion (coeff, contraction)
+
+ let print_dscalar4_km c pa pb wf1 wf2 wf3 p1 p2 p3 p123 fusion (coeff, contraction) =
+ match contraction, fusion with
+ | C_12_34, (F341|F431|F342|F432|F123|F213|F124|F214)
+ | C_13_42, (F241|F421|F243|F423|F132|F312|F134|F314)
+ | C_14_23, (F231|F321|F234|F324|F142|F412|F143|F413) ->
+ printf "((%s%s%s+%s))*(%s*%s)*(%s*%s)*%s*%s*%s)"
+ (format_coeff coeff) c pa pb p1 p2 p3 p123 wf1 wf2 wf3
+ | C_12_34, (F134|F143|F234|F243|F312|F321|F412|F421)
+ | C_13_42, (F124|F142|F324|F342|F213|F231|F413|F431)
+ | C_14_23, (F123|F132|F423|F432|F214|F241|F314|F341) ->
+ printf "((%s%s%s+%s))*(%s*%s)*(%s*%s)*%s*%s*%s)"
+ (format_coeff coeff) c pa pb p2 p3 p1 p123 wf1 wf2 wf3
+ | C_12_34, (F314|F413|F324|F423|F132|F231|F142|F241)
+ | C_13_42, (F214|F412|F234|F432|F123|F321|F143|F341)
+ | C_14_23, (F213|F312|F243|F342|F124|F421|F134|F431) ->
+ printf "((%s%s%s+%s))*(%s*%s)*(%s*%s)*%s*%s*%s)"
+ (format_coeff coeff) c pa pb p1 p3 p2 p123 wf1 wf2 wf3
+
+ let print_add_dscalar4_km c pa pb wf1 wf2 wf3 p1 p2 p3 p123 fusion (coeff, contraction) =
+ printf "@ + ";
+ print_dscalar4_km c pa pb wf1 wf2 wf3 p1 p2 p3 p123 fusion (coeff, contraction)
+
+ let print_current_V3 format_wf format_p amplitude dictionary rhs vertex fusion constant =
+ let ch1, ch2 = children2 rhs in
+ let wf1 = format_wf amplitude dictionary ch1
+ and wf2 = format_wf amplitude dictionary ch2
+ and p1 = format_p ch1
+ and p2 = format_p ch2
+ and m1 = SCM.mass_symbol (F.flavor ch1)
+ and m2 = SCM.mass_symbol (F.flavor ch2) in
+ let c = SCM.constant_symbol constant in
+ printf "@, %s " (if (F.sign rhs) < 0 then "-" else "+");
+ begin match vertex with
+
+ (* Fermionic currents $\bar\psi\fmslash{A}\psi$ and $\bar\psi\phi\psi$
+ are handled by the [Fermions] module, since they depend on the
+ choice of Feynman rules: Dirac or Majorana. *)
+
+ | FBF (coeff, fb, b, f) ->
+ begin match coeff, fb, b, f with
+ | _, _, (VLRM|SPM|VAM|VA3M|TVA|TVAM|TLR|TLRM|TRL|TRLM), _ ->
+ let p12 = Printf.sprintf "(-%s-%s)" p1 p2 in
+ Fermions.print_current_mom (coeff, fb, b, f) c wf1 wf2 p1 p2
+ p12 fusion
+ | _, _, _, _ ->
+ Fermions.print_current (coeff, fb, b, f) c wf1 wf2 fusion
+ end
+ | PBP (coeff, f1, b, f2) ->
+ Fermions.print_current_p (coeff, f1, b, f2) c wf1 wf2 fusion
+ | BBB (coeff, fb1, b, fb2) ->
+ Fermions.print_current_b (coeff, fb1, b, fb2) c wf1 wf2 fusion
+ | GBG (coeff, fb, b, f) ->
+ let p12 = Printf.sprintf "(-%s-%s)" p1 p2 in
+ Fermions.print_current_g (coeff, fb, b, f) c wf1 wf2 p1 p2 p12 fusion
+
+ (* Table~\ref{tab:dim4-bosons} is a bit misleading, since if includes
+ totally antisymmetric structure constants. The space-time part alone
+ is also totally antisymmetric: *)
+
+ | Gauge_Gauge_Gauge coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | (F23|F31|F12) -> printf "g_gg(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | (F32|F13|F21) -> printf "g_gg(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ end
+
+ | I_Gauge_Gauge_Gauge coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | (F23|F31|F12) -> printf "g_gg((0,1)*(%s),%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | (F32|F13|F21) -> printf "g_gg((0,1)*(%s),%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ end
+
+ (* In [Aux_Gauge_Gauge], we can not rely on antisymmetry alone, because of the
+ different Lorentz representations of the auxialiary and the gauge field.
+ Instead we have to provide the sign in
+ \begin{equation}
+ (V_2 \wedge V_3) \cdot T_1 =
+ \begin{cases}
+ V_2 \cdot (T_1 \cdot V_3) = - V_2 \cdot (V_3 \cdot T_1) & \\
+ V_3 \cdot (V_2 \cdot T_1) = - V_3 \cdot (T_1 \cdot V_2) &
+ \end{cases}
+ \end{equation}
+ ourselves. Alternatively, one could provide \verb+g_xg+ mirroring
+ \verb+g_gx+. *)
+
+ | Aux_Gauge_Gauge coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F23 -> printf "x_gg(%s,%s,%s)" c wf1 wf2
+ | F32 -> printf "x_gg(%s,%s,%s)" c wf2 wf1
+ | F12 -> printf "g_gx(%s,%s,%s)" c wf2 wf1
+ | F21 -> printf "g_gx(%s,%s,%s)" c wf1 wf2
+ | F13 -> printf "(-1)*g_gx(%s,%s,%s)" c wf2 wf1
+ | F31 -> printf "(-1)*g_gx(%s,%s,%s)" c wf1 wf2
+ end
+
+ (* These cases are symmetric and we just have to juxtapose the correct fields
+ and provide parentheses to minimize the number of multiplications. *)
+
+ | Scalar_Vector_Vector coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | (F23|F32) -> printf "%s*(%s*%s)" c wf1 wf2
+ | (F12|F13) -> printf "(%s*%s)*%s" c wf1 wf2
+ | (F21|F31) -> printf "(%s*%s)*%s" c wf2 wf1
+ end
+
+ | Aux_Vector_Vector coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | (F23|F32) -> printf "%s*(%s*%s)" c wf1 wf2
+ | (F12|F13) -> printf "(%s*%s)*%s" c wf1 wf2
+ | (F21|F31) -> printf "(%s*%s)*%s" c wf2 wf1
+ end
+
+ (* Even simpler: *)
+
+ | Scalar_Scalar_Scalar coeff ->
+ printf "(%s*%s*%s)" (format_coupling coeff c) wf1 wf2
+
+ | Aux_Scalar_Scalar coeff ->
+ printf "(%s*%s*%s)" (format_coupling coeff c) wf1 wf2
+
+ | Aux_Scalar_Vector coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | (F13|F31) -> printf "%s*(%s*%s)" c wf1 wf2
+ | (F23|F21) -> printf "(%s*%s)*%s" c wf1 wf2
+ | (F32|F12) -> printf "(%s*%s)*%s" c wf2 wf1
+ end
+
+ | Vector_Scalar_Scalar coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F23 -> printf "v_ss(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F32 -> printf "v_ss(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ | F12 -> printf "s_vs(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F21 -> printf "s_vs(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ | F13 -> printf "(-1)*s_vs(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F31 -> printf "(-1)*s_vs(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ end
+
+ | Graviton_Scalar_Scalar coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F12 -> printf "s_gravs(%s,%s,-(%s+%s),%s,%s,%s)" c m2 p1 p2 p2 wf1 wf2
+ | F21 -> printf "s_gravs(%s,%s,-(%s+%s),%s,%s,%s)" c m1 p1 p2 p1 wf2 wf1
+ | F13 -> printf "s_gravs(%s,%s,%s,-(%s+%s),%s,%s)" c m2 p2 p1 p2 wf1 wf2
+ | F31 -> printf "s_gravs(%s,%s,%s,-(%s+%s),%s,%s)" c m1 p1 p1 p2 wf2 wf1
+ | F23 -> printf "grav_ss(%s,%s,%s,%s,%s,%s)" c m1 p1 p2 wf1 wf2
+ | F32 -> printf "grav_ss(%s,%s,%s,%s,%s,%s)" c m1 p2 p1 wf2 wf1
+ end
+
+ (* In producing a vector in the fusion we always contract the rightmost index with the
+ vector wavefunction from [rhs]. So the first momentum is always the one of the
+ vector boson produced in the fusion, while the second one is that from the [rhs].
+ This makes the cases [F12] and [F13] as well as [F21] and [F31] equal. In principle,
+ we could have already done this for the [Graviton_Scalar_Scalar] case. *)
+
+
+ | Graviton_Vector_Vector coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | (F12|F13) -> printf "v_gravv(%s,%s,-(%s+%s),%s,%s,%s)" c m2 p1 p2 p2 wf1 wf2
+ | (F21|F31) -> printf "v_gravv(%s,%s,-(%s+%s),%s,%s,%s)" c m1 p1 p2 p1 wf2 wf1
+ | F23 -> printf "grav_vv(%s,%s,%s,%s,%s,%s)" c m1 p1 p2 wf1 wf2
+ | F32 -> printf "grav_vv(%s,%s,%s,%s,%s,%s)" c m1 p2 p1 wf2 wf1
+ end
+
+ | Graviton_Spinor_Spinor coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F23 -> printf "f_gravf(%s,%s,-(%s+%s),(-%s),%s,%s)" c m2 p1 p2 p2 wf1 wf2
+ | F32 -> printf "f_gravf(%s,%s,-(%s+%s),(-%s),%s,%s)" c m1 p1 p2 p1 wf2 wf1
+ | F12 -> printf "f_fgrav(%s,%s,%s,%s+%s,%s,%s)" c m1 p1 p1 p2 wf1 wf2
+ | F21 -> printf "f_fgrav(%s,%s,%s,%s+%s,%s,%s)" c m2 p2 p1 p2 wf2 wf1
+ | F13 -> printf "grav_ff(%s,%s,%s,(-%s),%s,%s)" c m1 p1 p2 wf1 wf2
+ | F31 -> printf "grav_ff(%s,%s,%s,(-%s),%s,%s)" c m1 p2 p1 wf2 wf1
+ end
+
+ | Dim4_Vector_Vector_Vector_T coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F23 -> printf "tkv_vv(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F32 -> printf "tkv_vv(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ | F12 -> printf "tv_kvv(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F21 -> printf "tv_kvv(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ | F13 -> printf "(-1)*tv_kvv(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F31 -> printf "(-1)*tv_kvv(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ end
+
+ | Dim4_Vector_Vector_Vector_L coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F23 -> printf "lkv_vv(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F32 -> printf "lkv_vv(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ | F12 | F13 -> printf "lv_kvv(%s,%s,%s,%s)" c wf1 p1 wf2
+ | F21 | F31 -> printf "lv_kvv(%s,%s,%s,%s)" c wf2 p2 wf1
+ end
+
+ | Dim6_Gauge_Gauge_Gauge coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F23 | F31 | F12 -> printf "kg_kgkg(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F32 | F13 | F21 -> printf "kg_kgkg(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ end
+
+ | Dim4_Vector_Vector_Vector_T5 coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F23 -> printf "t5kv_vv(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F32 -> printf "t5kv_vv(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ | F12 | F13 -> printf "t5v_kvv(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F21 | F31 -> printf "t5v_kvv(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ end
+
+ | Dim4_Vector_Vector_Vector_L5 coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F23 -> printf "l5kv_vv(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F32 -> printf "l5kv_vv(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ | F12 -> printf "l5v_kvv(%s,%s,%s,%s)" c wf1 p1 wf2
+ | F21 -> printf "l5v_kvv(%s,%s,%s,%s)" c wf2 p2 wf1
+ | F13 -> printf "(-1)*l5v_kvv(%s,%s,%s,%s)" c wf1 p1 wf2
+ | F31 -> printf "(-1)*l5v_kvv(%s,%s,%s,%s)" c wf2 p2 wf1
+ end
+
+ | Dim6_Gauge_Gauge_Gauge_5 coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F23 -> printf "kg5_kgkg(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F32 -> printf "kg5_kgkg(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ | F12 -> printf "kg_kg5kg(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F21 -> printf "kg_kg5kg(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ | F13 -> printf "(-1)*kg_kg5kg(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F31 -> printf "(-1)*kg_kg5kg(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ end
+
+ | Aux_DScalar_DScalar coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | (F23|F32) -> printf "%s*(%s*%s)*(%s*%s)" c p1 p2 wf1 wf2
+ | (F12|F13) -> printf "%s*(-((%s+%s)*%s))*(%s*%s)" c p1 p2 p2 wf1 wf2
+ | (F21|F31) -> printf "%s*(-((%s+%s)*%s))*(%s*%s)" c p1 p2 p1 wf1 wf2
+ end
+
+ | Aux_Vector_DScalar coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F23 -> printf "%s*(%s*%s)*%s" c wf1 p2 wf2
+ | F32 -> printf "%s*(%s*%s)*%s" c wf2 p1 wf1
+ | F12 -> printf "%s*(-((%s+%s)*%s))*%s" c p1 p2 wf2 wf1
+ | F21 -> printf "%s*(-((%s+%s)*%s))*%s" c p1 p2 wf1 wf2
+ | (F13|F31) -> printf "(-(%s+%s))*(%s*%s*%s)" p1 p2 c wf1 wf2
+ end
+
+ | Dim5_Scalar_Gauge2 coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | (F23|F32) ->
+ printf "(%s)*((%s*%s)*(%s*%s) - (%s*%s)*(%s*%s))" c p1 wf2 p2 wf1 p1 p2 wf2 wf1
+ | (F12|F13) ->
+ printf "(%s)*%s*((-((%s+%s)*%s))*%s - ((-(%s+%s)*%s))*%s)" c wf1 p1 p2 wf2 p2 p1 p2 p2 wf2
+ | (F21|F31) ->
+ printf "(%s)*%s*((-((%s+%s)*%s))*%s - ((-(%s+%s)*%s))*%s)" c wf2 p2 p1 wf1 p1 p1 p2 p1 wf1
+ end
+
+ | Dim5_Scalar_Gauge2_Skew coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | (F23|F32) -> printf "(- phi_vv (%s, %s, %s, %s, %s))" c p1 p2 wf1 wf2
+ | (F12|F13) -> printf "(- v_phiv (%s, %s, %s, %s, %s))" c wf1 p1 p2 wf2
+ | (F21|F31) -> printf "v_phiv (%s, %s, %s, %s, %s)" c wf2 p1 p2 wf1
+ end
+
+ | Dim5_Scalar_Vector_Vector_T coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | (F23|F32) -> printf "(%s)*(%s*%s)*(%s*%s)" c p1 wf2 p2 wf1
+ | (F12|F13) -> printf "(%s)*%s*(-((%s+%s)*%s))*%s" c wf1 p1 p2 wf2 p2
+ | (F21|F31) -> printf "(%s)*%s*(-((%s+%s)*%s))*%s" c wf2 p2 p1 wf1 p1
+ end
+
+ | Dim5_Scalar_Vector_Vector_U coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | (F23|F32) -> printf "phi_u_vv (%s, %s, %s, %s, %s)" c p1 p2 wf1 wf2
+ | (F12|F13) -> printf "v_u_phiv (%s, %s, %s, %s, %s)" c wf1 p1 p2 wf2
+ | (F21|F31) -> printf "v_u_phiv (%s, %s, %s, %s, %s)" c wf2 p2 p1 wf1
+ end
+
+ | Dim5_Scalar_Vector_Vector_TU coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F23 -> printf "(%s)*((%s*%s)*(-(%s+%s)*%s) - (-(%s+%s)*%s)*(%s*%s))"
+ c p1 wf2 p1 p2 wf1 p1 p2 p1 wf1 wf2
+ | F32 -> printf "(%s)*((%s*%s)*(-(%s+%s)*%s) - (-(%s+%s)*%s)*(%s*%s))"
+ c p2 wf1 p1 p2 wf2 p1 p2 p2 wf1 wf2
+ | F12 -> printf "(%s)*%s*((%s*%s)*%s - (%s*%s)*%s)"
+ c wf1 p1 wf2 p2 p1 p2 wf2
+ | F21 -> printf "(%s)*%s*((%s*%s)*%s - (%s*%s)*%s)"
+ c wf2 p2 wf1 p1 p1 p2 wf1
+ | F13 -> printf "(%s)*%s*((-(%s+%s)*%s)*%s - (-(%s+%s)*%s)*%s)"
+ c wf1 p1 p2 wf2 p1 p1 p2 p1 wf2
+ | F31 -> printf "(%s)*%s*((-(%s+%s)*%s)*%s - (-(%s+%s)*%s)*%s)"
+ c wf2 p1 p2 wf1 p2 p1 p2 p2 wf1
+ end
+
+ | Dim5_Scalar_Scalar2 coeff->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | (F23|F32) ->
+ printf "phi_dim5s2(%s, %s ,%s, %s, %s)" c wf1 p1 wf2 p2
+ | (F12|F13) ->
+ let p12 = Printf.sprintf "(-%s-%s)" p1 p2 in
+ printf "phi_dim5s2(%s,%s,%s,%s,%s)" c wf1 p12 wf2 p2
+ | (F21|F31) ->
+ let p12 = Printf.sprintf "(-%s-%s)" p1 p2 in
+ printf "phi_dim5s2(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p12
+ end
+
+ | Scalar_Vector_Vector_t coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | (F23|F32) -> printf "s_vv_t(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | (F12|F13) -> printf "v_sv_t(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | (F21|F31) -> printf "v_sv_t(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ end
+
+ | Dim6_Vector_Vector_Vector_T coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F23 -> printf "(%s)*(%s*%s)*(%s*%s)*(%s-%s)" c p2 wf1 p1 wf2 p1 p2
+ | F32 -> printf "(%s)*(%s*%s)*(%s*%s)*(%s-%s)" c p1 wf2 p2 wf1 p2 p1
+ | (F12|F13) ->
+ printf "(%s)*((%s+2*%s)*%s)*(-((%s+%s)*%s))*%s" c p1 p2 wf1 p1 p2 wf2 p2
+ | (F21|F31) ->
+ printf "(%s)*((-((%s+%s)*%s))*(%s+2*%s)*%s)*%s" c p2 p1 wf1 p2 p1 wf2 p1
+ end
+
+ | Tensor_2_Vector_Vector coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | (F23|F32) -> printf "t2_vv(%s,%s,%s)" c wf1 wf2
+ | (F12|F13) -> printf "v_t2v(%s,%s,%s)" c wf1 wf2
+ | (F21|F31) -> printf "v_t2v(%s,%s,%s)" c wf2 wf1
+ end
+
+ | Tensor_2_Scalar_Scalar coeff->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | (F23|F32) -> printf "t2_phi2(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | (F12|F13) -> printf "phi_t2phi(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | (F21|F31) -> printf "phi_t2phi(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ end
+
+ | Tensor_2_Vector_Vector_1 coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | (F23|F32) -> printf "t2_vv_1(%s,%s,%s)" c wf1 wf2
+ | (F12|F13) -> printf "v_t2v_1(%s,%s,%s)" c wf1 wf2
+ | (F21|F31) -> printf "v_t2v_1(%s,%s,%s)" c wf2 wf1
+ end
+
+ | Tensor_2_Vector_Vector_cf coeff->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | (F23|F32) -> printf "t2_vv_cf(%s,%s,%s)" c wf1 wf2
+ | (F12|F13) -> printf "v_t2v_cf(%s,%s,%s)" c wf1 wf2
+ | (F21|F31) -> printf "v_t2v_cf(%s,%s,%s)" c wf2 wf1
+ end
+
+ | Tensor_2_Scalar_Scalar_cf coeff->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | (F23|F32) -> printf "t2_phi2_cf(%s,%s,%s,%s, %s)" c wf1 p1 wf2 p2
+ | (F12|F13) -> printf "phi_t2phi_cf(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | (F21|F31) -> printf "phi_t2phi_cf(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ end
+
+ | Dim5_Tensor_2_Vector_Vector_1 coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | (F23|F32) -> printf "t2_vv_d5_1(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | (F12|F13) -> printf "v_t2v_d5_1(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | (F21|F31) -> printf "v_t2v_d5_1(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ end
+
+ | Tensor_2_Vector_Vector_t coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | (F23|F32) -> printf "t2_vv_t(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | (F12|F13) -> printf "v_t2v_t(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | (F21|F31) -> printf "v_t2v_t(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ end
+
+ | Dim5_Tensor_2_Vector_Vector_2 coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F23 -> printf "t2_vv_d5_2(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F32 -> printf "t2_vv_d5_2(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ | (F12|F13) -> printf "v_t2v_d5_2(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | (F21|F31) -> printf "v_t2v_d5_2(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ end
+
+ | TensorVector_Vector_Vector coeff->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | (F23|F32) -> printf "dv_vv(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | (F12|F13) -> printf "v_dvv(%s,%s,%s,%s)" c wf1 p1 wf2
+ | (F21|F31) -> printf "v_dvv(%s,%s,%s,%s)" c wf2 p2 wf1
+ end
+
+ | TensorVector_Vector_Vector_cf coeff->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | (F23|F32) -> printf "dv_vv_cf(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | (F12|F13) -> printf "v_dvv_cf(%s,%s,%s,%s)" c wf1 p1 wf2
+ | (F21|F31) -> printf "v_dvv_cf(%s,%s,%s,%s)" c wf2 p2 wf1
+ end
+
+ | TensorVector_Scalar_Scalar coeff->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | (F23|F32) -> printf "dv_phi2(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | (F12|F13) -> printf "phi_dvphi(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | (F21|F31) -> printf "phi_dvphi(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ end
+
+ | TensorVector_Scalar_Scalar_cf coeff->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | (F23|F32) -> printf "dv_phi2_cf(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | (F12|F13) -> printf "phi_dvphi_cf(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | (F21|F31) -> printf "phi_dvphi_cf(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ end
+
+ | TensorScalar_Vector_Vector coeff->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | (F23|F32) -> printf "tphi_vv(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | (F12|F13) -> printf "v_tphiv(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | (F21|F31) -> printf "v_tphiv(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ end
+
+ | TensorScalar_Vector_Vector_cf coeff->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | (F23|F32) -> printf "tphi_vv_cf(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | (F12|F13) -> printf "v_tphiv_cf(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | (F21|F31) -> printf "v_tphiv_cf(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ end
+
+ | TensorScalar_Scalar_Scalar coeff->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | (F23|F32) -> printf "tphi_ss(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | (F12|F13) -> printf "s_tphis(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | (F21|F31) -> printf "s_tphis(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ end
+
+ | TensorScalar_Scalar_Scalar_cf coeff->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | (F23|F32) -> printf "tphi_ss_cf(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | (F12|F13) -> printf "s_tphis_cf(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | (F21|F31) -> printf "s_tphis_cf(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ end
+
+ | Dim7_Tensor_2_Vector_Vector_T coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F23 -> printf "t2_vv_d7(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F32 -> printf "t2_vv_d7(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ | (F12|F13) -> printf "v_t2v_d7(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | (F21|F31) -> printf "v_t2v_d7(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ end
+
+ | Dim6_Scalar_Vector_Vector_D coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | (F23|F32) -> printf "s_vv_6D(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | (F12|F13) -> printf "v_sv_6D(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | (F21|F31) -> printf "v_sv_6D(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ end
+
+ | Dim6_Scalar_Vector_Vector_DP coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | (F23|F32) -> printf "s_vv_6DP(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | (F12|F13) -> printf "v_sv_6DP(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | (F21|F31) -> printf "v_sv_6DP(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ end
+
+ | Dim6_HAZ_D coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F23 -> printf "h_az_D(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F32 -> printf "h_az_D(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ | F13 -> printf "a_hz_D(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F31 -> printf "a_hz_D(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ | F12 -> printf "z_ah_D(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ | F21 -> printf "z_ah_D(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ end
+ | Dim6_HAZ_DP coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F23 -> printf "h_az_DP(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F32 -> printf "h_az_DP(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ | F13 -> printf "a_hz_DP(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F31 -> printf "a_hz_DP(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ | F12 -> printf "z_ah_DP(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ | F21 -> printf "z_ah_DP(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ end
+ | Gauge_Gauge_Gauge_i coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F23 -> printf "g_gg_23(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F32 -> printf "g_gg_23(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ | F13 -> printf "g_gg_13(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F31 -> printf "g_gg_13(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ | F12 -> printf "(-1) * g_gg_13(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F21 -> printf "(-1) * g_gg_13(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ end
+
+ | Dim6_GGG coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F23 -> printf "g_gg_6(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F32 -> printf "g_gg_6(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ | F12 -> printf "g_gg_6(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F21 -> printf "g_gg_6(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ | F13 -> printf "(-1) * g_gg_6(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F31 -> printf "(-1) * g_gg_6(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ end
+
+ | Dim6_AWW_DP coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F23 -> printf "a_ww_DP(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F32 -> printf "a_ww_DP(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ | F13 -> printf "w_aw_DP(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F31 -> printf "w_aw_DP(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ | F12 -> printf "(-1) * w_aw_DP(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F21 -> printf "(-1) * w_aw_DP(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ end
+
+ | Dim6_AWW_DW coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F23 -> printf "a_ww_DW(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F32 -> printf "a_ww_DW(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ | F13 -> printf "(-1) * a_ww_DW(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F31 -> printf "(-1) * a_ww_DW(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ | F12 -> printf "a_ww_DW(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F21 -> printf "a_ww_DW(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ end
+
+ | Dim6_Gauge_Gauge_Gauge_i coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F23 | F31 | F12 ->
+ printf "kg_kgkg_i(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F32 | F13 | F21 ->
+ printf "kg_kgkg_i(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ end
+
+ | Dim6_HHH coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | (F23|F32|F12|F21|F13|F31) ->
+ printf "h_hh_6(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ end
+
+ | Dim6_WWZ_DPWDW coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F23 -> printf "w_wz_DPW(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F32 -> printf "w_wz_DPW(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ | F13 -> printf "(-1) * w_wz_DPW(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F31 -> printf "(-1) * w_wz_DPW(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ | F12 -> printf "z_ww_DPW(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F21 -> printf "z_ww_DPW(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ end
+ | Dim6_WWZ_DW coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F23 -> printf "w_wz_DW(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F32 -> printf "w_wz_DW(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ | F13 -> printf "(-1) * w_wz_DW(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F31 -> printf "(-1) * w_wz_DW(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ | F12 -> printf "z_ww_DW(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F21 -> printf "z_ww_DW(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ end
+ | Dim6_WWZ_D coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F23 -> printf "w_wz_D(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F32 -> printf "w_wz_D(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ | F13 -> printf "(-1) * w_wz_D(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F31 -> printf "(-1) * w_wz_D(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ | F12 -> printf "z_ww_D(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | F21 -> printf "z_ww_D(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ end
+
+ (*i
+ | Dim6_Glu_Glu_Glu coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | (F23|F31|F12) ->
+ printf "g_gg_glu(%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2
+ | (F32|F13|F21) ->
+ printf "g_gg_glu(%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1
+ end
+i*)
+
+ end
+
+(* Flip the sign to account for the~$\mathrm{i}^2$ relative to diagrams
+ with only cubic couplings.
+ \label{hack:sign(V4)} *)
+(* \begin{dubious}
+ That's an \emph{slightly dangerous} hack!!! How do we accnount
+ for such signs when treating $n$-ary vertices uniformly?
+ \end{dubious} *)
+ let print_current_V4 format_wf format_p amplitude dictionary rhs vertex fusion constant =
+ let c = CM.constant_symbol constant
+ and ch1, ch2, ch3 = children3 rhs in
+ let wf1 = format_wf amplitude dictionary ch1
+ and wf2 = format_wf amplitude dictionary ch2
+ and wf3 = format_wf amplitude dictionary ch3
+ and p1 = format_p ch1
+ and p2 = format_p ch2
+ and p3 = format_p ch3 in
+ printf "@, %s " (if (F.sign rhs) < 0 then "+" else "-");
+ begin match vertex with
+ | Scalar4 coeff -> printf "(%s*%s*%s*%s)" (format_coupling coeff c) wf1 wf2 wf3
+ | Scalar2_Vector2 coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F134 | F143 | F234 | F243 -> printf "%s*%s*(%s*%s)" c wf1 wf2 wf3
+ | F314 | F413 | F324 | F423 -> printf "%s*%s*(%s*%s)" c wf2 wf1 wf3
+ | F341 | F431 | F342 | F432 -> printf "%s*%s*(%s*%s)" c wf3 wf1 wf2
+ | F312 | F321 | F412 | F421 -> printf "(%s*%s*%s)*%s" c wf2 wf3 wf1
+ | F231 | F132 | F241 | F142 -> printf "(%s*%s*%s)*%s" c wf1 wf3 wf2
+ | F123 | F213 | F124 | F214 -> printf "(%s*%s*%s)*%s" c wf1 wf2 wf3
+ end
+ | Vector4 contractions ->
+ begin match contractions with
+ | [] -> invalid_arg "Targets.print_current: Vector4 []"
+ | head :: tail ->
+ printf "(";
+ print_vector4 c wf1 wf2 wf3 fusion head;
+ List.iter (print_add_vector4 c wf1 wf2 wf3 fusion) tail;
+ printf ")"
+ end
+ | Dim8_Vector4_t_0 contractions ->
+ begin match contractions with
+ | [] -> invalid_arg "Targets.print_current: Vector4 []"
+ | head :: tail ->
+ print_vector4_t_0 c wf1 p1 wf2 p2 wf3 p3 fusion head;
+ List.iter (print_add_vector4 c wf1 wf2 wf3 fusion) tail;
+ end
+ | Dim8_Vector4_t_1 contractions ->
+ begin match contractions with
+ | [] -> invalid_arg "Targets.print_current: Vector4 []"
+ | head :: tail ->
+ print_vector4_t_1 c wf1 p1 wf2 p2 wf3 p3 fusion head;
+ List.iter (print_add_vector4 c wf1 wf2 wf3 fusion) tail;
+ end
+ | Dim8_Vector4_t_2 contractions ->
+ begin match contractions with
+ | [] -> invalid_arg "Targets.print_current: Vector4 []"
+ | head :: tail ->
+ print_vector4_t_2 c wf1 p1 wf2 p2 wf3 p3 fusion head;
+ List.iter (print_add_vector4 c wf1 wf2 wf3 fusion) tail;
+ end
+ | Dim8_Vector4_m_0 contractions ->
+ begin match contractions with
+ | [] -> invalid_arg "Targets.print_current: Vector4 []"
+ | head :: tail ->
+ print_vector4_m_0 c wf1 p1 wf2 p2 wf3 p3 fusion head;
+ List.iter (print_add_vector4 c wf1 wf2 wf3 fusion) tail;
+ end
+ | Dim8_Vector4_m_1 contractions ->
+ begin match contractions with
+ | [] -> invalid_arg "Targets.print_current: Vector4 []"
+ | head :: tail ->
+ print_vector4_m_1 c wf1 p1 wf2 p2 wf3 p3 fusion head;
+ List.iter (print_add_vector4 c wf1 wf2 wf3 fusion) tail;
+ end
+ | Dim8_Vector4_m_7 contractions ->
+ begin match contractions with
+ | [] -> invalid_arg "Targets.print_current: Vector4 []"
+ | head :: tail ->
+ print_vector4_m_7 c wf1 p1 wf2 p2 wf3 p3 fusion head;
+ List.iter (print_add_vector4 c wf1 wf2 wf3 fusion) tail;
+ end
+ | Vector4_K_Matrix_tho (_, poles) ->
+ let pa, pb =
+ begin match fusion with
+ | (F341|F431|F342|F432|F123|F213|F124|F214) -> (p1, p2)
+ | (F134|F143|F234|F243|F312|F321|F412|F421) -> (p2, p3)
+ | (F314|F413|F324|F423|F132|F231|F142|F241) -> (p1, p3)
+ end in
+ printf "(%s*(%s*%s)*(%s*%s)*(%s*%s)@,*("
+ c p1 wf1 p2 wf2 p3 wf3;
+ List.iter (fun (coeff, pole) ->
+ printf "+%s/((%s+%s)*(%s+%s)-%s)"
+ (SCM.constant_symbol coeff) pa pb pa pb
+ (SCM.constant_symbol pole))
+ poles;
+ printf ")*(-%s-%s-%s))" p1 p2 p3
+ | Vector4_K_Matrix_jr (disc, contractions) ->
+ let pa, pb =
+ begin match disc, fusion with
+ | 3, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
+ | 3, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
+ | 3, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
+ | _, (F341|F431|F342|F432|F123|F213|F124|F214) -> (p1, p2)
+ | _, (F134|F143|F234|F243|F312|F321|F412|F421) -> (p2, p3)
+ | _, (F314|F413|F324|F423|F132|F231|F142|F241) -> (p1, p3)
+ end in
+ begin match contractions with
+ | [] -> invalid_arg "Targets.print_current: Vector4_K_Matrix_jr []"
+ | head :: tail ->
+ printf "(";
+ print_vector4_km c pa pb wf1 wf2 wf3 fusion head;
+ List.iter (print_add_vector4_km c pa pb wf1 wf2 wf3 fusion)
+ tail;
+ printf ")"
+ end
+ | Vector4_K_Matrix_cf_t0 (disc, contractions) ->
+ let pa, pb, pc =
+ begin match disc, fusion with
+ | 3, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2, p3)
+ | 3, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3, p1)
+ | 3, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3, p2)
+ | _, (F341|F431|F342|F432|F123|F213|F124|F214) -> (p1, p2, p3)
+ | _, (F134|F143|F234|F243|F312|F321|F412|F421) -> (p2, p3, p1)
+ | _, (F314|F413|F324|F423|F132|F231|F142|F241) -> (p1, p3, p2)
+ end in
+ begin match contractions with
+ | [] -> invalid_arg "Targets.print_current: Vector4_K_Matrix_cf_t0 []"
+ | head :: tail ->
+ printf "(";
+ print_vector4_km_t_0 c pa pb wf1 p1 wf2 p2 wf3 p3 fusion head;
+ List.iter (print_add_vector4_km c pa pb wf1 wf2 wf3 fusion) tail;
+ printf ")"
+ end
+ | Vector4_K_Matrix_cf_t1 (disc, contractions) ->
+ let pa, pb =
+ begin match disc, fusion with
+ | 3, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
+ | 3, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
+ | 3, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
+ | _, (F341|F431|F342|F432|F123|F213|F124|F214) -> (p1, p2)
+ | _, (F134|F143|F234|F243|F312|F321|F412|F421) -> (p2, p3)
+ | _, (F314|F413|F324|F423|F132|F231|F142|F241) -> (p1, p3)
+ end in
+ begin match contractions with
+ | [] -> invalid_arg "Targets.print_current: Vector4_K_Matrix_cf_t1 []"
+ | head :: tail ->
+ printf "(";
+ print_vector4_km_t_1 c pa pb wf1 p1 wf2 p2 wf3 p3 fusion head;
+ List.iter (print_add_vector4_km c pa pb wf1 wf2 wf3 fusion) tail;
+ printf ")"
+ end
+ | Vector4_K_Matrix_cf_t2 (disc, contractions) ->
+ let pa, pb =
+ begin match disc, fusion with
+ | 3, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
+ | 3, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
+ | 3, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
+ | _, (F341|F431|F342|F432|F123|F213|F124|F214) -> (p1, p2)
+ | _, (F134|F143|F234|F243|F312|F321|F412|F421) -> (p2, p3)
+ | _, (F314|F413|F324|F423|F132|F231|F142|F241) -> (p1, p3)
+ end in
+ begin match contractions with
+ | [] -> invalid_arg "Targets.print_current: Vector4_K_Matrix_cf_t2 []"
+ | head :: tail ->
+ printf "(";
+ print_vector4_km_t_2 c pa pb wf1 p1 wf2 p2 wf3 p3 fusion head;
+ List.iter (print_add_vector4_km c pa pb wf1 wf2 wf3 fusion)
+ tail;
+ printf ")"
+ end
+ | Vector4_K_Matrix_cf_t_rsi (disc, contractions) ->
+ let pa, pb, pc =
+ begin match disc, fusion with
+ | 3, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2, p3)
+ | 3, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3, p1)
+ | 3, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3, p2)
+ | _, (F341|F431|F342|F432|F123|F213|F124|F214) -> (p1, p2, p3)
+ | _, (F134|F143|F234|F243|F312|F321|F412|F421) -> (p2, p3, p1)
+ | _, (F314|F413|F324|F423|F132|F231|F142|F241) -> (p1, p3, p2)
+ end in
+ begin match contractions with
+ | [] -> invalid_arg "Targets.print_current: Vector4_K_Matrix_cf_t_rsi []"
+ | head :: tail ->
+ printf "(";
+ print_vector4_km_t_rsi c pa pb pc wf1 p1 wf2 p2 wf3 p3 fusion head;
+ List.iter (print_add_vector4_km c pa pb wf1 wf2 wf3 fusion)
+ tail;
+ printf ")"
+ end
+ | Vector4_K_Matrix_cf_m0 (disc, contractions) ->
+ let pa, pb =
+ begin match disc, fusion with
+ | 3, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
+ | 3, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
+ | 3, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
+ | _, (F341|F431|F342|F432|F123|F213|F124|F214) -> (p1, p2)
+ | _, (F134|F143|F234|F243|F312|F321|F412|F421) -> (p2, p3)
+ | _, (F314|F413|F324|F423|F132|F231|F142|F241) -> (p1, p3)
+ end in
+ begin match contractions with
+ | [] -> invalid_arg "Targets.print_current: Vector4_K_Matrix_cf_m0 []"
+ | head :: tail ->
+ printf "(";
+ print_vector4_km_m_0 c pa pb wf1 p1 wf2 p2 wf3 p3 fusion head;
+ List.iter (print_add_vector4_km c pa pb wf1 wf2 wf3 fusion) tail;
+ printf ")"
+ end
+ | Vector4_K_Matrix_cf_m1 (disc, contractions) ->
+ let pa, pb =
+ begin match disc, fusion with
+ | 3, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
+ | 3, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
+ | 3, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
+ | _, (F341|F431|F342|F432|F123|F213|F124|F214) -> (p1, p2)
+ | _, (F134|F143|F234|F243|F312|F321|F412|F421) -> (p2, p3)
+ | _, (F314|F413|F324|F423|F132|F231|F142|F241) -> (p1, p3)
+ end in
+ begin match contractions with
+ | [] -> invalid_arg "Targets.print_current: Vector4_K_Matrix_cf_m1 []"
+ | head :: tail ->
+ printf "(";
+ print_vector4_km_m_1 c pa pb wf1 p1 wf2 p2 wf3 p3 fusion head;
+ List.iter (print_add_vector4_km c pa pb wf1 wf2 wf3 fusion)
+ tail;
+ printf ")"
+ end
+ | Vector4_K_Matrix_cf_m7 (disc, contractions) ->
+ let pa, pb =
+ begin match disc, fusion with
+ | 3, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
+ | 3, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
+ | 3, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
+ | _, (F341|F431|F342|F432|F123|F213|F124|F214) -> (p1, p2)
+ | _, (F134|F143|F234|F243|F312|F321|F412|F421) -> (p2, p3)
+ | _, (F314|F413|F324|F423|F132|F231|F142|F241) -> (p1, p3)
+ end in
+ begin match contractions with
+ | [] -> invalid_arg "Targets.print_current: Vector4_K_Matrix_cf_m7 []"
+ | head :: tail ->
+ printf "(";
+ print_vector4_km_m_7 c pa pb wf1 p1 wf2 p2 wf3 p3 fusion head;
+ List.iter (print_add_vector4_km c pa pb wf1 wf2 wf3 fusion) tail;
+ printf ")"
+ end
+ | DScalar2_Vector2_K_Matrix_ms (disc, contractions) ->
+ let p123 = Printf.sprintf "(-%s-%s-%s)" p1 p2 p3 in
+ let pa, pb =
+ begin match disc, fusion with
+ | 3, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
+ | 3, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
+ | 3, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
+ | 4, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
+ | 4, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
+ | 4, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
+ | 5, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
+ | 5, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
+ | 5, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
+ | 6, (F134|F132|F314|F312|F241|F243|F421|F423) -> (p1, p2)
+ | 6, (F213|F413|F231|F431|F124|F324|F142|F342) -> (p2, p3)
+ | 6, (F143|F123|F341|F321|F412|F214|F432|F234) -> (p1, p3)
+ | 7, (F134|F132|F314|F312|F241|F243|F421|F423) -> (p1, p2)
+ | 7, (F213|F413|F231|F431|F124|F324|F142|F342) -> (p2, p3)
+ | 7, (F143|F123|F341|F321|F412|F214|F432|F234) -> (p1, p3)
+ | 8, (F134|F132|F314|F312|F241|F243|F421|F423) -> (p1, p2)
+ | 8, (F213|F413|F231|F431|F124|F324|F142|F342) -> (p2, p3)
+ | 8, (F143|F123|F341|F321|F412|F214|F432|F234) -> (p1, p3)
+ | _, (F341|F431|F342|F432|F123|F213|F124|F214) -> (p1, p2)
+ | _, (F134|F143|F234|F243|F312|F321|F412|F421) -> (p2, p3)
+ | _, (F314|F413|F324|F423|F132|F231|F142|F241) -> (p1, p3)
+ end in
+ begin match contractions with
+ | [] -> invalid_arg "Targets.print_current: DScalar2_Vector4_K_Matrix_ms []"
+ | head :: tail ->
+ printf "(";
+ print_dscalar2_vector2_km c pa pb wf1 wf2 wf3 p1 p2 p3 p123 fusion head;
+ List.iter (print_add_dscalar2_vector2_km c pa pb wf1 wf2 wf3 p1 p2 p3 p123 fusion) tail;
+ printf ")"
+ end
+ | DScalar2_Vector2_m_0_K_Matrix_cf (disc, contractions) ->
+ let pa, pb =
+ begin match disc, fusion with
+ | 3, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
+ | 3, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
+ | 3, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
+ | 4, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
+ | 4, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
+ | 4, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
+ | 5, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
+ | 5, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
+ | 5, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
+ | 6, (F134|F132|F314|F312|F241|F243|F421|F423) -> (p1, p2)
+ | 6, (F213|F413|F231|F431|F124|F324|F142|F342) -> (p2, p3)
+ | 6, (F143|F123|F341|F321|F412|F214|F432|F234) -> (p1, p3)
+ | 7, (F134|F132|F314|F312|F241|F243|F421|F423) -> (p1, p2)
+ | 7, (F213|F413|F231|F431|F124|F324|F142|F342) -> (p2, p3)
+ | 7, (F143|F123|F341|F321|F412|F214|F432|F234) -> (p1, p3)
+ | 8, (F134|F132|F314|F312|F241|F243|F421|F423) -> (p1, p2)
+ | 8, (F213|F413|F231|F431|F124|F324|F142|F342) -> (p2, p3)
+ | 8, (F143|F123|F341|F321|F412|F214|F432|F234) -> (p1, p3)
+ | _, (F341|F431|F342|F432|F123|F213|F124|F214) -> (p1, p2)
+ | _, (F134|F143|F234|F243|F312|F321|F412|F421) -> (p2, p3)
+ | _, (F314|F413|F324|F423|F132|F231|F142|F241) -> (p1, p3)
+ end in
+ begin match contractions with
+ | [] -> invalid_arg "Targets.print_current: DScalar2_Vector4_K_Matrix_cf_m0 []"
+ | head :: tail ->
+ printf "(";
+ print_dscalar2_vector2_m_0_km c pa pb wf1 wf2 wf3 p1 p2 p3 fusion head;
+ List.iter (print_add_dscalar2_vector2_m_0_km c pa pb wf1 wf2 wf3 p1 p2 p3 fusion) tail;
+ printf ")"
+ end
+ | DScalar2_Vector2_m_1_K_Matrix_cf (disc, contractions) ->
+ let pa, pb =
+ begin match disc, fusion with
+ | 3, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
+ | 3, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
+ | 3, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
+ | 4, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
+ | 4, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
+ | 4, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
+ | 5, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
+ | 5, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
+ | 5, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
+ | 6, (F134|F132|F314|F312|F241|F243|F421|F423) -> (p1, p2)
+ | 6, (F213|F413|F231|F431|F124|F324|F142|F342) -> (p2, p3)
+ | 6, (F143|F123|F341|F321|F412|F214|F432|F234) -> (p1, p3)
+ | 7, (F134|F132|F314|F312|F241|F243|F421|F423) -> (p1, p2)
+ | 7, (F213|F413|F231|F431|F124|F324|F142|F342) -> (p2, p3)
+ | 7, (F143|F123|F341|F321|F412|F214|F432|F234) -> (p1, p3)
+ | 8, (F134|F132|F314|F312|F241|F243|F421|F423) -> (p1, p2)
+ | 8, (F213|F413|F231|F431|F124|F324|F142|F342) -> (p2, p3)
+ | 8, (F143|F123|F341|F321|F412|F214|F432|F234) -> (p1, p3)
+ | _, (F341|F431|F342|F432|F123|F213|F124|F214) -> (p1, p2)
+ | _, (F134|F143|F234|F243|F312|F321|F412|F421) -> (p2, p3)
+ | _, (F314|F413|F324|F423|F132|F231|F142|F241) -> (p1, p3)
+ end in
+ begin match contractions with
+ | [] -> invalid_arg "Targets.print_current: DScalar2_Vector4_K_Matrix_cf_m1 []"
+ | head :: tail ->
+ printf "(";
+ print_dscalar2_vector2_m_1_km c pa pb wf1 wf2 wf3 p1 p2 p3 fusion head;
+ List.iter (print_add_dscalar2_vector2_m_1_km c pa pb wf1 wf2 wf3 p1 p2 p3 fusion) tail;
+ printf ")"
+ end
+ | DScalar2_Vector2_m_7_K_Matrix_cf (disc, contractions) ->
+ let pa, pb =
+ begin match disc, fusion with
+ | 3, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
+ | 3, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
+ | 3, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
+ | 4, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
+ | 4, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
+ | 4, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
+ | 5, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
+ | 5, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
+ | 5, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
+ | 6, (F134|F132|F314|F312|F241|F243|F421|F423) -> (p1, p2)
+ | 6, (F213|F413|F231|F431|F124|F324|F142|F342) -> (p2, p3)
+ | 6, (F143|F123|F341|F321|F412|F214|F432|F234) -> (p1, p3)
+ | 7, (F134|F132|F314|F312|F241|F243|F421|F423) -> (p1, p2)
+ | 7, (F213|F413|F231|F431|F124|F324|F142|F342) -> (p2, p3)
+ | 7, (F143|F123|F341|F321|F412|F214|F432|F234) -> (p1, p3)
+ | 8, (F134|F132|F314|F312|F241|F243|F421|F423) -> (p1, p2)
+ | 8, (F213|F413|F231|F431|F124|F324|F142|F342) -> (p2, p3)
+ | 8, (F143|F123|F341|F321|F412|F214|F432|F234) -> (p1, p3)
+ | _, (F341|F431|F342|F432|F123|F213|F124|F214) -> (p1, p2)
+ | _, (F134|F143|F234|F243|F312|F321|F412|F421) -> (p2, p3)
+ | _, (F314|F413|F324|F423|F132|F231|F142|F241) -> (p1, p3)
+ end in
+ begin match contractions with
+ | [] -> invalid_arg "Targets.print_current: DScalar2_Vector4_K_Matrix_cf_m7 []"
+ | head :: tail ->
+ printf "(";
+ print_dscalar2_vector2_m_7_km c pa pb wf1 wf2 wf3 p1 p2 p3 fusion head;
+ List.iter (print_add_dscalar2_vector2_m_7_km c pa pb wf1 wf2 wf3 p1 p2 p3 fusion) tail;
+ printf ")"
+ end
+ | DScalar4_K_Matrix_ms (disc, contractions) ->
+ let p123 = Printf.sprintf "(-%s-%s-%s)" p1 p2 p3 in
+ let pa, pb =
+ begin match disc, fusion with
+ | 3, (F143|F413|F142|F412|F321|F231|F324|F234) -> (p1, p2)
+ | 3, (F314|F341|F214|F241|F132|F123|F432|F423) -> (p2, p3)
+ | 3, (F134|F431|F124|F421|F312|F213|F342|F243) -> (p1, p3)
+ | _, (F341|F431|F342|F432|F123|F213|F124|F214) -> (p1, p2)
+ | _, (F134|F143|F234|F243|F312|F321|F412|F421) -> (p2, p3)
+ | _, (F314|F413|F324|F423|F132|F231|F142|F241) -> (p1, p3)
+ end in
+ begin match contractions with
+ | [] -> invalid_arg "Targets.print_current: DScalar4_K_Matrix_ms []"
+ | head :: tail ->
+ printf "(";
+ print_dscalar4_km c pa pb wf1 wf2 wf3 p1 p2 p3 p123 fusion head;
+ List.iter (print_add_dscalar4_km c pa pb wf1 wf2 wf3 p1 p2 p3 p123 fusion) tail;
+ printf ")"
+ end
+ | Dim8_Scalar2_Vector2_1 coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F134 | F143 | F234 | F243 ->
+ printf "phi_phi2v_1(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F314 | F413 | F324 | F423 ->
+ printf "phi_phi2v_1(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F341 | F431 | F342 | F432 ->
+ printf "phi_phi2v_1(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F312 | F321 | F412 | F421 ->
+ printf "v_phi2v_1(%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1
+ | F231 | F132 | F241 | F142 ->
+ printf "v_phi2v_1(%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2
+ | F123 | F213 | F124 | F214 ->
+ printf "v_phi2v_1(%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3
+ end
+ | Dim8_Scalar2_Vector2_2 coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F134 | F143 | F234 | F243 ->
+ printf "phi_phi2v_2(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F314 | F413 | F324 | F423 ->
+ printf "phi_phi2v_2(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F341 | F431 | F342 | F432 ->
+ printf "phi_phi2v_2(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F312 | F321 | F412 | F421 ->
+ printf "v_phi2v_2(%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1
+ | F231 | F132 | F241 | F142 ->
+ printf "v_phi2v_2(%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2
+ | F123 | F213 | F124 | F214 ->
+ printf "v_phi2v_2(%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3
+ end
+ | Dim8_Scalar2_Vector2_m_0 coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F134 | F143 | F234 | F243 ->
+ printf "phi_phi2v_m_0(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F314 | F413 | F324 | F423 ->
+ printf "phi_phi2v_m_0(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F341 | F431 | F342 | F432 ->
+ printf "phi_phi2v_m_0(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F312 | F321 | F412 | F421 ->
+ printf "v_phi2v_m_0(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F231 | F132 | F241 | F142 ->
+ printf "v_phi2v_m_0(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F123 | F213 | F124 | F214 ->
+ printf "v_phi2v_m_0(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ end
+ | Dim8_Scalar2_Vector2_m_1 coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F134 | F143 | F234 | F243 ->
+ printf "phi_phi2v_m_1(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F314 | F413 | F324 | F423 ->
+ printf "phi_phi2v_m_1(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F341 | F431 | F342 | F432 ->
+ printf "phi_phi2v_m_1(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F312 | F321 | F412 | F421 ->
+ printf "v_phi2v_m_1(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F231 | F132 | F241 | F142 ->
+ printf "v_phi2v_m_1(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F123 | F213 | F124 | F214 ->
+ printf "v_phi2v_m_1(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ end
+ | Dim8_Scalar2_Vector2_m_7 coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F134 | F143 | F234 | F243 ->
+ printf "phi_phi2v_m_7(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F314 | F413 | F324 | F423 ->
+ printf "phi_phi2v_m_7(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F341 | F431 | F342 | F432 ->
+ printf "phi_phi2v_m_7(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F312 | F321 | F412 | F421 ->
+ printf "v_phi2v_m_7(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F231 | F132 | F241 | F142 ->
+ printf "v_phi2v_m_7(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F123 | F213 | F124 | F214 ->
+ printf "v_phi2v_m_7(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ end
+ | Dim8_Scalar4 coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F134 | F143 | F234 | F243 | F314 | F413 | F324 | F423
+ | F341 | F431 | F342 | F432 | F312 | F321 | F412 | F421
+ | F231 | F132 | F241 | F142 | F123 | F213 | F124 | F214 ->
+ printf "s_dim8s3 (%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ end
+ | GBBG (coeff, fb, b, f) ->
+ Fermions.print_current_g4 (coeff, fb, b, f) c wf1 wf2 wf3 fusion
+
+ | Dim6_H4_P2 coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F134 | F143 | F234 | F243 | F314 | F413 | F324 | F423
+ | F341 | F431 | F342 | F432 | F312 | F321 | F412 | F421
+ | F231 | F132 | F241 | F142 | F123 | F213 | F124 | F214 ->
+ printf "hhhh_p2 (%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ end
+
+ | Dim6_AHWW_DPB coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F234 -> printf "a_hww_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F243 -> printf "a_hww_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F342 -> printf "a_hww_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F324 -> printf "a_hww_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F423 -> printf "a_hww_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F432 -> printf "a_hww_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F134 -> printf "h_aww_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F143 -> printf "h_aww_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F341 -> printf "h_aww_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F314 -> printf "h_aww_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F413 -> printf "h_aww_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F431 -> printf "h_aww_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F124 -> printf "w_ahw_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F142 -> printf "w_ahw_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F241 -> printf "w_ahw_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F214 -> printf "w_ahw_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F412 -> printf "w_ahw_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F421 -> printf "w_ahw_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F123 -> printf "(-1)*w_ahw_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F132 -> printf "(-1)*w_ahw_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F231 -> printf "(-1)*w_ahw_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F213 -> printf "(-1)*w_ahw_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F312 -> printf "(-1)*w_ahw_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F321 -> printf "(-1)*w_ahw_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ end
+ | Dim6_AHWW_DPW coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F234 -> printf "a_hww_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F243 -> printf "a_hww_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F342 -> printf "a_hww_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F324 -> printf "a_hww_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F423 -> printf "a_hww_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F432 -> printf "a_hww_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F134 -> printf "h_aww_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F143 -> printf "h_aww_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F341 -> printf "h_aww_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F314 -> printf "h_aww_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F413 -> printf "h_aww_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F431 -> printf "h_aww_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F124 -> printf "w_ahw_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F142 -> printf "w_ahw_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F241 -> printf "w_ahw_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F214 -> printf "w_ahw_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F412 -> printf "w_ahw_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F421 -> printf "w_ahw_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F123 -> printf "(-1)*w_ahw_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F132 -> printf "(-1)*w_ahw_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F231 -> printf "(-1)*w_ahw_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F213 -> printf "(-1)*w_ahw_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F312 -> printf "(-1)*w_ahw_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F321 -> printf "(-1)*w_ahw_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ end
+
+ | Dim6_AHWW_DW coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F234 -> printf "a_hww_DW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F243 -> printf "a_hww_DW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F342 -> printf "a_hww_DW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F324 -> printf "a_hww_DW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F423 -> printf "a_hww_DW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F432 -> printf "a_hww_DW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F134 -> printf "h_aww_DW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F143 -> printf "h_aww_DW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F341 -> printf "h_aww_DW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F314 -> printf "h_aww_DW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F413 -> printf "h_aww_DW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F431 -> printf "h_aww_DW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F124 -> printf "w3_ahw_DW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F142 -> printf "w3_ahw_DW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F241 -> printf "w3_ahw_DW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F214 -> printf "w3_ahw_DW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F412 -> printf "w3_ahw_DW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F421 -> printf "w3_ahw_DW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F123 -> printf "w4_ahw_DW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F132 -> printf "w4_ahw_DW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F231 -> printf "w4_ahw_DW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F213 -> printf "w4_ahw_DW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F312 -> printf "w4_ahw_DW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F321 -> printf "w4_ahw_DW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ (*i | F234 | F134 | F124 | F123 ->
+ printf "a_hww_DW(%s,%s,%s,%s,%s,%s,%s)"
+ c wf1 p1 wf2 p2 wf3 p3
+ | F243 | F143 | F142 | F132 ->
+ printf "a_hww_DW(%s,%s,%s,%s,%s,%s,%s)"
+ c wf1 p1 wf3 p3 wf2 p2
+ | F342 | F341 | F241 | F231 ->
+ printf "a_hww_DW(%s,%s,%s,%s,%s,%s,%s)"
+ c wf3 p3 wf1 p1 wf2 p2
+ | F324 | F314 | F214 | F213 ->
+ printf "a_hww_DW(%s,%s,%s,%s,%s,%s,%s)"
+ c wf2 p2 wf1 p1 wf3 p3
+ | F423 | F413 | F412 | F312 ->
+ printf "a_hww_DW(%s,%s,%s,%s,%s,%s,%s)"
+ c wf2 p2 wf3 p3 wf1 p1
+ | F432 | F431 | F421 | F321 ->
+ printf "a_hww_DW(%s,%s,%s,%s,%s,%s,%s)"
+ c wf3 p3 wf2 p2 wf1 p1 i*)
+ end
+
+ | Dim6_Scalar2_Vector2_D coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F234 | F134 -> printf "h_hww_D(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F243 | F143 -> printf "h_hww_D(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F342 | F341 -> printf "h_hww_D(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F324 | F314 -> printf "h_hww_D(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F423 | F413 -> printf "h_hww_D(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F432 | F431 -> printf "h_hww_D(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F124 | F123 -> printf "w_hhw_D(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F142 | F132 -> printf "w_hhw_D(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F241 | F231 -> printf "w_hhw_D(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F214 | F213 -> printf "w_hhw_D(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F412 | F312 -> printf "w_hhw_D(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F421 | F321 -> printf "w_hhw_D(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ end
+
+ | Dim6_Scalar2_Vector2_DP coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F234 | F134 -> printf "h_hww_DP(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F342 | F341 -> printf "h_hww_DP(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F423 | F413 -> printf "h_hww_DP(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F243 | F143 -> printf "h_hww_DP(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F324 | F314 -> printf "h_hww_DP(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F432 | F431 -> printf "h_hww_DP(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F123 | F124 -> printf "w_hhw_DP(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F231 | F241 -> printf "w_hhw_DP(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F312 | F412 -> printf "w_hhw_DP(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F132 | F142 -> printf "w_hhw_DP(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F213 | F214 -> printf "w_hhw_DP(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F321 | F421 -> printf "w_hhw_DP(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ (*i | F234 ->
+ printf "h_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
+ c wf1 p1 wf2 p2 wf3 p3
+ | F243 ->
+ printf "h_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
+ c wf1 p1 wf3 p3 wf2 p2
+ | F342 ->
+ printf "h_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
+ c wf3 p3 wf1 p1 wf2 p2
+ | F324 ->
+ printf "h_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
+ c wf2 p2 wf1 p1 wf3 p3
+ | F423 ->
+ printf "h_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
+ c wf2 p2 wf3 p3 wf1 p1
+ | F432 ->
+ printf "h_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
+ c wf3 p3 wf2 p2 wf1 p1
+ | F124 ->
+ printf "w_hhw_DPW(%s,%s,%s,%s,%s,%s,%s)"
+ c wf1 p1 wf2 p2 wf3 p3
+ | F142 ->
+ printf "w_hhw_DPW(%s,%s,%s,%s,%s,%s,%s)"
+ c wf1 p1 wf3 p3 wf2 p2
+ | F241 ->
+ printf "w_hhw_DPW(%s,%s,%s,%s,%s,%s,%s)"
+ c wf3 p3 wf1 p1 wf2 p2
+ | F214 ->
+ printf "w_hhw_DPW(%s,%s,%s,%s,%s,%s,%s)"
+ c wf2 p2 wf1 p1 wf3 p3
+ | F412 ->
+ printf "w_hhw_DPW(%s,%s,%s,%s,%s,%s,%s)"
+ c wf2 p2 wf3 p3 wf1 p1
+ | F421 ->
+ printf "w_hhw_DPW(%s,%s,%s,%s,%s,%s,%s)"
+ c wf3 p3 wf2 p2 wf1 p1
+ | F134 ->
+ printf "h_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
+ c wf1 p1 wf2 p2 wf3 p3
+ | F143 ->
+ printf "h_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
+ c wf1 p1 wf3 p3 wf2 p2
+ | F341 ->
+ printf "h_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
+ c wf3 p3 wf1 p1 wf2 p2
+ | F314 ->
+ printf "h_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
+ c wf2 p2 wf1 p1 wf3 p3
+ | F413 ->
+ printf "h_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
+ c wf2 p2 wf3 p3 wf1 p1
+ | F431 ->
+ printf "h_hww_DPW(%s,%s,%s,%s,%s,%s,%s)"
+ c wf3 p3 wf2 p2 wf1 p1
+ | F123 ->
+ printf "w_hhw_DPW(%s,%s,%s,%s,%s,%s,%s)"
+ c wf1 p1 wf2 p2 wf3 p3
+ | F132 ->
+ printf "w_hhw_DPW(%s,%s,%s,%s,%s,%s,%s)"
+ c wf1 p1 wf3 p3 wf2 p2
+ | F231 ->
+ printf "w_hhw_DPW(%s,%s,%s,%s,%s,%s,%s)"
+ c wf3 p3 wf1 p1 wf2 p2
+ | F213 ->
+ printf "w_hhw_DPW(%s,%s,%s,%s,%s,%s,%s)"
+ c wf2 p2 wf1 p1 wf3 p3
+ | F312 ->
+ printf "w_hhw_DPW(%s,%s,%s,%s,%s,%s,%s)"
+ c wf2 p2 wf3 p3 wf1 p1
+ | F321 ->
+ printf "w_hhw_DPW(%s,%s,%s,%s,%s,%s,%s)"
+ c wf3 p3 wf2 p2 wf1 p1 i*)
+ end
+
+ | Dim6_Scalar2_Vector2_PB coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F234 | F134 -> printf "h_hvv_PB(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F342 | F341 -> printf "h_hvv_PB(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F423 | F413 -> printf "h_hvv_PB(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F243 | F143 -> printf "h_hvv_PB(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F324 | F314 -> printf "h_hvv_PB(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F432 | F431 -> printf "h_hvv_PB(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F123 | F124 -> printf "v_hhv_PB(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F231 | F241 -> printf "v_hhv_PB(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F312 | F412 -> printf "v_hhv_PB(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F132 | F142 -> printf "v_hhv_PB(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F213 | F214 -> printf "v_hhv_PB(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F321 | F421 -> printf "v_hhv_PB(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ end
+
+ | Dim6_HHZZ_T coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F234 | F134 -> printf "(%s)*(%s)*(%s)*(%s)" c wf1 wf2 wf3
+ | F342 | F341 -> printf "(%s)*(%s)*(%s)*(%s)" c wf3 wf1 wf2
+ | F423 | F413 -> printf "(%s)*(%s)*(%s)*(%s)" c wf2 wf3 wf1
+ | F243 | F143 -> printf "(%s)*(%s)*(%s)*(%s)" c wf1 wf3 wf2
+ | F324 | F314 -> printf "(%s)*(%s)*(%s)*(%s)" c wf2 wf1 wf3
+ | F432 | F431 -> printf "(%s)*(%s)*(%s)*(%s)" c wf3 wf2 wf1
+ | F123 | F124 | F231 | F241 | F312 | F412 -> printf "(%s)*(%s)*(%s)*(%s)" c wf1 wf2 wf3
+ | F132 | F142 | F213 | F214 | F321 | F421 -> printf "(%s)*(%s)*(%s)*(%s)" c wf1 wf2 wf3
+ end
+
+ | Dim6_Vector4_DW coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F234 | F134 -> printf "a_aww_DW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F342 | F341 -> printf "a_aww_DW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F423 | F413 -> printf "a_aww_DW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F243 | F143 -> printf "a_aww_DW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F324 | F314 -> printf "a_aww_DW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F432 | F431 -> printf "a_aww_DW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F124 | F123 -> printf "w_aaw_DW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F241 | F231 -> printf "w_aaw_DW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F412 | F312 -> printf "w_aaw_DW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F142 | F132 -> printf "w_aaw_DW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F214 | F213 -> printf "w_aaw_DW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F421 | F321 -> printf "w_aaw_DW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ end
+
+ | Dim6_Vector4_W coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F234 | F134 -> printf "a_aww_W(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F342 | F341 -> printf "a_aww_W(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F423 | F413 -> printf "a_aww_W(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F243 | F143 -> printf "a_aww_W(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F324 | F314 -> printf "a_aww_W(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F432 | F431 -> printf "a_aww_W(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F123 | F124 -> printf "w_aaw_W(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F231 | F241 -> printf "w_aaw_W(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F312 | F412 -> printf "w_aaw_W(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F132 | F142 -> printf "w_aaw_W(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F213 | F214 -> printf "w_aaw_W(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F321 | F421 -> printf "w_aaw_W(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ end
+
+ | Dim6_HWWZ_DW coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F234 -> printf "h_wwz_DW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F243 -> printf "h_wwz_DW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F342 -> printf "h_wwz_DW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F324 -> printf "h_wwz_DW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F423 -> printf "h_wwz_DW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F432 -> printf "h_wwz_DW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F124 -> printf "(-1)*w_hwz_DW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F142 -> printf "(-1)*w_hwz_DW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F241 -> printf "(-1)*w_hwz_DW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F214 -> printf "(-1)*w_hwz_DW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F412 -> printf "(-1)*w_hwz_DW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F421 -> printf "(-1)*w_hwz_DW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F134 -> printf "w_hwz_DW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F143 -> printf "w_hwz_DW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F341 -> printf "w_hwz_DW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F314 -> printf "w_hwz_DW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F413 -> printf "w_hwz_DW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F431 -> printf "w_hwz_DW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F123 -> printf "z_hww_DW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F132 -> printf "z_hww_DW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F231 -> printf "z_hww_DW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F213 -> printf "z_hww_DW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F312 -> printf "z_hww_DW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F321 -> printf "z_hww_DW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ end
+
+ | Dim6_HWWZ_DPB coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F234 -> printf "h_wwz_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F243 -> printf "h_wwz_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F342 -> printf "h_wwz_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F324 -> printf "h_wwz_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F423 -> printf "h_wwz_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F432 -> printf "h_wwz_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F124 -> printf "(-1)*w_hwz_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F142 -> printf "(-1)*w_hwz_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F241 -> printf "(-1)*w_hwz_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F214 -> printf "(-1)*w_hwz_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F412 -> printf "(-1)*w_hwz_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F421 -> printf "(-1)*w_hwz_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F134 -> printf "w_hwz_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F143 -> printf "w_hwz_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F341 -> printf "w_hwz_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F314 -> printf "w_hwz_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F413 -> printf "w_hwz_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F431 -> printf "w_hwz_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F123 -> printf "z_hww_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F132 -> printf "z_hww_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F231 -> printf "z_hww_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F213 -> printf "z_hww_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F312 -> printf "z_hww_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F321 -> printf "z_hww_DPB(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ end
+
+ | Dim6_HWWZ_DDPW coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F234 -> printf "h_wwz_DDPW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F243 -> printf "h_wwz_DDPW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F342 -> printf "h_wwz_DDPW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F324 -> printf "h_wwz_DDPW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F423 -> printf "h_wwz_DDPW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F432 -> printf "h_wwz_DDPW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F124 -> printf "(-1)*w_hwz_DDPW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F142 -> printf "(-1)*w_hwz_DDPW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F241 -> printf "(-1)*w_hwz_DDPW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F214 -> printf "(-1)*w_hwz_DDPW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F412 -> printf "(-1)*w_hwz_DDPW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F421 -> printf "(-1)*w_hwz_DDPW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F134 -> printf "w_hwz_DDPW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F143 -> printf "w_hwz_DDPW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F341 -> printf "w_hwz_DDPW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F314 -> printf "w_hwz_DDPW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F413 -> printf "w_hwz_DDPW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F431 -> printf "w_hwz_DDPW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F123 -> printf "z_hww_DDPW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F132 -> printf "z_hww_DDPW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F231 -> printf "z_hww_DDPW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F213 -> printf "z_hww_DDPW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F312 -> printf "z_hww_DDPW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F321 -> printf "z_hww_DDPW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ end
+
+ | Dim6_HWWZ_DPW coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F234 -> printf "h_wwz_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F243 -> printf "h_wwz_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F342 -> printf "h_wwz_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F324 -> printf "h_wwz_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F423 -> printf "h_wwz_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F432 -> printf "h_wwz_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F124 -> printf "(-1)*w_hwz_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F142 -> printf "(-1)*w_hwz_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F241 -> printf "(-1)*w_hwz_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F214 -> printf "(-1)*w_hwz_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F412 -> printf "(-1)*w_hwz_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F421 -> printf "(-1)*w_hwz_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F134 -> printf "w_hwz_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F143 -> printf "w_hwz_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F341 -> printf "w_hwz_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F314 -> printf "w_hwz_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F413 -> printf "w_hwz_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F431 -> printf "w_hwz_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F123 -> printf "z_hww_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F132 -> printf "z_hww_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F231 -> printf "z_hww_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F213 -> printf "z_hww_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F312 -> printf "z_hww_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F321 -> printf "z_hww_DPW(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ end
+
+ | Dim6_AHHZ_D coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F234 -> printf "a_hhz_D(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F243 -> printf "a_hhz_D(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F342 -> printf "a_hhz_D(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F324 -> printf "a_hhz_D(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F423 -> printf "a_hhz_D(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F432 -> printf "a_hhz_D(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F124 -> printf "h_ahz_D(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F142 -> printf "h_ahz_D(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F241 -> printf "h_ahz_D(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F214 -> printf "h_ahz_D(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F412 -> printf "h_ahz_D(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F421 -> printf "h_ahz_D(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F134 -> printf "h_ahz_D(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F143 -> printf "h_ahz_D(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F341 -> printf "h_ahz_D(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F314 -> printf "h_ahz_D(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F413 -> printf "h_ahz_D(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F431 -> printf "h_ahz_D(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F123 -> printf "z_ahh_D(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F132 -> printf "z_ahh_D(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F231 -> printf "z_ahh_D(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F213 -> printf "z_ahh_D(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F312 -> printf "z_ahh_D(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F321 -> printf "z_ahh_D(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ end
+
+ | Dim6_AHHZ_DP coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F234 -> printf "a_hhz_DP(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F243 -> printf "a_hhz_DP(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F342 -> printf "a_hhz_DP(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F324 -> printf "a_hhz_DP(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F423 -> printf "a_hhz_DP(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F432 -> printf "a_hhz_DP(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F124 -> printf "h_ahz_DP(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F142 -> printf "h_ahz_DP(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F241 -> printf "h_ahz_DP(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F214 -> printf "h_ahz_DP(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F412 -> printf "h_ahz_DP(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F421 -> printf "h_ahz_DP(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F134 -> printf "h_ahz_DP(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F143 -> printf "h_ahz_DP(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F341 -> printf "h_ahz_DP(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F314 -> printf "h_ahz_DP(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F413 -> printf "h_ahz_DP(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F431 -> printf "h_ahz_DP(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F123 -> printf "z_ahh_DP(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F132 -> printf "z_ahh_DP(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F231 -> printf "z_ahh_DP(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F213 -> printf "z_ahh_DP(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F312 -> printf "z_ahh_DP(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F321 -> printf "z_ahh_DP(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ end
+
+ | Dim6_AHHZ_PB coeff ->
+ let c = format_coupling coeff c in
+ begin match fusion with
+ | F234 -> printf "a_hhz_PB(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F243 -> printf "a_hhz_PB(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F342 -> printf "a_hhz_PB(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F324 -> printf "a_hhz_PB(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F423 -> printf "a_hhz_PB(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F432 -> printf "a_hhz_PB(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F124 -> printf "h_ahz_PB(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F142 -> printf "h_ahz_PB(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F241 -> printf "h_ahz_PB(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F214 -> printf "h_ahz_PB(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F412 -> printf "h_ahz_PB(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F421 -> printf "h_ahz_PB(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F134 -> printf "h_ahz_PB(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F143 -> printf "h_ahz_PB(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F341 -> printf "h_ahz_PB(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F314 -> printf "h_ahz_PB(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F413 -> printf "h_ahz_PB(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F431 -> printf "h_ahz_PB(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ | F123 -> printf "z_ahh_PB(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf2 p2 wf3 p3
+ | F132 -> printf "z_ahh_PB(%s,%s,%s,%s,%s,%s,%s)" c wf1 p1 wf3 p3 wf2 p2
+ | F231 -> printf "z_ahh_PB(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf1 p1 wf2 p2
+ | F213 -> printf "z_ahh_PB(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf1 p1 wf3 p3
+ | F312 -> printf "z_ahh_PB(%s,%s,%s,%s,%s,%s,%s)" c wf2 p2 wf3 p3 wf1 p1
+ | F321 -> printf "z_ahh_PB(%s,%s,%s,%s,%s,%s,%s)" c wf3 p3 wf2 p2 wf1 p1
+ end
+
+ (* \begin{dubious}
+ In principle, [p4] could be obtained from the left hand side \ldots
+ \end{dubious} *)
+ | DScalar4 contractions ->
+ let p123 = Printf.sprintf "(-%s-%s-%s)" p1 p2 p3 in
+ begin match contractions with
+ | [] -> invalid_arg "Targets.print_current: DScalar4 []"
+ | head :: tail ->
+ printf "(";
+ print_dscalar4 c wf1 wf2 wf3 p1 p2 p3 p123 fusion head;
+ List.iter (print_add_dscalar4 c wf1 wf2 wf3 p1 p2 p3 p123 fusion) tail;
+ printf ")"
+ end
+
+ | DScalar2_Vector2 contractions ->
+ let p123 = Printf.sprintf "(-%s-%s-%s)" p1 p2 p3 in
+ begin match contractions with
+ | [] -> invalid_arg "Targets.print_current: DScalar4 []"
+ | head :: tail ->
+ printf "(";
+ print_dscalar2_vector2 c wf1 wf2 wf3 p1 p2 p3 p123 fusion head;
+ List.iter (print_add_dscalar2_vector2 c wf1 wf2 wf3 p1 p2 p3 p123 fusion) tail;
+ printf ")"
+ end
+
+ end
+
+ end
Index: trunk/omega/src/color.mli
===================================================================
--- trunk/omega/src/color.mli (revision 8899)
+++ trunk/omega/src/color.mli (revision 8900)
@@ -1,417 +1,98 @@
(* color.mli --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
module type Test =
sig
val suite : OUnit.test
val suite_long : OUnit.test
end
(* \thocwmodulesection{Quantum Numbers} *)
(* Color is not necessarily the~$\textrm{SU}(3)$ of QCD. Conceptually,
it can be any \emph{unbroken} symmetry (\emph{broken} symmetries correspond
to [Model.flavor]). In order to keep the group theory simple, we confine
ourselves to the fundamental and adjoint representation
of a single~$\textrm{SU}(N_C)$ for the moment. Therefore,
particles are either color singlets or live in the defining
representation of $\textrm{SU}(N_C)$: [SUN]$(|N_C|)$, its conjugate
[SUN]$(-|N_C|)$ or in the adjoint representation of
$\textrm{SU}(N_C)$: [AdjSUN]$(N_C)$. *)
-type t = Singlet | SUN of int | AdjSUN of int
+type t =
+ | Singlet
+ | SUN of int
+ | AdjSUN of int
+ | YT of int Young.tableau
+ | YTC of int Young.tableau
val conjugate : t -> t
val compare : t -> t -> int
(* \thocwmodulesection{Color Flows} *)
(* This computes the color flow as used by WHIZARD: *)
module type Flow =
sig
type color
type t = color list * color list
val rank : t -> int
val of_list : int list -> color
val ghost : unit -> color
val to_lists : t -> int list list
val in_to_lists : t -> int list list
val out_to_lists : t -> int list list
val ghost_flags : t -> bool list
val in_ghost_flags : t -> bool list
val out_ghost_flags : t -> bool list
(* A factor is a list of powers
\begin{equation}
\sum_{i}
\left( \frac{\ocwlowerid{num}_i}{\ocwlowerid{den}_i}
\right)^{\ocwlowerid{power}_i}
\end{equation} *)
type power = { num : int; den : int; power : int }
type factor = power list
+ (* Compute the product of two color flows. *)
val factor : t -> t -> factor
val zero : factor
+ (* Take a list of color flows and compute a table of all
+ squares and interferences. *)
+ val factor_table : t list -> factor array array
+
module Test : Test
end
module Flow : Flow
(* \thocwmodulesection{Vertex Color Flows} *)
-(* The datatypes [Arrow.free] and [Arrow.factor] will be used as
- building blocks for [Birdtracks.t] below. *)
-
-module type Arrow =
- sig
-
- (* For fundamental and adjoint representations, the endpoints
- of arrows are uniquely specified by a vertex (which will
- be represented by a number). For representations with more
- than one outgoing or incoming arrow, we need an additional index.
- This is abrcated in the [endpoint] type. *)
- type endpoint
-
- (* Endpoints can be the the tip or tail of an arrow or a ghost.
- Currently, we use the types for illustration only, but we
- might eventually try to make them abstract for additional
- safety.. *)
- type tip = endpoint
- type tail = endpoint
- type ghost = endpoint
-
- (* The position of the endpoint is encoded as an integer, which
- can be mapped, if necessary. *)
- val position : endpoint -> int
- val relocate : (int -> int) -> endpoint -> endpoint
-
- (* An [Arrow.t] is either a genuine arrow or a ghost. *)
- type ('tail, 'tip, 'ghost) t =
- | Arrow of 'tail * 'tip
- | Ghost of 'ghost
-
- (* $\epsilon_{i_1i_2\cdots i_n}$ and $\bar\epsilon_{i_1i_2\cdots i_n}$
- are represented by lists~$\lbrack i_1; i_2; \ldots; i_n \rbrack$. *)
- type 'tip eps = 'tip list
- type 'tail eps_bar = 'tail list
-
- (* We distuish [free] arrows, $\epsilon$s and $\bar\epsilon$s
- that must not contain
- summation indices from [factor]s that may. Indices are
- opaque. [('tail, 'tip, 'ghost) t] has been defined polymorphic
- above so that we can use richer ['tail], ['tip] and ['ghost] in
- [factor] to identify summation indices.. *)
- type free = (tail, tip, ghost) t
- type free_eps = tip eps
- type free_eps_bar = tail eps_bar
- type factor
- type factor_eps
- type factor_eps_bar
-
- (* Useful for testing compatibility when adding terms. *)
- val tips : free -> tip list
- val tips_eps : free_eps -> tip list
- val tails : free -> tail list
- val tails_eps_bar : free_eps_bar -> tail list
-
- (* For debugging, logging, etc. *)
- val free_to_string : free -> string
- val free_eps_to_string : free_eps -> string
- val free_eps_bar_to_string : free_eps_bar -> string
- val factor_to_string : factor -> string
- val factor_eps_to_string : factor_eps -> string
- val factor_eps_bar_to_string : factor_eps_bar -> string
-
- (* Change the [endpoint]s in a [free] arrow. *)
- val map : (endpoint -> endpoint) -> free -> free
-
- (* Turn the [endpoint]s satisfying the predicate into a
- left or right hand side summation index. Left and right
- refer to the two factors in a product and
- we must only match arrows with [endpoint]s in both
- factors, not double lines on either side.
- Typically, the predicate will be set up to select only the
- summation indices that appear on both sides.*)
-
- val to_left_factor : (endpoint -> bool) -> free -> factor
- val to_left_factor_eps : (endpoint -> bool) -> free_eps -> factor_eps
- val to_left_factor_eps_bar : (endpoint -> bool) -> free_eps_bar -> factor_eps_bar
- val to_right_factor : (endpoint -> bool) -> free -> factor
- val to_right_factor_eps : (endpoint -> bool) -> free_eps -> factor_eps
- val to_right_factor_eps_bar : (endpoint -> bool) -> free_eps_bar -> factor_eps_bar
-
- (* The incomplete inverse [of_factor] raises an exception
- if there are remaining summation indices. [is_free] can
- be used to check first. *)
- val of_factor : factor -> free
- val of_factor_eps : factor_eps -> free_eps
- val of_factor_eps_bar : factor_eps_bar -> free_eps_bar
- val is_free : factor -> bool
- val is_free_eps : factor_eps -> bool
- val is_free_eps_bar : factor_eps_bar -> bool
-
- (* Return all the endpoints of the arrow that have a [position]
- encoded as a negative integer. These are treated as summation
- indices in our applications. *)
- val negatives : free -> endpoint list
- val negatives_eps : free_eps -> endpoint list
- val negatives_eps_bar : free_eps_bar -> endpoint list
-
- (* We will need to test whether an arrow represents a ghost. *)
- val is_ghost : free -> bool
-
- (* An arrow looping back to itself. *)
- val is_tadpole : factor -> bool
-
-(* Merging an arrow with another arrow, $\epsilon$ or $\bar\epsilon$
- can give a variety of results: *)
-
- type merge =
- | Match of factor (* a tip fits the other's tail: make one arrow out of two *)
- | Ghost_Match (* two matching ghosts *)
- | Loop_Match (* both tips fit both tails: drop the arrows *)
- | Mismatch (* ghost meets arrow: error *)
- | No_Match (* nothing to be done *)
-
- val merge_arrow_arrow : factor -> factor -> merge
-
-(* We can narrow this for $\epsilon$ and $\bar\epsilon$,
- where [Loop_Match] and [Ghost_Match] are impossible! *)
-
- type 'a merge_eps =
- | Match_Eps of 'a (* a tip fits the other's tail: make one arrow out of two *)
- | Mismatch_Eps (* ghost meets arrow: error *)
- | No_Match_Eps (* nothing to be done *)
-
- val merge_arrow_eps : factor -> factor_eps -> factor_eps merge_eps
- val merge_arrow_eps_bar : factor -> factor_eps_bar -> factor_eps_bar merge_eps
-
-(* In order to merge an~$\epsilon$ with an $\bar\epsilon$, we use
- \begin{equation}
- \forall n, N \in\mathbf{N}, 2\le n \le N:\;
- \epsilon_{i_1i_2\cdots i_n} \bar\epsilon^{j_1j_2\cdots j_n}
- = \sum_{\sigma\in S_n} (-1)^{\varepsilon(\sigma)}
- \delta_{i_1}^{\sigma(j_1)}
- \delta_{i_2}^{\sigma(j_2)}
- \cdots
- \delta_{i_n}^{\sigma(j_n)}\,,
- \end{equation}
- where~$N=\delta_i^i$ is the dimension, to replace the pair by two lists of
- list of arrows: the first corresponding to the even permutations, the
- second to the odd ones. *)
-
-(* Return [None], if the rank of $\epsilon$ and $\bar\epsilon$ don't match. *)
-
- val merge_eps_eps_bar : factor_eps -> factor_eps_bar -> (factor list list * factor list list) option
-
-(* Break up an arrow [tee a (i => j) -> [i => a; a => j]], i.\,e.~insert
- a gluon. Returns an empty list for a ghost and raises an exception
- for~$\epsilon$ and~$\bar\epsilon$. *)
- val tee : int -> free -> free list
-
-(* [dir i j arrow] returns the direction of the arrow relative to [j => i].
- Returns 0 for a ghost and raises an exception for~$\epsilon$
- and~$\bar\epsilon$. *)
- val dir : int -> int -> free -> int
-
-(* It's intuitive to use infix operators to construct the lines. *)
- val single : endpoint -> endpoint -> free
- val double : endpoint -> endpoint -> free list
- val ghost : endpoint -> free
-
- module Infix : sig
-
- (* [single i j] or [i => j] creates a single line from [i] to [j] and
- [i ==> j] is a shorthard for [[i => j]]. *)
- val (=>) : int -> int -> free
- val (==>) : int -> int -> free list
-
- (* [double i j] or [i <=> j] creates a double line from [i] to [j]
- and back. *)
- val (<=>) : int -> int -> free list
-
- (* Single lines with subindices at the tip and/or tail *)
- val (>=>) : int * int -> int -> free
- val (=>>) : int -> int * int -> free
- val (>=>>) : int * int -> int * int -> free
-
- (* [?? i] creates a ghost at [i]. *)
- val (??) : int -> free
-
- (* NB: I wanted to use [~~] instead of [??], but ocamlweb can't handle
- operators starting with [~] in the index properly. *)
-
- end
-
- val epsilon : int list -> free_eps
- val epsilon_bar : int list -> free_eps_bar
-
- (* [chain [1;2;3]] is a shorthand for [[1 => 2; 2 => 3]] and
- [cycle [1;2;3]] for [[1 => 2; 2 => 3; 3 => 1]]. Other lists
- and edge cases are handled in the natural way. *)
- val chain : int list -> free list
- val cycle : int list -> free list
-
- module Test : Test
-
- (* Pretty printer for the toplevel. *)
- val pp_free : Format.formatter -> free -> unit
- val pp_factor : Format.formatter -> factor -> unit
-
- end
-
-module Arrow : Arrow
-
-(* Possible color flows for a single propagator, as currently
- supported by WHIZARD. *)
-module type Propagator =
- sig
- type cf_in = int
- type cf_out = int
- type t = W | I of cf_in | O of cf_out | IO of cf_in * cf_out | G
- val to_string : t -> string
- end
-
-module Propagator : Propagator
-
-(* Implement birdtracks operations as generally as possible.
- Below, the signature will be extended with group specific
- generators for $\mathrm{SU}(N_C)$ and $\mathrm{U}(N_C)$ and
- even $N_C=3$. *)
-module type Birdtracks =
- sig
- type t
-
- (* Strip out redundancies. *)
- val canonicalize : t -> t
-
- (* Debugging, logging, etc. *)
- val to_string : t -> string
-
- (* Test for trivial color flows that are just a number. *)
- val trivial : t -> bool
-
- (* Test for vanishing coefficients. *)
- val is_null : t -> bool
-
- (* Purely numeric factors, implemented as Laurent polynomials
- (cf.~[Algebra.Laurent] in~$N_C$ with complex rational
- coefficients. *)
- val const : Algebra.Laurent.t -> t
- val null : t (* $0$ *)
- val one : t (* $1$ *)
- val two : t (* $2$ *)
- val half : t (* $1/2$ *)
- val third : t (* $1/3$ *)
- val minus : t (* $-1$ *)
- val int : int -> t (* $n$ *)
- val fraction : int -> t (* $1/n$ *)
- val nc : t (* $N_C$ *)
- val over_nc : t (* $1/N_C$ *)
- val imag : t (* $\ii$ *)
-
- (* Shorthand: $\{(c_i,p_i)\}_i\to \sum_i c_i (N_C)^{p_i}$*)
- val ints : (int * int) list -> t
-
- val scale : Algebra.QC.t -> t -> t
-
- val sum : t list -> t
- val diff : t -> t -> t
- val times : t -> t -> t
- val multiply : t list -> t
-
- (* For convenience, here are infix versions of the above operations. *)
- module Infix : sig
- val ( +++ ) : t -> t -> t
- val ( --- ) : t -> t -> t
- val ( *** ) : t -> t -> t
- end
-
- (* We can compute the $f_{abc}$ and $d_{abc}$ invariant tensors
- from the generators of an arbitrary representation:
- \begin{subequations}
- \begin{align}
- f_{a_1a_2a_3} &=
- - \ii \tr\left(T_{a_1}\left\lbrack T_{a_2},T_{a_3}\right\rbrack_-\right)
- = - \ii \tr\left(T_{a_1}T_{a_2}T_{a_3}\right)
- + \ii \tr\left(T_{a_1}T_{a_3}T_{a_2}\right) \\
- d_{a_1a_2a_3} &=
- \tr\left(T_{a_1}\left\lbrack T_{a_2},T_{a_3}\right\rbrack_+\right)
- = \tr\left(T_{a_1}T_{a_2}T_{a_3}\right)
- + \tr\left(T_{a_1}T_{a_3}T_{a_2}\right)\,
- \end{align}
- \end{subequations}
- assuming the normalization $ \tr(T_aT_b) = \delta_{ab}$.
-
- NB: this uses the summation indices $-1$, $-2$ and $-3$. Therefore
- it \emph{must not} appear unevaluated more than once in a product! *)
- val f_of_rep : (int -> int -> int -> t) -> int -> int -> int -> t
- val d_of_rep : (int -> int -> int -> t) -> int -> int -> int -> t
-
- (* Rename the indices of endpoints in a birdtrack. *)
- val relocate : (int -> int) -> t -> t
-
- (* [fuse nc vertex children] use the color flows in the [vertex]
- to combine the color flows in the incoming [children] and return
- the color flows for outgoing particle together with their weights. *)
- val fuse : int -> t -> Propagator.t list -> (Algebra.QC.t * Propagator.t) list
-
- module Test : Test
-
- (* Pretty printer for the toplevel. *)
- val pp : Format.formatter -> t -> unit
- end
-
-module Birdtracks : Birdtracks
-
-module type SU3 =
- sig
- include Birdtracks
- val delta3 : int -> int -> t
- val delta8 : int -> int -> t
- val delta8_loop : int -> int -> t
- val gluon : int -> int -> t
- val delta6 : int -> int -> t
- val delta10 : int -> int -> t
- val t : int -> int -> int -> t
- val f : int -> int -> int -> t
- val d : int -> int -> int -> t
- val epsilon : int list -> t
- val epsilon_bar : int list -> t
- val t8 : int -> int -> int -> t
- val t6 : int -> int -> int -> t
- val t10 : int -> int -> int -> t
- val k6 : int -> int -> int -> t
- val k6bar : int -> int -> int -> t
- val delta_of_tableau : int Young.tableau -> int -> int -> t
- val t_of_tableau : int Young.tableau -> int -> int -> int -> t
- end
-
-module SU3 : SU3
-module Vertex : SU3
+module Vertex : module type of SU3
Index: trunk/omega/src/omega_SM_VM.ml
===================================================================
--- trunk/omega/src/omega_SM_VM.ml (revision 8899)
+++ trunk/omega/src/omega_SM_VM.ml (revision 8900)
@@ -1,26 +1,26 @@
(* omega_SM_VM.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
cf. main AUTHORS file
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.VM)(Modellib_SM.SM(Modellib_SM.SM_no_anomalous))
+module O = Omega.Mixed23(Target_VM.Make)(Modellib_SM.SM(Modellib_SM.SM_no_anomalous))
let _ = O.main ()
Index: trunk/omega/src/feynmp.ml
===================================================================
--- trunk/omega/src/feynmp.ml (revision 0)
+++ trunk/omega/src/feynmp.ml (revision 8900)
@@ -0,0 +1,270 @@
+(* feynmp.ml --
+
+ Copyright (C) 1999-2023 by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+
+ WHIZARD is free software; you can redistribute it and/or modify it
+ under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ WHIZARD is distributed in the hope that it will be useful, but
+ WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
+
+module type T =
+ sig
+ type amplitudes
+ val amplitudes_to_channel : bool -> amplitudes -> out_channel -> unit
+ val amplitudes_sans_color_to_channel : bool -> amplitudes -> out_channel -> unit
+ val amplitudes_color_only_to_channel : bool -> amplitudes -> out_channel -> unit
+ val amplitudes : bool -> string -> amplitudes -> unit
+ val amplitudes_sans_color : bool -> string -> amplitudes -> unit
+ val amplitudes_color_only : bool -> string -> amplitudes -> unit
+ end
+
+let (<<) f g x = f (g x)
+let (>>) f g x = g (f x)
+
+module Make (FM : Fusion.Maker) (P : Momentum.T) (M : Model.T) : T
+ with type amplitudes = Fusion.Multi(FM)(P)(M).amplitudes =
+ struct
+
+ module F = FM(P)(M)
+ module CF = Fusion.Multi(FM)(P)(M)
+ module SCM = Orders.Slice(Colorize.It(M))
+
+ type amplitudes = CF.amplitudes
+
+ let opt_array_to_list a =
+ let rec opt_array_to_list' acc i a =
+ if i < 0 then
+ acc
+ else
+ begin match a.(i) with
+ | None -> opt_array_to_list' acc (pred i) a
+ | Some x -> opt_array_to_list' (x :: acc) (pred i) a
+ end in
+ opt_array_to_list' [] (Array.length a - 1) a
+
+ let amplitudes_by_flavor amplitudes =
+ List.map opt_array_to_list (Array.to_list (CF.process_table amplitudes))
+
+(* Take a [CF.amplitude list] assumed to correspond to the same
+ external states after stripping the color and return a
+ pair of the list of external particles and the corresponding
+ Feynman diagrams without color. *)
+
+ let wf1 amplitude =
+ match F.externals amplitude with
+ | wf :: _ -> wf
+ | [] -> failwith "Omega.forest_sans_color: no external particles"
+
+ let uniq l =
+ ThoList.uniq (List.sort compare l)
+
+ let forest_sans_color = function
+ | amplitude :: _ as amplitudes ->
+ let externals = F.externals amplitude in
+ let prune_color wf =
+ (F.flavor_sans_color wf, F.momentum_list wf) in
+ let prune_color_and_couplings (wf, c) =
+ (prune_color wf, None) in
+ (List.map prune_color externals,
+ uniq
+ (List.map
+ (fun t ->
+ Tree.canonicalize
+ (Tree.map prune_color_and_couplings prune_color t))
+ (ThoList.flatmap (fun a -> F.forest (wf1 a) a) amplitudes)))
+ | [] -> ([], [])
+
+ let dag_sans_color = function
+ | amplitude :: _ as amplitudes ->
+ let prune a = a in
+ List.map prune amplitudes
+ | [] -> []
+
+ let p2s p =
+ if p >= 0 && p <= 9 then
+ string_of_int p
+ else if p <= 36 then
+ String.make 1 (Char.chr (Char.code 'A' + p - 10))
+ else
+ "_"
+
+ let format_p wf =
+ String.concat "" (List.map p2s (F.momentum_list wf))
+
+ let variable wf =
+ M.flavor_to_string (F.flavor_sans_color wf) ^ "[" ^ format_p wf ^ "]"
+
+ let variable' wf =
+ SCM.flavor_to_TeX (F.flavor wf) ^ "(" ^ format_p wf ^ ")"
+
+ let feynmf_style tex propagator color =
+ { Tree.style =
+ begin match propagator with
+ | Coupling.Prop_Feynman
+ | Coupling.Prop_Gauge _ ->
+ begin match color with
+ | Color.AdjSUN _ -> Some ("gluon", tex)
+ | _ -> Some ("boson", tex)
+ end
+ | Coupling.Prop_Col_Feynman -> Some ("gluon", tex)
+ | Coupling.Prop_Unitarity
+ | Coupling.Prop_Rxi _ -> Some ("dbl_wiggly", tex)
+ | Coupling.Prop_Spinor
+ | Coupling.Prop_ConjSpinor -> Some ("fermion", tex)
+ | _ -> None
+ end;
+ Tree.rev =
+ begin match propagator with
+ | Coupling.Prop_Spinor -> true
+ | Coupling.Prop_ConjSpinor -> false
+ | _ -> false
+ end;
+ Tree.label = None;
+ Tree.tension = None }
+
+ let header incoming outgoing =
+ "$ " ^
+ String.concat " "
+ (List.map (SCM.flavor_to_TeX << F.flavor) incoming) ^
+ " \\to " ^
+ String.concat " "
+ (List.map (SCM.flavor_to_TeX << SCM.conjugate << F.flavor) outgoing) ^
+ " $"
+
+ let header_sans_color incoming outgoing =
+ "$ " ^
+ String.concat " "
+ (List.map (M.flavor_to_TeX << fst) incoming) ^
+ " \\to " ^
+ String.concat " "
+ (List.map (M.flavor_to_TeX << M.conjugate << fst) outgoing) ^
+ " $"
+
+ let diagram incoming tree =
+ let fmf wf =
+ let f = F.flavor wf in
+ feynmf_style "" (SCM.propagator f) (SCM.color f) in
+ Tree.map
+ (fun (n, _) ->
+ let n' = fmf n in
+ if List.mem n incoming then
+ { n' with Tree.rev = not n'.Tree.rev }
+ else
+ n')
+ (fun l ->
+ if List.mem l incoming then
+ l
+ else
+ F.conjugate l)
+ tree
+
+ let diagram_sans_color incoming tree =
+ let fmf (f, p) =
+ feynmf_style "" (M.propagator f) (M.color f) in
+ Tree.map
+ (fun (n, c) ->
+ let n' = fmf n in
+ if List.mem n incoming then
+ { n' with Tree.rev = not n'.Tree.rev }
+ else
+ n')
+ (fun (f, p) ->
+ if List.mem (f, p) incoming then
+ (f, p)
+ else
+ (M.conjugate f, p))
+ tree
+
+ let feynmf_set amplitude =
+ match F.externals amplitude with
+ | wf1 :: wf2 :: wfs ->
+ let incoming = [wf1; wf2] in
+ { Tree.header = header incoming wfs;
+ Tree.incoming = incoming;
+ Tree.diagrams =
+ List.map (diagram incoming) (F.forest wf1 amplitude) }
+ | _ -> failwith "less than two external particles"
+
+ let feynmf_set_sans_color (externals, trees) =
+ match externals with
+ | wf1 :: wf2 :: wfs ->
+ let incoming = [wf1; wf2] in
+ { Tree.header = header_sans_color incoming wfs;
+ Tree.incoming = incoming;
+ Tree.diagrams =
+ List.map (diagram_sans_color incoming) trees }
+ | _ -> failwith "less than two external particles"
+
+ let feynmf_set_sans_color_empty (externals, trees) =
+ match externals with
+ | wf1 :: wf2 :: wfs ->
+ let incoming = [wf1; wf2] in
+ { Tree.header = header_sans_color incoming wfs;
+ Tree.incoming = incoming;
+ Tree.diagrams = [] }
+ | _ -> failwith "less than two external particles"
+
+ let uncolored_colored amplitudes =
+ { Tree.outer = feynmf_set_sans_color (forest_sans_color amplitudes);
+ Tree.inner = List.map feynmf_set amplitudes }
+
+ let uncolored_only amplitudes =
+ { Tree.outer = feynmf_set_sans_color (forest_sans_color amplitudes);
+ Tree.inner = [] }
+
+ let colored_only amplitudes =
+ { Tree.outer = feynmf_set_sans_color_empty (forest_sans_color amplitudes);
+ Tree.inner = List.map feynmf_set amplitudes }
+
+ let momentum_to_TeX (_, p) =
+ String.concat "" (List.map p2s p)
+
+ let wf_to_TeX (f, _ as wf) =
+ M.flavor_to_TeX f ^ "(" ^ momentum_to_TeX wf ^ ")"
+
+ let amplitudes latex name amplitudes =
+ Tree.feynmf_sets_wrapped latex name
+ wf_to_TeX momentum_to_TeX variable' format_p
+ (List.map uncolored_colored (amplitudes_by_flavor amplitudes))
+
+ let amplitudes_sans_color latex name amplitudes =
+ Tree.feynmf_sets_wrapped latex name
+ wf_to_TeX momentum_to_TeX variable' format_p
+ (List.map uncolored_only (amplitudes_by_flavor amplitudes))
+
+ let amplitudes_color_only latex name amplitudes =
+ Tree.feynmf_sets_wrapped latex name
+ wf_to_TeX momentum_to_TeX variable' format_p
+ (List.map colored_only (amplitudes_by_flavor amplitudes))
+
+ let amplitudes_to_channel latex amplitudes channel =
+ Tree.feynmf_sets_wrapped_to_channel latex channel
+ wf_to_TeX momentum_to_TeX variable' format_p
+ (List.map uncolored_colored (amplitudes_by_flavor amplitudes))
+
+ let amplitudes_sans_color_to_channel latex amplitudes channel =
+ Tree.feynmf_sets_wrapped_to_channel latex channel
+ wf_to_TeX momentum_to_TeX variable' format_p
+ (List.map uncolored_only (amplitudes_by_flavor amplitudes))
+
+ let amplitudes_color_only_to_channel latex amplitudes channel =
+ Tree.feynmf_sets_wrapped_to_channel latex channel
+ wf_to_TeX momentum_to_TeX variable' format_p
+ (List.map colored_only (amplitudes_by_flavor amplitudes))
+
+ end
+
+
Index: trunk/omega/src/young.ml
===================================================================
--- trunk/omega/src/young.ml (revision 8899)
+++ trunk/omega/src/young.ml (revision 8900)
@@ -1,276 +1,284 @@
(* young.ml --
Copyright (C) 2022- by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-(* Avoid refering to [Pervasives.compare], because [Pervasives] will
- become [Stdlib.Pervasives] in O'Caml 4.07 and [Stdlib] in O'Caml 4.08. *)
-let pcompare = compare
-
type diagram = int list
type 'a tableau = 'a list list
(* Not exposed. Just for documentation. *)
type 'a table = 'a option array array
(* The following three are candidates for [ThoList]. *)
let rec sum = function
| [] -> 0
| n :: rest -> n + sum rest
let rec product = function
| [] -> 1
| n :: rest -> n * product rest
(* Test a predicate for each pair of consecutive elements of a list.
Trivially true for empty and one-element lists. *)
let rec for_all_pairs predicate = function
| [] | [_] -> true
| a1 :: (a2 :: _ as a_list) ->
if not (predicate a1 a2) then
false
else
for_all_pairs predicate a_list
-let decreasing l = for_all_pairs (fun a1 a2 -> pcompare a1 a2 > 0) l
-let increasing l = for_all_pairs (fun a1 a2 -> pcompare a1 a2 < 0) l
-let non_increasing l = for_all_pairs (fun a1 a2 -> pcompare a1 a2 >= 0) l
-let non_decreasing l = for_all_pairs (fun a1 a2 -> pcompare a1 a2 <= 0) l
+let decreasing l = for_all_pairs (fun a1 a2 -> compare a1 a2 > 0) l
+let increasing l = for_all_pairs (fun a1 a2 -> compare a1 a2 < 0) l
+let non_increasing l = for_all_pairs (fun a1 a2 -> compare a1 a2 >= 0) l
+let non_decreasing l = for_all_pairs (fun a1 a2 -> compare a1 a2 <= 0) l
+
+let non_increasing_never_zero l =
+ for_all_pairs (fun a1 a2 -> a2 > 0 && compare a1 a2 >= 0) l
-let valid_diagram = non_increasing
+let valid_diagram = non_increasing_never_zero
let diagram_rows d =
List.length d
let diagram_columns = function
| [] -> 0
| nc :: _ -> nc
let take_column d =
let rec take_column' len acc = function
| [] -> (len, List.rev acc)
| cols :: rest ->
if cols <= 1 then
take_column' (succ len) acc rest
else
take_column' (succ len) (pred cols :: acc) rest in
take_column' 0 [] d
let conjugate_diagram_new d =
let rec conjugate_diagram' rows =
match take_column rows with
| n, [] -> [n]
| n, rest -> n :: conjugate_diagram' rest in
conjugate_diagram' d
let tableau_rows t =
List.length t
let tableau_columns = function
| [] -> 0
| row :: _ -> List.length row
let num_cells_diagram d =
sum d
let cells_tableau t =
List.flatten t
let num_cells_tableau t =
List.fold_left (fun acc row -> acc + List.length row) 0 t
let diagram_of_tableau t =
List.map List.length t
let tableau_of_diagram cell d =
List.map (ThoList.clone cell) d
(* Note that the first index counts the rows and the second the columns! *)
let array_of_tableau t =
let nr = tableau_rows t
and nc = tableau_columns t in
let a = Array.make_matrix nr nc None in
List.iteri
(fun ir -> List.iteri (fun ic cell -> a.(ir).(ic) <- Some cell))
t;
a
let transpose_array a =
let nr = Array.length a in
if nr <= 0 then
invalid_arg "Young.transpose_array"
else
let nc = Array.length a.(0) in
let a' = Array.make_matrix nc nr None in
for ic = 0 to pred nc do
for ir = 0 to pred nr do
a'.(ic).(ir) <- a.(ir).(ic)
done
done;
a'
let list_of_array_row a =
let n = Array.length a in
let rec list_of_array_row' ic =
if ic >= n then
[]
else
match a.(ic) with
| None -> []
| Some cell -> cell :: list_of_array_row' (succ ic) in
list_of_array_row' 0
let tableau_of_array a =
Array.fold_right (fun row acc -> list_of_array_row row :: acc) a []
let conjugate_tableau t =
array_of_tableau t |> transpose_array |> tableau_of_array
let conjugate_diagram d =
tableau_of_diagram () d |> conjugate_tableau |> diagram_of_tableau
let valid_tableau t =
valid_diagram (diagram_of_tableau t)
let semistandard_tableau t =
let rows = t
and columns = conjugate_tableau t in
valid_tableau t
&& List.for_all non_decreasing rows
&& List.for_all increasing columns
let standard_tableau ?offset t =
- match List.sort pcompare (cells_tableau t) with
+ match List.sort compare (cells_tableau t) with
| [] -> true
| cell :: _ as cell_list ->
(match offset with None -> true | Some o -> cell = o)
&& for_all_pairs (fun c1 c2 -> c2 = c1 + 1) cell_list
&& semistandard_tableau t
+let map f t =
+ List.map (List.map f) t
+
+let tableau_to_string to_string t =
+ ThoList.to_string (ThoList.to_string to_string) t
+
+let pp fmt y =
+ Format.fprintf fmt "%s" (tableau_to_string string_of_int y)
+
let hook_lengths_table d =
let nr = diagram_rows d
and nc = diagram_columns d in
if min nr nc <= 0 then
invalid_arg "Young.hook_lengths_table"
else
let a = array_of_tableau (tableau_of_diagram 0 d) in
let cols = Array.of_list d
and rows = transpose_array a |> tableau_of_array
|> diagram_of_tableau |> Array.of_list in
for ir = 0 to pred nr do
for ic = 0 to pred cols.(ir) do
a.(ir).(ic) <- Some (rows.(ic) - ir + cols.(ir) - ic - 1)
done
done;
a
(* \begin{dubious}
The following products and factorials can easily overflow,
even if the final ratio is a smallish number. We can avoid
this by representing them as lists of factors (or maps from
factors to powers). The ratio can be computed by first
cancelling all common factors and multiplying the remaining
factors at the very end.
\end{dubious} *)
let hook_lengths_product d =
let nr = diagram_rows d
and nc = diagram_columns d in
if min nr nc <= 0 then
0
else
let cols = Array.of_list d
and rows = Array.of_list (conjugate_diagram d) in
let n = ref 1 in
for ir = 0 to pred nr do
for ic = 0 to pred cols.(ir) do
n := !n * (rows.(ic) - ir + cols.(ir) - ic - 1)
done
done;
!n
let num_standard_tableaux d =
let num = Combinatorics.factorial (num_cells_diagram d)
and den = hook_lengths_product d in
if num mod den <> 0 then
failwith "Young.num_standard_tableaux"
else
num / den
(* Note that [hook_lengths_product] calls [conjugate_diagram]
and this calls it again.
This is wasteful, but probably no big deal for our applications. *)
let normalization d =
let num =
product (List.map Combinatorics.factorial (d @ conjugate_diagram d))
and den = hook_lengths_product d in
(num, den)
module type Test =
sig
val suite : OUnit.test
val suite_long : OUnit.test
end
module Test =
struct
open OUnit
let random_int ratio =
truncate (Random.float ratio +. 0.5)
let random_diagram ?(ratio=1.0) rows =
let rec random_diagram' acc row cols =
if row >= rows then
acc
else
let cols' = cols + random_int ratio in
random_diagram' (cols' :: acc) (succ row) cols' in
random_diagram' [] 0 (1 + random_int ratio)
let suite_hook_lengths_product =
"hook_lengths_product" >:::
[ "[4;3;2]" >::
(fun () -> assert_equal 2160 (hook_lengths_product [4; 3; 2])) ]
let suite_num_standard_tableaux =
"num_standard_tableaux" >:::
[ "[4;3;2]" >::
(fun () -> assert_equal 168 (num_standard_tableaux [4; 3; 2])) ]
let suite_normalization =
"normalization" >:::
[ "[2;1]" >::
(fun () -> assert_equal (4, 3) (normalization [2; 1])) ]
let suite =
"Young" >:::
[suite_hook_lengths_product;
suite_num_standard_tableaux;
suite_normalization]
let suite_long =
"Young long" >:::
[]
end
Index: trunk/omega/src/UFO.mli
===================================================================
--- trunk/omega/src/UFO.mli (revision 8899)
+++ trunk/omega/src/UFO.mli (revision 8900)
@@ -1,111 +1,116 @@
(* vertex.mli --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
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. *)
val parse_string : string -> UFO_syntax.t
val parse_file : string -> UFO_syntax.t
(* These are the contents of the Python files after lexical
analysis as context-free variable declarations, before
any semantic interpretation. *)
module type Files =
sig
type t = private
{ particles : UFO_syntax.t;
couplings : UFO_syntax.t;
coupling_orders : UFO_syntax.t;
vertices : UFO_syntax.t;
lorentz : UFO_syntax.t;
parameters : UFO_syntax.t;
propagators : UFO_syntax.t;
decays : UFO_syntax.t }
val parse_directory : string -> t
end
type t
exception Unhandled of string
-module Model : Model.T
+(* \begin{dubious}
+ If we want we can switch the implementation from
+ [type init = string * string list] to
+ [type init = string * flag list] with a structured [flag] type.
+ \end{dubious} *)
+module Model : Model.Mutable with type init = string * string list
val parse_directory : string -> t
module type Fortran_Target =
sig
(* [fuse c v s fl g wfs ps fusion]
fuses the wavefunctions named [wfs] with momenta named [ps]
using the vertex named [v] with legs reordered according to [fusion].
The overall coupling constant named [g] is multiplied by the rational
coefficient [c]. The list of spins [s] and the fermion
lines [fl] are used for selecting the appropriately
transformed version of the vertex [v]. *)
val fuse :
Algebra.QC.t -> string ->
Coupling.lorentzn -> Coupling.fermion_lines ->
string -> string list -> string list -> Coupling.fusen -> unit
val lorentz_module :
?only:Sets.String.t -> ?name:string ->
?fortran_module:string -> ?parameter_module:string ->
Format_Fortran.formatter -> unit -> unit
end
module Targets :
sig
module Fortran : Fortran_Target
end
(* Export some functions for testing: *)
module Propagator_UFO :
sig
type t = (* private *)
{ name : string;
numerator : UFOx.Lorentz.t;
denominator : UFOx.Lorentz.t }
end
module Propagator :
sig
type t = (* private *)
{ name : string;
spins : Coupling.lorentz * Coupling.lorentz;
numerator : UFO_Lorentz.t;
denominator : UFO_Lorentz.t;
variables : string list }
val of_propagator_UFO : ?majorana:bool -> Propagator_UFO.t -> t
val transpose : t -> t
end
module type Test =
sig
val suite : OUnit.test
end
module Test : Test
Index: trunk/omega/src/DAG.mli
===================================================================
--- trunk/omega/src/DAG.mli (revision 8899)
+++ trunk/omega/src/DAG.mli (revision 8900)
@@ -1,361 +1,419 @@
(* DAG.mli --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
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. *)
(* This datastructure describes large collections of trees with
many shared nodes. The sharing of nodes is semantically irrelevant,
but can turn a factorial complexity to exponential complexity.
Note that [DAG] implements only a very specialized subset of Directed
Acyclical Graphs (DAGs). *)
-(* If~$T(n,D)$ denotes the set of all binary trees with root~$n$
- encoded in~$D$, while
+(* \thocwmodulesection{Forests} *)
+
+(* A forest is a set of trees and we want to represent
+ it efficiently by a DAG. However, we will not handle arbitrary
+ forests here, but only such forests, where \emph{all} subtrees of
+ trees in the forest are also members of the forest.
+
+ In this case, we can represent
+ a forest~$F$ over a set of nodes and a set of edges
+ as a map from the set of nodes~$N$ to the direct product
+ of the set of edges~$E$ and the set
\begin{equation}
- O(n,D)=\{(e_1,n_1,n_1'), \ldots, (e_k,n_k,n_k')\}
+ t(N) = \bigcup_{n=0}^\infty N^{\times n}
+ = \emptyset \cup N \cup N\times N \cup N\times N\times N \cup \ldots
\end{equation}
- denotes the set of all~\emph{offspring} of~$n$ in~$D$,
- and~$\text{tree}(e,t,t')$ denotes the binary tree formed by
- joining the binary trees~$t$ and~$t'$ with the label~$e$, then
- \begin{multline}
- T(n,D) = \bigl\{ \text{tree}(e_i,t_i,t_i')\,\bigl|\,
- (e_i,t_i,t_i')\in\{e_1\}\times T(n_1,D)\times T(n_1',D) \cup\ldots\\
- \ldots\cup\{e_k\}\times T(n_k,D)\times T(n_k',D) \bigr\}
- \end{multline}
- is the recursive definition of the binary trees encoded in~$D$.
- It is obvious how this definitions translates to $n$-ary trees
- (including trees with mixed arity). *)
+ of tuples of nodes augmented
+ by a special element~$\bot$ (``bottom'').
+ \begin{equation}
+ \begin{aligned}
+ F: N &\to (E \times t(N)) \cup \{\bot\} \\
+ n &\mapsto \begin{cases}
+ \left(e, (n'_1,n'_2,\ldots)\right) \\
+ \bot
+ \end{cases}
+ \end{aligned}
+ \end{equation}
+ Nodes that are mapped to~$\bot$ are called \emph{leaf} nodes and
+ nodes that do not appear in any~$F(n)$ are called \emph{root}
+ nodes. There are as many trees in a given forest~$F$ as there are
+ nodes.
+ Our trees are Feynman tree diagrams and each forest~$F$
+ consists of one diagram and its subdiagrams.
-(* \thocwmodulesection{Forests} *)
+ For convenience, we require edges and nodes to be members of ordered
+ sets. If the nodes are ordered, cycles can be detected easily
+ \begin{equation}
+ \forall n\in N:
+ \Bigl( \bigl( F(n) = (e, x) \bigr) \Rightarrow
+ \bigl( \forall n'\in x: n > n' \bigr) \Bigr)\,.
+ \end{equation}
+ Note that this requirement does \emph{not} exclude any trees.
+ Even if we consider only topological equivalence classes with
+ anonymous nodes and edges, we can always construct a canonical
+ labeling and order from the children of the nodes. E.\,g.~the depth
+ of the tree beneath a node provides a suitable labeling for
+ \emph{all} forests. However, in practical
+ applications, we will often have more efficient labelings and
+ orders at our disposal.
-(* We require edges and nodes to be members of ordered sets.
- The sematics of [compare] are compatible with [Pervasives.compare]:
+ The sematics of [compare] is expected to be compatible
+ with [Pervasives.compare]
+ (i.\,e.~[Stdlib.compare] on O'Caml 4.08 and later):
\begin{equation}
\ocwlowerid{compare}(x,y) =
\begin{cases}
-1 & \text{for $x<y$} \\
0 & \text{for $x=y$} \\
1 & \text{for $x>y$}
\end{cases}
- \end{equation}
- Note that this requirement does \emph{not} exclude any trees.
- Even if we consider only topological equivalence classes with
- anonymous nodes, we can always construct a canonical labeling
- and order from the children of the nodes. However, if practical
- applications, we will often have more efficient labelings and
- orders at our disposal. *)
+ \end{equation} *)
module type Ord =
sig
type t
val compare : t -> t -> int
end
-(* A forest~$F$ over a set of nodes and a set of edges
- is a map from the set of nodes~$N$, to the direct product
- of the set of edges~$E$ and the power set $2^N$ of~$N$ augmented
- by a special element~$\bot$ (``bottom'').
- \begin{equation}
- \begin{aligned}
- F: N &\to (E \times 2^N) \cup \{\bot\} \\
- n &\mapsto \begin{cases}
- (e, \{n'_1,n'_2,\ldots\}) \\
- \bot
- \end{cases}
- \end{aligned}
- \end{equation}
- The nodes are ordered so that cycles can be detected
- \begin{equation}
- \forall n\in N: F(n) = (e, x) \Rightarrow \forall n'\in x: n > n'
- \end{equation}
- A suitable function that exists for \emph{all} forests is the
- depth of the tree beneath a node.
-
- Nodes that are mapped to~$\bot$ are called \emph{leaf} nodes and
- nodes that do not appear in any~$F(n)$ are called \emph{root}
- nodes. There are as many trees in the forest as there are root
- nodes. *)
-
module type Forest =
sig
module Nodes : Ord
type node = Nodes.t
type edge
-(* A subset~$X\subset2^N$ of the powerset of the set of nodes. The
- members of~$X$ can be be characterized by a fixed number of members
- (e.\,g.~two for binary trees, as in QED). We can also have mixed arities
+(* A tuple of nodes. The most general realization is
+ [type children = node list], but we use a [Tuple.Mono]
+ or [Tuple.Poly] module for more specific
+ implementations, where the number of nodes is bounded from
+ below or above. For example to two for binary trees,
+ as in~$\phi^3$ or QED. We can also have mixed arities
(e.\,g.~two and three for QCD) or even arbitrary arities. However,
- in most cases, the members of~$X$ will have at least two members. *)
+ in most cases, there will be at least two children. *)
type children
(* This type abbreviation and order allow to apply the [Set.Make]
- functor to $E\times X$. *)
+ functor to $E\times t(N)$. *)
type t = edge * children
+
+(* In our implementation, we order by [children] and if they
+ agree, we disambiguate by [edge]. *)
val compare : t -> t -> int
(* Test a predicate for \emph{all} children. *)
val for_all : (node -> bool) -> t -> bool
(* [fold f (_, children) acc] will calculate
\begin{equation}
f (x_1, f(x_2, \cdots f(x_n,\ocwlowerid{acc})))
\end{equation}
where the [children] are $\{x_1,x_2,\ldots,x_n\}$.
There are slightly more efficient alternatives for fixed arity
(in particular binary), but we want to be general. *)
val fold : (node -> 'a -> 'a) -> t -> 'a -> 'a
end
+(* We will use modules from [Tuple] to implement arity constraints
+ for [Forest.children]. *)
+
module Forest : functor (PT : Tuple.Poly) ->
functor (N : Ord) -> functor (E : Ord) ->
Forest with module Nodes = N and type edge = E.t
and type node = N.t and type children = N.t PT.t
(* \thocwmodulesection{DAGs} *)
+(* A DAG will describe the recursive construction of one particle
+ off-shell wave functions (1POW). The nodes are therefore the 1POWs
+ and can be specified by a flavor and a momentum or a sum of external
+ momenta. Just as in [Forest], the edges are couplings and the leaf
+ nodes are external on-shell wave functions. However, each node can
+ now have more than one offspring, i.\,e.~combination of edge and children
+ or coupling and tuple of 1POWs. This factorizes the forest and
+ optimizes the code by common subexpression elimination.
+
+ If~$T(n,D)$ denotes the set of all binary trees with root~$n$
+ encoded in the DAG~$D$, while
+ \begin{equation}
+ O(n,D)=\{(e_1,n_1,n_1'), \ldots, (e_k,n_k,n_k')\}
+ \end{equation}
+ denotes the set of all~\emph{offspring} of~$n$ in~$D$,
+ and~$\text{tree}(e,t,t')$ denotes the binary tree formed by
+ joining the binary trees~$t$ and~$t'$ with the label~$e$, then
+ \begin{equation}
+ T(n,D) = \left\{ \text{tree}(e_i,t_i,t_i')\,\bigl|\,
+ (e_i,t_i,t_i')\in
+ \bigcup_{i=1}^k \{e_i\}\times T(n_i,D)\times T(n_i',D)\right\}
+ \end{equation}
+ is the recursive definition of the binary trees encoded by the DAG~$D$.
+ It is obvious how this definitions translates to $n$-ary trees
+ (including trees with mixed arity). *)
+
module type T =
sig
+(* When implementing modules of type [T], the type [node] will
+ be a [Ord.t] that allows us use [Map.Make] and [Set.Make] to
+ construct maps. In a functor [Forest -> T], the order from
+ [Forest.Node] will be used for ordering [node] in [T].
+ In particular, the equality of nodes in [add_node], [add_offspring],
+ [harvest], etc.{} below will be determined by [Forest.Node.compare]. *)
type node
+
+(* For [edge], we need no additional structure. *)
type edge
(* In the description of the function we assume for definiteness DAGs of
binary trees with [type children = node * node]. However, we will
also have implementations with [type children = node list] below. *)
(* Other possibilities include
[type children = V3 of node * node | V4 of node * node * node].
There's probable never a need to use sets with logarithmic
- access, but it is easy to add. *)
+ access, but it would be easy to add. *)
type children
type t
(* The empty DAG. *)
val empty : t
(* [add_node n dag] returns the DAG [dag] with the node [n].
- If the node [n] already exists in [dag], it is returned
+ If the node [n] already exists in [dag], [dag] is returned
unchanged. Otherwise [n] is added without offspring. *)
val add_node : node -> t -> t
(* [add_offspring n (e, (n1, n2)) dag] returns the DAG [dag]
with the node [n] and its offspring [n1] and [n2] with edge
label [e]. Each node can have an arbitrary number of offspring,
but identical offspring are added only once. In order
to prevent cycles, [add_offspring] requires both [n>n1] and
- [n>n2] in the given ordering. The nodes [n1] and [n2] are
- added as by [add_node]. NB: Adding all nodes [n1] and [n2], even
- if they are sterile, is not strictly necessary for our applications.
- It even slows down the code by a few percent. But it is desirable
- for consistency and allows much more efficient [iter_nodes] and
- [fold_nodes] below. *)
+ [n>n2] in the ordering of [node]s in the [Forest] that the
+ DAG represents. The nodes [n1] and [n2] are
+ added as by [add_node]. NB: Adding the nodes [n1] and [n2] even
+ if they are sterile is not necessary for our applications.
+ But even though it slows down the code by a few percent, it is desirable
+ for consistency and allows much more concise implementations of
+ [iter_nodes] and [fold_nodes] below. *)
val add_offspring : node -> edge * children -> t -> t
exception Cycle
(* Just like [add_offspring], but does not check for potential cycles. *)
val add_offspring_unsafe : node -> edge * children -> t -> t
(* [is_node n dag] returns [true] iff [n] is a node in [dag]. *)
val is_node : node -> t -> bool
-(* [is_sterile n dag] returns [true] iff [n] is a node in [dag] and
- boasts no offspring. *)
+(* [is_sterile n dag] returns [true] iff [n] is a node in [dag], but
+ has no offspring. *)
val is_sterile : node -> t -> bool
(* [is_offspring n (e, (n1, n2)) dag] returns [true] iff [n1] and [n2]
are offspring of [n] with label [e] in [dag]. *)
val is_offspring : node -> edge * children -> t -> bool
+(* There is no function [val offspring : node -> (edge * children) list]
+ to extract the structure of the DAG explicitely. Instead, we export
+ a functional interface that allows us to transform a DAG and
+ to evaluate the expression encoded by the DAG. *)
+
(* Note that the following functions can run into infinite
recursion if the DAG given as argument contains cycles. *)
(* The usual functionals for processing all nodes (including sterile)
\ldots{} *)
val iter_nodes : (node -> unit) -> t -> unit
val map_nodes : (node -> node) -> t -> t
val fold_nodes : (node -> 'a -> 'a) -> t -> 'a -> 'a
(* \ldots{} and all parent/offspring relations. Note that [map] requires
\emph{two} functions: one for the nodes and one for
the edges and children. This is so because a change in the
definition of node is \emph{not} propagated automatically to where
it is used as a child. *)
val iter : (node -> edge * children -> unit) -> t -> unit
val map : (node -> node) ->
(node -> edge * children -> edge * children) -> t -> t
val fold : (node -> edge * children -> 'a -> 'a) -> t -> 'a -> 'a
(* \begin{dubious}
Note that in it's current incarnation,
[fold add_offspring dag empty] copies \emph{only} the fertile nodes, while
[fold add_offspring dag (fold_nodes add_node dag empty)]
includes sterile ones, as does
[map (fun n -> n) (fun n ec -> ec) dag].
\end{dubious} *)
(* Return the DAG as a list of lists. *)
val lists : t -> (node * (edge * children) list) list
(* [dependencies dag node] returns a canonically sorted [Tree2.t] of all
nodes reachable from [node]. *)
val dependencies : t -> node -> (node, edge) Tree2.t
(* [harvest dag n roots] returns the DAG [roots]
enlarged by all nodes in [dag] reachable from [n]. *)
val harvest : t -> node -> t -> t
-(* [harvest_list dag nlist] returns the part of the DAG [dag]
- that is reachable from the nodes in [nlist]. *)
+(* [harvest_list dag nodes] returns the part of the DAG [dag]
+ that is reachable from the [nodes]. *)
val harvest_list : t -> node list -> t
(* [size dag] returns the number of nodes in the DAG [dag]. *)
val size : t -> int
(* [eval f mul_edge mul_nodes add null unit root dag]
interprets the part of [dag] beneath [root] as an algebraic
expression:
\begin{itemize}
\item each node is evaluated by [f: node -> 'a]
\item each set of children is evaluated by iterating the
binary
[mul_nodes: 'a -> 'c -> 'c] on the values of the nodes,
starting from [unit: 'c]
\item each offspring relation $(node, (edge, children))$
is evaluated by applying
[mul_edge: node -> edge -> 'c -> 'd] to [node], [edge]
and the evaluation of [children].
\item all offspring relations of a [node] are combined by
iterating the binary
[add: 'd -> 'a -> 'a] starting from [null: 'a]
\end{itemize}
In our applications, we will always have ['a = 'c = 'd], but
the more general type is useful for documenting the relationships.
The memoizing variant
[eval_memoized f mul_edge mul_nodes add null unit root dag]
requires some overhead, but can be more efficient for
complex operations. *)
val eval : (node -> 'a) -> (node -> edge -> 'c -> 'd) ->
('a -> 'c -> 'c) -> ('d -> 'a -> 'a) -> 'a -> 'c -> node -> t -> 'a
val eval_memoized : (node -> 'a) -> (node -> edge -> 'c -> 'd) ->
('a -> 'c -> 'c) -> ('d -> 'a -> 'a) -> 'a -> 'c -> node -> t -> 'a
(* [forest root dag] expands the [dag] beneath [root] into the
equivalent list of trees [Tree.t]. [children] are represented
as list of nodes.
\begin{dubious}
A sterile node~[n] is represented as [Tree.Leaf ((n, None), n)],
cf.~page~\pageref{Tree.Leaf}. There might be a better way, but
we need to change the interface and semantics of [Tree] for this.
\end{dubious} *)
val forest : node -> t -> (node * edge option, node) Tree.t list
val forest_memoized : node -> t -> (node * edge option, node) Tree.t list
(* [count_trees n dag] returns the number of trees with root [n] encoded
in the DAG [dag], i.\,e.~$|T(n,D)|$. NB: the current
implementation is very naive and can take a \emph{very} long
time for moderately sized DAGs that encode a large set of
trees. *)
val count_trees : node -> t -> int
end
module Make (F : Forest) :
T with type node = F.node and type edge = F.edge
and type children = F.children
(* \thocwmodulesection{Graded Sets, Forests \&{} DAGs} *)
(* A graded ordered\footnote{We don't appear to have use for graded unordered
- sets.} set is an ordered set with a map into another ordered set (often the
- non-negative integers). The grading does not necessarily respect the
- ordering. *)
+ sets.} set is an ordered set with a map [rank]
+ into another ordered set (often the
+ non-negative integers). Note that it is \emph{not} required
+ that the grading respects the ordering,
+ i.\,e.~[x<y] $\not\Rightarrow$ [rank x < rank y]. *)
+
+(* \begin{dubious}
+ Conceptionally, there is some overlap with [Bundle]
+ (cf.~section~\ref{sec:bundle}), if we interpret the
+ set of ranks as the base of the bundle and [rank] as the
+ projection $\pi$. We might want to unify the structures.
+ But note that in the case of [Bundle], the intuition is
+ that the base is a subset of the bundle, i.\,e.~each element
+ of the base is an element of a fiber. In the case of
+ a grading, the set of ranks can be completely disjoint from
+ the original set.
+ \end{dubious} *)
module type Graded_Ord =
sig
include Ord
module G : Ord
val rank : t -> G.t
end
(* For all ordered sets, there are two canonical gradings: a [Chaotic] grading
that assigns the same rank (e.\,g.~[unit]) to all elements and the [Discrete]
grading that uses the identity map as grading. *)
module type Grader = functor (O : Ord) -> Graded_Ord with type t = O.t
module Chaotic : Grader
module Discrete : Grader
(* A graded forest is just a forest in which the nodes form a graded ordered set.
\begin{dubious}
- There doesn't appear to be a nice syntax for avoiding the repetition
- here. Fortunately, the signature is short \ldots
+ Module type substitions for avoiding the repetition
+ here will come with O'Caml 4.13.
+ Until then, we're lucky that the signature is short \ldots
\end{dubious} *)
module type Graded_Forest =
sig
module Nodes : Graded_Ord
type node = Nodes.t
type edge
type children
type t = edge * children
val compare : t -> t -> int
val for_all : (node -> bool) -> t -> bool
val fold : (node -> 'a -> 'a) -> t -> 'a -> 'a
end
module type Forest_Grader = functor (G : Grader) -> functor (F : Forest) ->
Graded_Forest with type Nodes.t = F.node
and type node = F.node
and type edge = F.edge
and type children = F.children
and type t = F.t
module Grade_Forest : Forest_Grader
(* Finally, a graded DAG is a DAG in which the nodes form a graded ordered set
and the subsets with a given rank can be accessed cheaply. *)
module type Graded =
sig
include T
type rank
val rank : node -> rank
val ranks : t -> rank list
val min_max_rank : t -> rank * rank
val ranked : rank -> t -> node list
end
module Graded (F : Graded_Forest) :
Graded with type node = F.node and type edge = F.edge
and type children = F.children and type rank = F.Nodes.G.t
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
+module Test : sig val suite : OUnit.test end
Index: trunk/omega/src/omega_Xdim.ml
===================================================================
--- trunk/omega/src/omega_Xdim.ml (revision 8899)
+++ trunk/omega/src/omega_Xdim.ml (revision 8900)
@@ -1,35 +1,26 @@
(* omega_Xdim.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.Fortran)
- (Modellib_BSM.Xdim(Modellib_BSM.BSM_bsm))
+module O = Omega.Mixed23(Target_Fortran.Make)(Modellib_BSM.Xdim(Modellib_BSM.BSM_bsm))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/color_Fusion.mli
===================================================================
--- trunk/omega/src/color_Fusion.mli (revision 0)
+++ trunk/omega/src/color_Fusion.mli (revision 8900)
@@ -0,0 +1,45 @@
+(* color_Fusion.mli --
+
+ Copyright (C) 2022-2023 by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+ with contributions from
+ Christian Speckner <cnspeckn@googlemail.com>
+
+ 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. *)
+
+(* This module uses a vertex color flow of type [Birdtracks.t]
+ (which aliased to, e.\,g., [SU3.t]), to fuse a list of
+ [Color_Propagator.t]. *)
+
+(* [fuse nc vertex children] use the color flows in the [vertex]
+ to combine the color flows in the incoming [children] and return
+ the color flows for outgoing particle together with their weights. *)
+
+val fuse : int -> Birdtracks.t -> Color_Propagator.t list -> (Algebra.Laurent.c * Color_Propagator.t) list
+
+(* \begin{dubious}
+ At the moment, [nc] is substituted for $N_C$. It this necessary
+ or the desired behavior? Can we use
+ [(Algebra.Laurent.t * Color_Propagator.t) list]
+ as return type instead, in order to be able to write the symbolic
+ expression to the amplitude? This would necessitate changes in
+ many places, however.
+ \end{dubious} *)
+
+(* Unit tests. *)
+module Test : sig val suite : OUnit.test val suite_long : OUnit.test end
Index: trunk/omega/src/SU3.ml
===================================================================
--- trunk/omega/src/SU3.ml (revision 0)
+++ trunk/omega/src/SU3.ml (revision 8900)
@@ -0,0 +1,1440 @@
+(* SU3.ml --
+
+ Copyright (C) 2022-2023 by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+ with contributions from
+ Christian Speckner <cnspeckn@googlemail.com>
+
+ WHIZARD is free software; you can redistribute it and/or modify it
+ under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ WHIZARD is distributed in the hope that it will be useful, but
+ WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
+
+(* \thocwmodulesection{Import Functions from [Birdtracks]} *)
+module A = Arrow
+open Arrow.Infix
+module L = Algebra.Laurent
+
+type t = Birdtracks.t
+open Birdtracks
+open Birdtracks.Infix
+
+(* \thocwmodulesection{Constructors specific to $\mathrm{SU}(N_C)$} *)
+
+(* \thocwmodulesubsection{Fundamental and Adjoint Representation} *)
+
+let delta3 i j =
+ [ Arrows { coeff = L.int 1; arrows = j ==> i } ]
+
+let delta8 a b =
+ [ Arrows { coeff = L.int 1; arrows = a <=> b } ]
+
+(* If the~$\delta_{ab}$ originates from
+ a~$\tr(T_aT_b)$, like an effective~$gg\to H$
+ coupling, it makes a difference in the color
+ flow basis and we must write the full expression~(6.2)
+ from~\cite{Kilian:2012pz} including the ghosts instead.
+ Note that the sign for the terms with one ghost
+ has not been spelled out in that reference. *)
+
+let delta8_loop a b =
+ [ Arrows { coeff = L.int 1; arrows = a <=> b };
+ Arrows { coeff = L.int (-1); arrows = [a => a; ?? b] };
+ Arrows { coeff = L.int (-1); arrows = [?? a; b => b] };
+ Arrows { coeff = L.nc 1; arrows = [?? a; ?? b] } ]
+
+(* The following can be used for computing polarization sums
+ (eventually, this could make the [Flow] module redundant).
+ Note that we have $-N_C$ instead of $-1/N_C$ in the ghost
+ contribution here, because [add_arrow_to_arrows_list']
+ from the module [Birdtracks] (cf.~page ~\pageref{pg:add_arrow})
+ will produce a factor of $-1/N_C$ when contracting each one
+ of the two ghost indices.
+ Indeed, with this definition we can maintain all projection
+ properties
+ \begin{itemize}
+ \item[] [gluon 1 (-3) *** gluon (-3) 2 = gluon 1 2],
+ \item[] [delta8 1 (-3) *** delta8 (-3) 2 = delta8 1 2],
+ \item[] [ghost 1 (-3) *** ghost (-3) 2 = ghost 1 2]
+ \end{itemize}
+ and most importantly
+ \begin{itemize}
+ \item[] [t (-1) 1 2 *** gluon (-1) (-2) *** t (-2) 3 4 = t (-1) 1 2 *** t (-1) 3 4].
+ \end{itemize} *)
+
+let ghost a b =
+ [ Arrows { coeff = L.nc (-1); arrows = [?? a; ?? b] } ]
+
+let gluon a b =
+ delta8 a b @ ghost a b
+
+(* Note that the arrow is directed from the second to the first
+ index, opposite to our color flow paper~\cite{Kilian:2012pz}.
+ Fortunately, this is just a matter of conventions.
+\begin{subequations}
+\begin{align}
+\parbox{28\unitlength}{%
+ \fmfframe(4,4)(4,4){%
+ \begin{fmfgraph*}(20,20)
+ \fmfleft{f1,f2}
+ \fmfright{g}
+ \fmfv{label=$i$}{f2}
+ \fmfv{label=$j$}{f1}
+ \fmfv{label=$a$}{g}
+ \fmf{fermion}{f1,v}
+ \fmf{fermion}{v,f2}
+ \fmf{gluon}{v,g}
+ \end{fmfgraph*}}} &\Longrightarrow
+\parbox{28\unitlength}{%
+ \fmfframe(4,4)(4,4){%
+ \begin{fmfgraph*}(20,20)
+ \fmfleft{f1,f2}
+ \fmfright{g}
+ \fmfv{label=$i$}{f2}
+ \fmfv{label=$j$}{f1}
+ \fmfv{label=$a$}{g}
+ \fmf{phantom}{f1,v}
+ \fmf{phantom}{v,f2}
+ \fmf{phantom}{v,g}
+ \fmffreeze
+ \fmfi{phantom_arrow}{vpath (__v, __g) sideways -thick}
+ \fmfi{phantom_arrow}{(reverse vpath (__v, __g)) sideways -thick}
+ \fmfi{phantom_arrow}{vpath (__f1, __v)}
+ \fmfi{phantom_arrow}{vpath (__v, __f2)}
+ \fmfi{plain}{%
+ (vpath (__f1, __v) join (vpath (__v, __g)) sideways -thick)}
+ \fmfi{plain}{%
+ ((reverse vpath (__g, __v) sideways -thick) join vpath (__v, __f2))}
+ \end{fmfgraph*}}}
+\parbox{28\unitlength}{%
+ \fmfframe(4,4)(4,4){%
+ \begin{fmfgraph*}(20,20)
+ \fmfleft{f1,f2}
+ \fmfright{g}
+ \fmfv{label=$i$}{f1}
+ \fmfv{label=$j$}{f2}
+ \fmfv{label=$a$}{g}
+ \fmf{fermion}{f1,v}
+ \fmf{fermion}{v,f2}
+ \fmf{dots}{v,g}
+ \end{fmfgraph*}}}\\
+ T_a^{ij} \qquad\quad
+ &\Longrightarrow \qquad\quad \delta^{ia}\delta^{aj}
+ \qquad\qquad\qquad - \delta^{ij}
+\end{align}
+\end{subequations} *)
+
+let t a i j =
+ [ Arrows { coeff = L.int 1; arrows = [j => a; a => i] };
+ Arrows { coeff = L.int (-1); arrows = [j => i; ?? a] } ]
+
+(* Note that while we expect $\tr(T_a)=T_a^{ii}=0$,
+ the evaluation of the expression [t 1 (-1) (-1)] will stop
+ at [ [ -1 => 1; 1 => -1 ] --- [ -1 => -1; ?? 1 ] ], because the
+ summation index appears in a single term.
+ However, a naive further evaluation would get stuck at
+ [ [ 1 => 1 ] --- nc *** [ ?? 1 ] ].
+ Fortunately, traces of single generators are never needed in our
+ applications. We just have to resist the temptation to use them
+ in unit tests. *)
+
+(*
+\begin{equation}
+\parbox{29\unitlength}{%
+ \fmfframe(2,2)(2,2){%
+ \begin{fmfgraph*}(25,25)
+ \fmfleft{g1,g2}
+ \fmfright{g3}
+ \fmfv{label=$a$}{g1}
+ \fmfv{label=$b$}{g2}
+ \fmfv{label=$c$}{g3}
+ \fmf{gluon}{g1,v}
+ \fmf{gluon}{g2,v}
+ \fmf{gluon}{g3,v}
+ \end{fmfgraph*}}}
+\qquad\Longrightarrow
+\parbox{29\unitlength}{%
+ \fmfframe(2,2)(2,2){%
+ \begin{fmfgraph*}(25,25)
+ \fmfleft{g1,g2}
+ \fmfright{g3}
+ \fmfv{label=$a$}{g1}
+ \fmfv{label=$b$}{g2}
+ \fmfv{label=$c$}{g3}
+ \fmf{phantom}{g1,v}
+ \fmf{phantom}{g2,v}
+ \fmf{phantom}{g3,v}
+ \fmffreeze
+ \fmfi{plain}{(vpath(__g1,__v) join (reverse vpath(__g2,__v)))
+ sideways thick}
+ \fmfi{plain}{(vpath(__g2,__v) join (reverse vpath(__g3,__v)))
+ sideways thick}
+ \fmfi{plain}{(vpath(__g3,__v) join (reverse vpath(__g1,__v)))
+ sideways thick}
+ \fmfi{phantom_arrow}{vpath (__g1, __v) sideways thick}
+ \fmfi{phantom_arrow}{vpath (__g2, __v) sideways thick}
+ \fmfi{phantom_arrow}{vpath (__g3, __v) sideways thick}
+ \fmfi{phantom_arrow}{(reverse vpath (__g1, __v)) sideways thick}
+ \fmfi{phantom_arrow}{(reverse vpath (__g2, __v)) sideways thick}
+ \fmfi{phantom_arrow}{(reverse vpath (__g3, __v)) sideways thick}
+ \end{fmfgraph*}}}
+\qquad
+\parbox{29\unitlength}{%
+ \fmfframe(2,2)(2,2){%
+ \begin{fmfgraph*}(25,25)
+ \fmfleft{g1,g2}
+ \fmfright{g3}
+ \fmfv{label=$a$}{g1}
+ \fmfv{label=$b$}{g2}
+ \fmfv{label=$c$}{g3}
+ \fmf{phantom}{g1,v}
+ \fmf{phantom}{g2,v}
+ \fmf{phantom}{g3,v}
+ \fmffreeze
+ \fmfi{plain}{(vpath(__g1,__v) join (reverse vpath(__g3,__v)))
+ sideways thick}
+ \fmfi{plain}{(vpath(__g2,__v) join (reverse vpath(__g1,__v)))
+ sideways thick}
+ \fmfi{plain}{(vpath(__g3,__v) join (reverse vpath(__g2,__v)))
+ sideways thick}
+ \fmfi{phantom_arrow}{vpath (__g1, __v) sideways thick}
+ \fmfi{phantom_arrow}{vpath (__g2, __v) sideways thick}
+ \fmfi{phantom_arrow}{vpath (__g3, __v) sideways thick}
+ \fmfi{phantom_arrow}{(reverse vpath (__g1, __v)) sideways thick}
+ \fmfi{phantom_arrow}{(reverse vpath (__g2, __v)) sideways thick}
+ \fmfi{phantom_arrow}{(reverse vpath (__g3, __v)) sideways thick}
+ \end{fmfgraph*}}}
+\end{equation} *)
+
+let f a b c =
+ [ Arrows { coeff = L.imag ( 1); arrows = A.cycle [a; b; c] };
+ Arrows { coeff = L.imag (-1); arrows = A.cycle [a; c; b] } ]
+
+(* The generator in the adjoint representation $T_a^{bc}=-\ii f_{abc}$: *)
+
+let t8 a b c =
+ minus *** imag *** f a b c
+
+(* This $d_{abc}$ is now compatible with~(6.11) in our color
+ flow paper~\cite{Kilian:2012pz}. The signs had been wrong
+ in earlier versions of the code to match the missing
+ sign in the ghost contribution to the generator~$T_a^{ij}$
+ above. *)
+
+let d a b c =
+ [ Arrows { coeff = L.int 1; arrows = A.cycle [a; b; c] };
+ Arrows { coeff = L.int 1; arrows = A.cycle [a; c; b] };
+ Arrows { coeff = L.int (-2); arrows = (a <=> b) @ [?? c] };
+ Arrows { coeff = L.int (-2); arrows = (b <=> c) @ [?? a] };
+ Arrows { coeff = L.int (-2); arrows = (c <=> a) @ [?? b] };
+ Arrows { coeff = L.int 2; arrows = [a => a; ?? b; ?? c] };
+ Arrows { coeff = L.int 2; arrows = [?? a; b => b; ?? c] };
+ Arrows { coeff = L.int 2; arrows = [?? a; ?? b; c => c] };
+ Arrows { coeff = L.nc (-2); arrows = [?? a; ?? b; ?? c] } ]
+
+(* \thocwmodulesubsection{Decomposed Tensor Product Representations} *)
+
+let pass_through m n incoming outgoing =
+ List.rev_map2 (fun i o -> (m, i) >=>> (n, o)) incoming outgoing
+
+let delta_of_permutations n permutations k l =
+ let incoming = ThoList.range 0 (pred n)
+ and normalization = List.length permutations in
+ List.rev_map
+ (fun (eps, outgoing) ->
+ Arrows { coeff = L.fraction (eps * normalization);
+ arrows = pass_through l k incoming outgoing } )
+ permutations
+
+let totally_symmetric n =
+ List.map
+ (fun p -> (1, p))
+ (Combinatorics.permute (ThoList.range 0 (pred n)))
+
+let totally_antisymmetric n =
+ (Combinatorics.permute_signed (ThoList.range 0 (pred n)))
+
+let delta_S n k l =
+ delta_of_permutations n (totally_symmetric n) k l
+
+let delta_A n k l =
+ delta_of_permutations n (totally_antisymmetric n) k l
+
+let delta6 = delta_S 2
+let delta10 = delta_S 3
+let delta15 = delta_S 4
+
+let delta3bar = delta_A 2
+
+(* Mixed symmetries, as in section 9.4 of the birdtracks book. *)
+
+module IM = Partial.Make (struct type t = int let compare = compare end)
+module P = Permutation.Default
+
+(* Map the elements of [original] to [permuted] in [all], with [all]
+ a list of $n$ integers from $0$ to $n-1$ in order, and use the resulting
+ list to define a permutation.
+ E.\,g.~[permute_partial [1;3] [3;1] [0;1;2;3;4]] will define a
+ permutation that transposes the second and fourth element in
+ a 5 element list. *)
+
+let permute_partial original permuted all =
+ P.of_list (List.map (IM.auto (IM.of_lists original permuted)) all)
+
+let apply1 (sign, indices) (eps, p) =
+ (eps * sign, P.list p indices)
+
+let apply signed_permutations signed_indices =
+ List.rev_map (apply1 signed_indices) signed_permutations
+
+let apply_list signed_permutations signed_indices =
+ ThoList.flatmap (apply signed_permutations) signed_indices
+
+let symmetrizer_of_permutations n original signed_permutations =
+ let incoming = ThoList.range 0 (pred n) in
+ List.rev_map
+ (fun (eps, permuted) ->
+ (eps, permute_partial original permuted incoming))
+ signed_permutations
+
+let symmetrizer n indices =
+ symmetrizer_of_permutations
+ n indices
+ (List.rev_map (fun p -> (1, p)) (Combinatorics.permute indices))
+
+let anti_symmetrizer n indices =
+ symmetrizer_of_permutations
+ n indices
+ (Combinatorics.permute_signed indices)
+
+let symmetrize n elements indices =
+ apply_list (symmetrizer n elements) indices
+
+let anti_symmetrize n elements indices =
+ apply_list (anti_symmetrizer n elements) indices
+
+let id n =
+ [(1, ThoList.range 0 (pred n))]
+
+(* \begin{dubious}
+ We can avoid the recursion here, if we use
+ [Combinatorics.permute_tensor_signed] in
+ [symmetrizer] above.
+ \end{dubious} *)
+
+let rec apply_tableau f n tableau indices =
+ match tableau with
+ | [] | [_] :: _ -> indices
+ | cells :: rest ->
+ apply_tableau f n rest (f n cells indices)
+
+(* \begin{dubious}
+ Here we should at a sanity test for [tableau]: all integers should
+ be consecutive starting from 0 with no duplicates. In additions
+ the rows must not grow in length.
+ \end{dubious} *)
+
+let young_tableau_valid_omega y =
+ Young.standard_tableau ~offset:0 y
+
+let delta_of_tableau tableau i j =
+ if young_tableau_valid_omega tableau then
+ let n = Young.num_cells_tableau tableau
+ and num, den = Young.normalization (Young.diagram_of_tableau tableau)
+ and rows = tableau
+ and cols = Young.conjugate_tableau tableau in
+ let permutations =
+ apply_tableau symmetrize n rows (apply_tableau anti_symmetrize n cols (id n)) in
+ int num *** fraction den *** delta_of_permutations n permutations i j
+ else
+ let s = Young.tableau_to_string string_of_int tableau in
+ invalid_arg ("SU3.delta_of_tableau: " ^ s ^ " is not standard!")
+
+let incomplete tensor =
+ failwith ("SU3: " ^ tensor ^ " not supported yet!")
+
+let experimental tensor =
+ Printf.eprintf "SU3: %s support still experimental and untested!\n" tensor
+
+let distinct integers =
+ let rec distinct' seen = function
+ | [] -> true
+ | i :: rest ->
+ if Sets.Int.mem i seen then
+ false
+ else
+ distinct' (Sets.Int.add i seen) rest in
+ distinct' Sets.Int.empty integers
+
+(* All lines start here: they point towards the vertex. *)
+let epsilon tips =
+ if distinct tips then
+ [ Epsilons ({ coeff = L.int 1; arrows = [] }, NEList.singleton (A.epsilon tips)) ]
+ else
+ []
+
+(* All lines end here: they point away from the vertex. *)
+let epsilon_bar tails =
+ if distinct tails then
+ [ Epsilon_Bars ({ coeff = L.int 1; arrows = [] },NEList.singleton (A.epsilon_bar tails)) ]
+ else
+ []
+
+
+(* In order to get the correct $N_C$ dependence of
+ quadratic Casimir operators, the arrows in the vertex must
+ have the same permutation symmetry as the propagator. This
+ is demonstrated by the unit tests involving Casimir operators
+ on page \pageref{pg:casimir-tests} below. These tests also
+ provide a check of our normalization.
+
+ The implementation takes a propagator and uses [Arrow.tee] to
+ replace one arrow by the pair of arrows corresponding to the
+ insertion of a gluon. This is repeated for each arrow.
+ The normalization remains unchanged from the propagator.
+ A minus sign is added for antiparallel arrows, since the
+ conjugate representation is~$-T^*_a$.
+
+ To this, we add the diagrams with a gluon connected to one arrow.
+ Since these are identical, only one diagram multiplied by the
+ difference of the number of parallel and antiparallel arrows
+ is added. *)
+
+let insert_gluon a k l term =
+ let rec insert_gluon' acc left = function
+ | [] -> acc
+ | arrow :: right ->
+ insert_gluon'
+ (Arrows { coeff = Algebra.Laurent.mul (L.int (A.dir k l arrow)) term.coeff;
+ arrows = List.rev_append left ((A.tee a arrow) @ right) } :: acc)
+ (arrow :: left)
+ right in
+ insert_gluon' [] [] term.arrows
+
+let t_of_delta delta a k l =
+ match delta k l with
+ | [] -> []
+ | Arrows { arrows = arrows } :: _ as delta_kl ->
+ let n =
+ List.fold_left
+ (fun acc arrow -> acc + A.dir k l arrow)
+ 0 arrows in
+ let ghosts =
+ List.rev_map
+ (fun term ->
+ match term with
+ | Arrows aterm ->
+ Arrows { coeff = Algebra.Laurent.mul (L.int (-n)) aterm.coeff;
+ arrows = ?? a :: aterm.arrows }
+ | Epsilons _ -> failwith "t_of_delta: unexpected epsilon"
+ | Epsilon_Bars _ -> failwith "t_of_delta: unexpected epsilon_bar")
+ delta_kl in
+ List.fold_left
+ (fun acc ->
+ function
+ | Arrows aterm -> insert_gluon a k l aterm @ acc
+ | Epsilons _ -> failwith "t_of_delta: unexpected epsilon"
+ | Epsilon_Bars _ -> failwith "t_of_delta: unexpected epsilon_bar")
+ ghosts delta_kl
+ | Epsilons _ :: _ -> failwith "t_of_delta: unexpected epsilon"
+ | Epsilon_Bars _ :: _ -> failwith "t_of_delta: unexpected epsilon_bar"
+
+let t_of_delta delta a k l =
+ canonicalize (t_of_delta delta a k l)
+
+let t_S n a k l =
+ t_of_delta (delta_S n) a k l
+
+let t_A n a k l =
+ t_of_delta (delta_A n) a k l
+
+let t6 = t_S 2
+let t10 = t_S 3
+let t15 = t_S 4
+let t3bar = t_A 2
+
+(* Equivalent definition: *)
+
+let t8' a b c =
+ t_of_delta delta8 a b c
+
+let t_of_tableau tableau a k l =
+ t_of_delta (delta_of_tableau tableau) a k l
+
+(* \begin{dubious}
+ Check the following for a real live UFO file!
+ \end{dubious} *)
+
+(* In the UFO paper, the Clebsh-Gordan is defined
+ as~$K^{(6),ij}_{\hphantom{(6),ij}m}$. Therefore, keeping
+ our convention for the generators~$T_{a\hphantom{(6),j}i}^{(6),j}$,
+ the must arrows \emph{end} at~$m$. *)
+
+let k6 m i j =
+ experimental "k6";
+ [ Arrows { coeff = L.int 1; arrows = [i =>> (m, 0); j =>> (m, 1)] };
+ Arrows { coeff = L.int 1; arrows = [i =>> (m, 1); j =>> (m, 0)] } ]
+
+(* The arrow are reversed for~$\bar K^{(6),m}_{\hphantom{(6),m}ij}$
+ and \emph{start} at~$m$. *)
+
+let k6bar m i j =
+ experimental "k6bar";
+ [ Arrows { coeff = L.int 1; arrows = [(m, 0) >=> i; (m, 1) >=> j] };
+ Arrows { coeff = L.int 1; arrows = [(m, 1) >=> i; (m, 0) >=> j] } ]
+
+(* \begin{dubious}
+ Playing arround with an example, it appears that we need the
+ opposite direction. Investigate!
+ \end{dubious} *)
+
+let k6 m i j =
+ experimental "k6";
+ [ Arrows { coeff = L.int 1; arrows = [(m, 0) >=> i; (m, 1) >=> j] };
+ Arrows { coeff = L.int 1; arrows = [(m, 1) >=> i; (m, 0) >=> j] } ]
+
+let k6bar m i j =
+ experimental "k6bar";
+ [ Arrows { coeff = L.int 1; arrows = [i =>> (m, 0); j =>> (m, 1)] };
+ Arrows { coeff = L.int 1; arrows = [i =>> (m, 1); j =>> (m, 0)] } ]
+
+(* \thocwmodulesection{Unit Tests} *)
+
+module Test =
+ struct
+ open OUnit
+ module L = Algebra.Laurent
+
+ let exorcise vertex =
+ List.filter
+ (function
+ | Arrows aterm | Epsilons (aterm, _) | Epsilon_Bars (aterm, _) ->
+ not (List.exists A.is_ghost aterm.arrows))
+ vertex
+
+ let exorcised_equal v1 v2 =
+ equal (exorcise v1) (exorcise v2)
+
+ (* \thocwmodulesubsection{Trivia} *)
+
+ let suite_sum =
+ "sum" >:::
+
+ [ "atoms" >::
+ (fun () ->
+ equal
+ (int 2 *** delta3 1 2)
+ (delta3 1 2 +++ delta3 1 2)) ]
+
+ let suite_diff =
+ "diff" >:::
+
+ [ "atoms" >::
+ (fun () ->
+ equal
+ (delta3 3 4)
+ (delta3 1 2 +++ delta3 3 4 --- delta3 1 2)) ]
+
+
+ (* \begin{equation}
+ \prod_{k=i}^j f(k)
+ \end{equation} *)
+ let rec product f i j =
+ if i > j then
+ null
+ else if i = j then
+ f i
+ else
+ f i *** product f (succ i) j
+
+ (* In particular
+ \begin{equation}
+ \text{[nc_minus_n_plus] n k}\, \mapsto N_C-n+k
+ \end{equation}
+ and
+ \begin{multline}
+ \text{[product (nc_minus_n_plus n) i j]}\, \mapsto \\
+ \prod_{k=i}^j (N_C-n+k)
+ = \frac{(N_C-n+j)!}{(N_C-n+i-1)!}
+ = (N_C-n+j)(N_C-n+j-1)\cdots(N_C-n+i)
+ \end{multline} *)
+ let nc_minus_n_plus n k =
+ const (L.ints [ (1, 1); (-n + k, 0) ])
+
+ let contractions rank k =
+ product (nc_minus_n_plus rank) 1 k
+
+ let suite_times =
+ "times" >:::
+
+ [ "reorder components t1*t2" >:: (* trivial $T_a^{ik}T_a^{kj}=T_a^{kj}T_a^{ik}$ *)
+ (fun () ->
+ let t1 = t (-1) 1 (-2)
+ and t2 = t (-1) (-2) 2 in
+ equal (t1 *** t2) (t2 *** t1));
+
+ "reorder components tr(t1*t2)" >:: (* trivial $T_a^{ij}T_a^{ji}=T_a^{ji}T_a^{ij}$ *)
+ (fun () ->
+ let t1 = t 1 (-1) (-2)
+ and t2 = t 2 (-2) (-1) in
+ equal (t1 *** t2) (t2 *** t1));
+
+ "reorderings" >::
+ (fun () ->
+ let v1 = [Arrows { coeff = L.unit; arrows = [ 1 => -2; -2 => -1; -1 => 1] }]
+ and v2 = [Arrows { coeff = L.unit; arrows = [-1 => 2; 2 => -2; -2 => -1] }]
+ and v' = [Arrows { coeff = L.unit; arrows = [ 1 => 1; 2 => 2] }] in
+ equal v' (v1 *** v2));
+
+ "eps*epsbar" >::
+ (fun () ->
+ equal
+ (delta3 1 2 *** delta3 3 4 --- delta3 1 4 *** delta3 3 2)
+ (epsilon [1; 3] *** epsilon_bar [2; 4]));
+
+ "eps*epsbar -" >::
+ (fun () ->
+ equal
+ (delta3 1 4 *** delta3 3 2 --- delta3 1 2 *** delta3 3 4)
+ (epsilon [1; 3] *** epsilon_bar [4; 2]));
+
+ "eps*epsbar 1" >::
+ (fun () ->
+ equal (* $N_C-3+1=(N_C-2)$, for $NC=3$: $1$ *)
+ (contractions 3 1 ***
+ (delta3 1 2 *** delta3 3 4 --- delta3 1 4 *** delta3 3 2))
+ (epsilon [-1; 1; 3] *** epsilon_bar [-1; 2; 4]));
+
+ "eps*epsbar cyclic 1" >::
+ (fun () ->
+ equal (* $N_C-3+1=(N_C-2)$, for $NC=3$: $1$ *)
+ (contractions 3 1 ***
+ (delta3 1 2 *** delta3 3 4 --- delta3 1 4 *** delta3 3 2))
+ (epsilon [3; -1; 1] *** epsilon_bar [-1; 2; 4]));
+
+ "eps*epsbar cyclic 2" >::
+ (fun () ->
+ equal (* $N_C-3+1=(N_C-2)$, for $NC=3$: $1$ *)
+ (contractions 3 1 ***
+ (delta3 1 2 *** delta3 3 4 --- delta3 1 4 *** delta3 3 2))
+ (epsilon [-1; 1; 3] *** epsilon_bar [4; -1; 2]));
+
+ "eps*epsbar 2" >::
+ (fun () ->
+ equal (* $(N_C-3+2)(N_C-3+1)=(N_C-1)(N_C-2)$, for $NC=3$: $2$ *)
+ (contractions 3 2 *** delta3 1 2)
+ (epsilon [-1; -2; 1] *** epsilon_bar [-1; -2; 2]));
+
+ "eps*epsbar 3" >::
+ (fun () ->
+ equal (* $(N_C-3+3)(N_C-3+2)(N_C-3+1)=N_C(N_C-1)(N_C-2)$, for $NC=3$: $3!$ *)
+ (contractions 3 3)
+ (epsilon [-1; -2; -3] *** epsilon_bar [-1; -2; -3]));
+
+ "eps*epsbar big" >::
+ (fun () ->
+ equal (* $(N_C-5+3)(N_C-5+2)(N_C-5+1)=(N_C-2)(N_C-3)(N_C-4)$, for $NC=5$: $3!$ *)
+ (contractions 5 3 ***
+ (epsilon [4; 5] *** epsilon_bar [6; 7]))
+ (epsilon [-1; -2; -3; 4; 5] *** epsilon_bar [-1; -2; -3; 6; 7]));
+
+ "eps*epsbar big -" >::
+ (fun () ->
+ equal (* $(N_C-5+3)(N_C-5+2)(N_C-5+1)=(N_C-2)(N_C-3)(N_C-4)$, for $NC=5$: $3!$ *)
+ (contractions 5 3 ***
+ (epsilon [5; 4] *** epsilon_bar [6; 7]))
+ (epsilon [-1; 4; -3; -2; 5] *** epsilon_bar [-1; -2; -3; 6; 7])) ]
+
+ (* \thocwmodulesubsection{Propagators} *)
+
+ (* Verify the normalization of the propagators by making sure
+ that $D^{ij}D^{jk}=D^{ik}$ *)
+
+ let projection_id rep_d =
+ equal (rep_d 1 2) (rep_d 1 (-1) *** rep_d (-1) 2)
+
+ let orthogonality d d' =
+ assert_zero_vertex (d 1 (-1) *** d' (-1) 2)
+
+ (* Pass every arrow straight through, without (anti-)symmetrization. *)
+ let delta_unsymmetrized n k l =
+ delta_of_permutations n [(1, ThoList.range 0 (pred n))] k l
+
+ let completeness n tableaux =
+ equal
+ (delta_unsymmetrized n 1 2)
+ (sum (List.map (fun t -> delta_of_tableau t 1 2) tableaux))
+
+ (* The following names are of historical origin. From the time,
+ when we didn't have full support for Young tableaux and
+ implemented figure 9.1 from the birdtrack book.
+ \ytableausetup{centertableaux,smalltableaux}
+ \begin{equation}
+ \ytableaushort{01,2}
+ \end{equation} *)
+
+ let delta_SAS i j =
+ delta_of_tableau [[0;1];[2]] i j
+
+ (* \begin{equation}
+ \ytableaushort{02,1}
+ \end{equation} *)
+
+ let delta_ASA i j =
+ delta_of_tableau [[0;2];[1]] i j
+
+ let suite_propagators =
+ "propagators" >:::
+ [ "D*D=D" >:: (fun () -> projection_id delta3);
+ "D8*D8=D8" >:: (fun () -> projection_id delta8);
+ "G*G=G" >:: (fun () -> projection_id gluon);
+ "D6*D6=D6" >:: (fun () -> projection_id delta6);
+ "D10*D10=D10" >:: (fun () -> projection_id delta10);
+ "D15*D15=D15" >:: (fun () -> projection_id delta15);
+ "D3bar*D3bar=D3bar" >:: (fun () -> projection_id delta3bar);
+ "D6*D3bar=0" >:: (fun () -> orthogonality delta6 delta3bar);
+ "D_A3*D_A3=D_A3" >:: (fun () -> projection_id (delta_A 3));
+ "D10*D_A3=0" >:: (fun () -> orthogonality delta10 (delta_A 3));
+ "D_SAS*D_SAS=D_SAS" >:: (fun () -> projection_id delta_SAS);
+ "D_ASA*D_ASA=D_ASA" >:: (fun () -> projection_id delta_ASA);
+ "D_SAS*D_S3=0" >:: (fun () -> orthogonality delta_SAS (delta_S 3));
+ "D_SAS*D_A3=0" >:: (fun () -> orthogonality delta_SAS (delta_A 3));
+ "D_SAS*D_ASA=0" >:: (fun () -> orthogonality delta_SAS delta_ASA);
+ "D_ASA*D_SAS=0" >:: (fun () -> orthogonality delta_ASA delta_SAS);
+ "D_ASA*D_S3=0" >:: (fun () -> orthogonality delta_ASA (delta_S 3));
+ "D_ASA*D_A3=0" >:: (fun () -> orthogonality delta_ASA (delta_A 3));
+ "DU*DU=DU" >:: (fun () -> projection_id (delta_unsymmetrized 3));
+
+ "S3=[0123]" >::
+ (fun () ->
+ equal (delta_S 4 1 2) (delta_of_tableau [[0;1;2;3]] 1 2));
+
+ "A3=[0,1,2,3]" >::
+ (fun () ->
+ equal (delta_A 4 1 2) (delta_of_tableau [[0];[1];[2];[3]] 1 2));
+
+ "[0123]*[012,3]=0" >::
+ (fun () ->
+ orthogonality
+ (delta_of_tableau [[0;1;2;3]])
+ (delta_of_tableau [[0;1;2];[3]]));
+
+ "[0123]*[01,23]=0" >::
+ (fun () ->
+ orthogonality
+ (delta_of_tableau [[0;1;2;3]])
+ (delta_of_tableau [[0;1];[2;3]]));
+
+ "[012,3]*[012,3]=[012,3]" >::
+ (fun () -> projection_id (delta_of_tableau [[0;1;2];[3]]));
+
+ (* \ytableausetup{centertableaux,smalltableaux}
+ \begin{equation}
+ \ytableaushort{01} + \ytableaushort{0,1}
+ \end{equation} *)
+
+ "completeness 2" >:: (fun () -> completeness 2 [ [[0;1]]; [[0];[1]] ]) ;
+
+ "completeness 2'" >::
+ (fun () ->
+ equal
+ (delta_unsymmetrized 2 1 2)
+ (delta_S 2 1 2 +++ delta_A 2 1 2));
+
+ (* The normalization factors are written for illustration. They are
+ added by [delta_of_tableau] automatically.
+ \ytableausetup{centertableaux,smalltableaux}
+ \begin{equation}
+ \ytableaushort{012}
+ + \frac{4}{3}\cdot\ytableaushort{01,2}
+ + \frac{4}{3}\cdot\ytableaushort{02,1}
+ + \ytableaushort{0,1,2}
+ \end{equation} *)
+
+ "completeness 3" >::
+ (fun () -> completeness 3 [ [[0;1;2]]; [[0;1];[2]]; [[0;2];[1]]; [[0];[1];[2]] ]);
+
+ "completeness 3'" >::
+ (fun () ->
+ equal
+ (delta_unsymmetrized 3 1 2)
+ (delta_S 3 1 2 +++ delta_SAS 1 2 +++ delta_ASA 1 2 +++ delta_A 3 1 2));
+
+ (* \ytableausetup{centertableaux,smalltableaux}
+ \begin{equation}
+ \ytableaushort{0123}
+ + \frac{3}{2}\cdot\ytableaushort{012,3}
+ + \frac{3}{2}\cdot\ytableaushort{013,2}
+ + \frac{3}{2}\cdot\ytableaushort{023,1}
+ + \frac{4}{3}\cdot\ytableaushort{01,23}
+ + \frac{4}{3}\cdot\ytableaushort{02,13}
+ + \frac{3}{2}\cdot\ytableaushort{01,2,3}
+ + \frac{3}{2}\cdot\ytableaushort{02,1,3}
+ + \frac{3}{2}\cdot\ytableaushort{03,1,2}
+ + \ytableaushort{0,1,2,3}
+ \end{equation} *)
+
+ "completeness 4" >::
+ (fun () ->
+ completeness 4
+ [ [[0;1;2;3]];
+ [[0;1;2];[3]]; [[0;1;3];[2]]; [[0;2;3];[1]];
+ [[0;1];[2;3]]; [[0;2];[1;3]];
+ [[0;1];[2];[3]]; [[0;2];[1];[3]]; [[0;3];[1];[2]];
+ [[0];[1];[2];[3]] ]) ]
+
+ (* \thocwmodulesubsection{Normalization} *)
+
+ let suite_normalization =
+ "normalization" >:::
+
+ [ "tr(t*t)" >:: (* $\tr(T_aT_b)=\delta_{ab} + \text{ghosts}$ *)
+ (fun () ->
+ equal
+ (delta8_loop 1 2)
+ (t 1 (-1) (-2) *** t 2 (-2) (-1)));
+
+ "tr(t*t) sans ghosts" >:: (* $\tr(T_aT_b)=\delta_{ab}$ *)
+ (fun () ->
+ exorcised_equal
+ (delta8 1 2)
+ (t 1 (-1) (-2) *** t 2 (-2) (-1)));
+
+ (* The additional ghostly terms were unexpected, but
+ arises like~(6.2) in our color flow paper~\cite{Kilian:2012pz}. *)
+ "t*t*t" >:: (* $T_aT_bT_a=-T_b/N_C + \ldots$ *)
+ (fun () ->
+ equal
+ (minus *** over_nc *** t 1 2 3
+ +++ [Arrows { coeff = L.int 1; arrows = [1 => 1; 3 => 2] };
+ Arrows { coeff = L.nc (-1); arrows = [3 => 2; ?? 1] }])
+ (t (-1) 2 (-2) *** t 1 (-2) (-3) *** t (-1) (-3) 3));
+
+ (* As expected, these ghostly terms cancel in the summed squares
+ \begin{equation}
+ \tr(T_aT_bT_aT_cT_bT_c)
+ = \tr(T_bT_b)/N_C^2
+ = \delta_{bb}/N_C^2
+ = (N_C^2-1) / N_C^2
+ = 1 - 1 / N_C^2
+ \end{equation} *)
+ "sum((t*t*t)^2)" >::
+ (fun () ->
+ equal
+ (ints [(1, 0); (-1, -2)])
+ (t (-1) (-11) (-12) *** t (-2) (-12) (-13) *** t (-1) (-13) (-14)
+ *** t (-3) (-14) (-15) *** t (-2) (-15) (-16) *** t (-3) (-16) (-11)));
+
+ "d*d" >::
+ (fun () ->
+ exorcised_equal
+ [ Arrows { coeff = L.ints [(2, 1); (-8,-1)]; arrows = 1 <=> 2 };
+ Arrows { coeff = L.ints [(2, 0); ( 4,-2)]; arrows = [1=>1; 2=>2] }]
+ (d 1 (-1) (-2) *** d 2 (-2) (-1))) ]
+
+
+ (* As proposed in our color flow paper~\cite{Kilian:2012pz},
+ we can get the correct (anti-)symmetrized generators
+ by sandwiching the following unsymmetrized generators
+ between the corresponding (anti-)symmetrized projectors.
+ Therefore, the unsymmetrized generators work as long as
+ they're used in Feynman diagrams, where they are connected
+ by propagators that contain (anti-)symmetrized projectors.
+ They even work in the Lie algebra relations and give the
+ correct normalization there.
+
+ They fail however for more general color algebra expressions
+ that can appear in UFO files.
+ In particular, the Casimir operators come out really wrong. *)
+
+ let t_unsymmetrized n k l =
+ t_of_delta (delta_unsymmetrized n) k l
+
+ (* The following trivial vertices are \emph{not} used anymore,
+ since they don't get the normalization of the Ward identities
+ right. For the quadratic casimir operators, they always produce a
+ result proportional to~$C_F=C_2(S_1)$. This can be understood because
+ they correspond to a fundamental representation with spectators.
+
+ (Anti-)symmetrizing by sandwiching with projectors almost works,
+ but they must be multiplied by hand by the number of arrows to get the
+ normalization right.
+ They're here just for documenting what doesn't work. *)
+ let t_trivial n a k l =
+ let sterile =
+ List.map (fun i -> (l, i) >=>> (k, i)) (ThoList.range 1 (pred n)) in
+ [ Arrows { coeff = L.int ( 1); arrows = ((l, 0) >=> a) :: (a =>> (k, 0)) :: sterile };
+ Arrows { coeff = L.int (-1); arrows = (?? a) :: ((l, 0) >=>> (k, 0)) :: sterile }]
+
+ let t6_trivial = t_trivial 2
+ let t10_trivial = t_trivial 3
+ let t15_trivial = t_trivial 4
+
+ let t_SAS = t_of_delta delta_SAS
+ let t_ASA = t_of_delta delta_ASA
+
+ let symmetrization ?rep_ts rep_tu rep_d =
+ let rep_ts =
+ match rep_ts with
+ | None -> rep_tu
+ | Some rep_t -> rep_t in
+ equal
+ (rep_ts 1 2 3)
+ (gluon 1 (-1) *** rep_d 2 (-2) *** rep_tu (-1) (-2) (-3) *** rep_d (-3) 3)
+
+ let suite_symmetrization =
+ "symmetrization" >:::
+
+ [ "t6" >:: (fun () -> symmetrization t6 delta6);
+ "t10" >:: (fun () -> symmetrization t10 delta10);
+ "t15" >:: (fun () -> symmetrization t15 delta15);
+ "t3bar" >:: (fun () -> symmetrization t3bar delta3bar);
+ "t_SAS" >:: (fun () -> symmetrization t_SAS delta_SAS);
+ "t_ASA" >:: (fun () -> symmetrization t_ASA delta_ASA);
+ "t6'" >:: (fun () -> symmetrization ~rep_ts:t6 (t_unsymmetrized 2) delta6);
+ "t10'" >:: (fun () -> symmetrization ~rep_ts:t10 (t_unsymmetrized 3) delta10);
+ "t15'" >:: (fun () -> symmetrization ~rep_ts:t15 (t_unsymmetrized 4) delta15);
+
+ "t6''" >::
+ (fun () ->
+ equal
+ (t6 1 2 3)
+ (int 2 *** delta6 2 (-1) *** t6_trivial 1 (-1) (-2) *** delta6 (-2) 3));
+
+ "t10''" >::
+ (fun () ->
+ equal
+ (t10 1 2 3)
+ (int 3 *** delta10 2 (-1) *** t10_trivial 1 (-1) (-2) *** delta10 (-2) 3));
+
+ "t15''" >::
+ (fun () ->
+ equal
+ (t15 1 2 3)
+ (int 4 *** delta15 2 (-1) *** t15_trivial 1 (-1) (-2) *** delta15 (-2) 3)) ]
+
+ (* \thocwmodulesubsection{Traces} *)
+
+ (* Compute (anti-)commutators of generators in the representation~$r$,
+ i.\,e.~$[r(t_a)r(t_b)]_{ij}\mp[r(t_b)r(t_a)]_{ij}$, using
+ [isum<0] as summation index in the matrix products. *)
+ let commutator rep_t i_sum a b i j =
+ multiply [rep_t a i i_sum; rep_t b i_sum j]
+ --- multiply [rep_t b i i_sum; rep_t a i_sum j]
+
+ let anti_commutator rep_t i_sum a b i j =
+ multiply [rep_t a i i_sum; rep_t b i_sum j]
+ +++ multiply [rep_t b i i_sum; rep_t a i_sum j]
+
+ (* Trace of the product of three generators in the representation~$r$,
+ i.\,e.~$\tr_r(r(t_a)r(t_b)r(t_c))$, using $-1,-2,-3$ as summation indices
+ in the matrix products. *)
+ let trace3 rep_t a b c =
+ rep_t a (-1) (-2) *** rep_t b (-2) (-3) *** rep_t c (-3) (-1)
+
+ let loop3 a b c =
+ [ Arrows { coeff = L.int 1; arrows = A.cycle (List.rev [a; b; c]) };
+ Arrows { coeff = L.int (-1); arrows = (a <=> b) @ [?? c] };
+ Arrows { coeff = L.int (-1); arrows = (b <=> c) @ [?? a] };
+ Arrows { coeff = L.int (-1); arrows = (c <=> a) @ [?? b] };
+ Arrows { coeff = L.int 1; arrows = [a => a; ?? b; ?? c] };
+ Arrows { coeff = L.int 1; arrows = [?? a; b => b; ?? c] };
+ Arrows { coeff = L.int 1; arrows = [?? a; ?? b; c => c] };
+ Arrows { coeff = L.nc (-1); arrows = [?? a; ?? b; ?? c] } ]
+
+ let suite_trace =
+ "trace" >:::
+
+ [ "tr(ttt)" >::
+ (fun () -> equal (trace3 t 1 2 3) (loop3 1 2 3));
+
+ "tr(ttt) cyclic 1" >:: (* $\tr(T_aT_bT_c)=\tr(T_bT_cT_a)$ *)
+ (fun () -> equal (trace3 t 1 2 3) (trace3 t 2 3 1));
+
+ "tr(ttt) cyclic 2" >:: (* $\tr(T_aT_bT_c)=\tr(T_cT_aT_b)$ *)
+ (fun () -> equal (trace3 t 1 2 3) (trace3 t 3 1 2));
+
+ (* \begin{dubious}
+ Do we expect this?
+ \end{dubious} *)
+ "tr(tttt)" >:: (* $\tr(T_aT_bT_cT_d)=\ldots$ *)
+ (fun () ->
+ exorcised_equal
+ [ Arrows { coeff = L.int 1; arrows = A.cycle [4; 3; 2; 1] }]
+ (t 1 (-1) (-2) *** t 2 (-2) (-3) *** t 3 (-3) (-4) *** t 4 (-4) (-1))) ]
+
+ let suite_ghosts =
+ "ghosts" >:::
+
+ [ "H->gg" >::
+ (fun () ->
+ equal
+ (delta8_loop 1 2)
+ (t 1 (-1) (-2) *** t 2 (-2) (-1)));
+
+ "H->ggg f" >::
+ (fun () ->
+ equal
+ (imag *** f 1 2 3)
+ (trace3 t 1 2 3 --- trace3 t 1 3 2));
+
+ "H->ggg d" >::
+ (fun () ->
+ equal
+ (d 1 2 3)
+ (trace3 t 1 2 3 +++ trace3 t 1 3 2));
+
+ "H->ggg f'" >::
+ (fun () ->
+ equal
+ (imag *** f 1 2 3)
+ (t 1 (-3) (-2) *** commutator t (-1) 2 3 (-2) (-3)));
+
+ "H->ggg d'" >::
+ (fun () ->
+ equal
+ (d 1 2 3)
+ (t 1 (-3) (-2) *** anti_commutator t (-1) 2 3 (-2) (-3)));
+
+ "H->ggg cyclic'" >::
+ (fun () ->
+ let trace a b c =
+ t a (-3) (-2) *** commutator t (-1) b c (-2) (-3) in
+ equal (trace 1 2 3) (trace 2 3 1)) ]
+
+ let ff a1 a2 a3 a4 =
+ [ Arrows { coeff = L.int (-1); arrows = A.cycle [a1; a2; a3; a4] };
+ Arrows { coeff = L.int ( 1); arrows = A.cycle [a2; a1; a3; a4] };
+ Arrows { coeff = L.int ( 1); arrows = A.cycle [a1; a2; a4; a3] };
+ Arrows { coeff = L.int (-1); arrows = A.cycle [a2; a1; a4; a3] } ]
+
+ let tf j i a b =
+ [ Arrows { coeff = L.imag ( 1); arrows = A.chain [i; a; b; j] };
+ Arrows { coeff = L.imag (-1); arrows = A.chain [i; b; a; j] } ]
+
+ let suite_ff =
+ "f*f" >:::
+ [ "1" >:: (fun () -> equal (ff 1 2 3 4) (f (-1) 1 2 *** f (-1) 3 4));
+ "2" >:: (fun () -> equal (ff 1 2 3 4) (f (-1) 1 2 *** f 3 4 (-1)));
+ "3" >:: (fun () -> equal (ff 1 2 3 4) (f (-1) 1 2 *** f 4 (-1) 3)) ]
+
+ let suite_tf =
+ "t*f" >:::
+ [ "1" >:: (fun () -> equal (tf 1 2 3 4) (t (-1) 1 2 *** f (-1) 3 4)) ]
+
+ (* \thocwmodulesubsection{Completeness Relation} *)
+
+ (* Check the completeness relation corresponding
+ to $q\bar q$-scattering:
+ \begin{equation}
+ \parbox{38\unitlength}{%
+ \fmfframe(4,2)(4,4){%
+ \begin{fmfgraph*}(30,20)
+ \setupFourAmp
+ \fmflabel{$i$}{i2}
+ \fmflabel{$j$}{i1}
+ \fmflabel{$k$}{o1}
+ \fmflabel{$l$}{o2}
+ \fmf{fermion}{i1,v1,i2}
+ \fmf{fermion}{o2,v2,o1}
+ \fmf{gluon}{v1,v2}
+ \end{fmfgraph*}}} =
+ \parbox{38\unitlength}{%
+ \fmfframe(4,2)(4,4){%
+ \begin{fmfgraph*}(30,20)
+ \setupFourAmp
+ \fmflabel{$i$}{i2}
+ \fmflabel{$j$}{i1}
+ \fmflabel{$k$}{o1}
+ \fmflabel{$l$}{o2}
+ \fmfi{phantom_arrow}{vpath (__i1, __v1)}
+ \fmfi{phantom_arrow}{vpath (__v1, __v2) sideways -thick}
+ \fmfi{phantom_arrow}{vpath (__v2, __o1)}
+ \fmfi{phantom_arrow}{vpath (__o2, __v2)}
+ \fmfi{phantom_arrow}{reverse vpath (__v1, __v2) sideways -thick}
+ \fmfi{phantom_arrow}{vpath (__v1, __i2)}
+ \fmfi{plain}{vpath (__i1, __v1) join
+ (vpath (__v1, __v2) sideways -thick) join
+ vpath (__v2, __o1)}
+ \fmfi{plain}{vpath (__o2, __v2) join
+ (reverse vpath (__v1, __v2) sideways -thick) join
+ vpath (__v1, __i2)}
+ \end{fmfgraph*}}} +
+ \parbox{38\unitlength}{%
+ \fmfframe(4,2)(4,4){%
+ \begin{fmfgraph*}(30,20)
+ \setupFourAmp
+ \fmflabel{$i$}{i2}
+ \fmflabel{$j$}{i1}
+ \fmflabel{$k$}{o1}
+ \fmflabel{$l$}{o2}
+ \fmfi{phantom_arrow}{vpath (__i1, __v1)}
+ \fmfi{phantom_arrow}{vpath (__v2, __o1)}
+ \fmfi{phantom_arrow}{vpath (__o2, __v2)}
+ \fmfi{phantom_arrow}{vpath (__v1, __i2)}
+ \fmfi{plain}{vpath (__i1, __v1) join
+ vpath (__v1, __i2)}
+ \fmfi{plain}{vpath (__o2, __v2) join
+ vpath (__v2, __o1)}
+ \fmfi{dots,label=$-1/N_C$}{vpath (__v1, __v2)}
+ \end{fmfgraph*}}}
+ \end{equation} *)
+
+ (* $T_{a}^{ij} T_{a}^{kl}$ *)
+ let tt i j k l =
+ t (-1) i j *** t (-1) k l
+
+ (* $ \delta^{il}\delta^{kj} - \delta^{ij}\delta^{kl}/N_C$ *)
+ let tt_expected i j k l =
+ [ Arrows { coeff = L.int 1; arrows = [l => i; j => k] };
+ Arrows { coeff = L.over_nc (-1); arrows = [j => i; l => k] }]
+
+ let suite_tt =
+ "t*t" >:::
+ [ "1" >:: (* $T_{a}^{ij} T_{a}^{kl} = \delta^{il}\delta^{kj} - \delta^{ij}\delta^{kl}/N_C$ *)
+ (fun () -> equal (tt_expected 1 2 3 4) (tt 1 2 3 4)) ]
+
+ (* \thocwmodulesubsection{Lie Algebra} *)
+
+ (* Check the commutation relations $[T_a,T_b]=\ii f_{abc} T_c$
+ in various representations. *)
+ let lie_algebra_id rep_t =
+ let lhs = imag *** f 1 2 (-1) *** t (-1) 3 4
+ and rhs = commutator t (-1) 1 2 3 4 in
+ equal lhs rhs
+
+ (* Check the normalization of the structure consistants
+ $\mathcal{N} f_{abc} = - \ii \tr(T_a[T_b,T_c])$ *)
+ let f_of_rep_id norm rep_t =
+ let lhs = norm *** f 1 2 3
+ and rhs = f_of_rep rep_t 1 2 3 in
+ equal lhs rhs
+
+ (* \begin{dubious}
+ Are the normalization factors for the traces of the higher dimensional
+ representations correct?
+ \end{dubious} *)
+ (* \begin{dubious}
+ The traces don't work for the symmetrized generators
+ that we need elsewhere!
+ \end{dubious} *)
+ let suite_lie =
+ "Lie algebra relations" >:::
+ [ "[t,t]=ift" >:: (fun () -> lie_algebra_id t);
+ "[t8,t8]=ift8" >:: (fun () -> lie_algebra_id t8);
+ "[t6,t6]=ift6" >:: (fun () -> lie_algebra_id t6);
+ "[t10,t10]=ift10" >:: (fun () -> lie_algebra_id t10);
+ "[t15,t15]=ift15" >:: (fun () -> lie_algebra_id t15);
+ "[t3bar,t3bar]=ift3bar" >:: (fun () -> lie_algebra_id t3bar);
+ "[tSAS,tSAS]=iftSAS" >:: (fun () -> lie_algebra_id t_SAS);
+ "[tASA,tASA]=iftASA" >:: (fun () -> lie_algebra_id t_ASA);
+ "[t6,t6]=ift6'" >:: (fun () -> lie_algebra_id (t_unsymmetrized 2));
+ "[t10,t10]=ift10'" >:: (fun () -> lie_algebra_id (t_unsymmetrized 3));
+ "[t15,t15]=ift15'" >:: (fun () -> lie_algebra_id (t_unsymmetrized 4));
+ "[t6,t6]=ift6''" >:: (fun () -> lie_algebra_id t6_trivial);
+ "[t10,t10]=ift10''" >:: (fun () -> lie_algebra_id t10_trivial);
+ "[t15,t15]=ift15''" >:: (fun () -> lie_algebra_id t15_trivial);
+ "if = tr(t[t,t])" >:: (fun () -> f_of_rep_id one t);
+ "2n*if = tr(t8[t8,t8])" >:: (fun () -> f_of_rep_id (two *** nc) t8);
+ "n*if = tr(t6[t6,t6])" >:: (fun () -> f_of_rep_id nc t6_trivial);
+ "n^2*if = tr(t10[t10,t10])" >:: (fun () -> f_of_rep_id (nc *** nc) t10_trivial);
+ "n^3*if = tr(t15[t15,t15])" >:: (fun () -> f_of_rep_id (nc *** nc *** nc) t15_trivial) ]
+
+ (* \thocwmodulesubsection{Ward Identities} *)
+
+ (* Testing the color part of basic Ward identities is essentially
+ the same as testing the Lie algebra equations above, but with
+ generators sandwiched between propagators, as in Feynman diagrams,
+ where the relative signs come from the kinematic part of the
+ diagrams after applying the equations of motion.. *)
+
+ (* First the diagram with the three gluon vertex
+ $\ii f_{abc} D_{cd}^{\text{gluon}} D^{ik} T_d^{kl} D^{lj}$ *)
+ let ward_ft rep_t rep_d a b i j =
+ imag *** f a b (-11) *** gluon (-11) (-12)
+ *** rep_d i (-1) *** rep_t (-12) (-1) (-2) *** rep_d (-2) j
+
+ (* then one diagram with two gauge couplings
+ $D^{ik} T_c^{kl} D^{lm} T_c^{mn} D^{nj}$ *)
+ let ward_tt1 rep_t rep_d a b i j =
+ rep_d i (-1) *** rep_t a (-1) (-2) *** rep_d (-2) (-3)
+ *** rep_t b (-3) (-4) *** rep_d (-4) j
+
+ (* finally the difference of exchanged orders:
+ $D^{ik} T_a^{kl} D^{lm} T_b^{mn} D^{nj}
+ -D^{ik} T_b^{kl} D^{lm} T_a^{mn} D^{nj}$ *)
+ let ward_tt rep_t rep_d a b i j =
+ ward_tt1 rep_t rep_d a b i j --- ward_tt1 rep_t rep_d b a i j
+
+ (* \begin{dubious}
+ The optional [~fudge] factor was used for
+ debugging normalizations.
+ \end{dubious} *)
+ let ward_id ?(fudge=one) rep_t rep_d =
+ let lhs = ward_ft rep_t rep_d 1 2 3 4
+ and rhs = ward_tt rep_t rep_d 1 2 3 4 in
+ equal lhs (fudge *** rhs)
+
+ let suite_ward =
+ "Ward identities" >:::
+ [ "fund." >:: (fun () -> ward_id t delta3);
+ "adj." >:: (fun () -> ward_id t8 delta8);
+ "S2" >:: (fun () -> ward_id t6 delta6);
+ "S3" >:: (fun () -> ward_id t10 delta10);
+ "A2" >:: (fun () -> ward_id t3bar delta3bar);
+ "A3" >:: (fun () -> ward_id (t_A 3) (delta_A 3));
+ "SAS" >:: (fun () -> ward_id t_SAS delta_SAS);
+ "ASA" >:: (fun () -> ward_id t_ASA delta_ASA);
+ "S2'" >:: (fun () -> ward_id ~fudge:two t6_trivial delta6);
+ "S3'" >:: (fun () -> ward_id ~fudge:(int 3) t10_trivial delta10) ]
+
+ let suite_ward_long =
+ "Ward identities" >:::
+ [ "S4" >:: (fun () -> ward_id t15 delta15);
+ "S4'" >:: (fun () -> ward_id ~fudge:(int 4) t15_trivial delta15) ]
+
+ (* \thocwmodulesubsection{Jacobi Identities} *)
+
+ (* $T_aT_bT_c$ *)
+ let prod3 rep_t a b c i j =
+ rep_t a i (-1) *** rep_t b (-1) (-2) *** rep_t c (-2) j
+
+ (* $[T_a,[T_b,T_c]]$ *)
+ let jacobi1 rep_t a b c i j =
+ (prod3 rep_t a b c i j --- prod3 rep_t a c b i j)
+ --- (prod3 rep_t b c a i j --- prod3 rep_t c b a i j)
+
+ (* sum of cyclic permutations of $[T_a,[T_b,T_c]]$ *)
+ let jacobi rep_t =
+ sum [jacobi1 rep_t 1 2 3 4 5;
+ jacobi1 rep_t 2 3 1 4 5;
+ jacobi1 rep_t 3 1 2 4 5]
+
+ let jacobi_id rep_t =
+ assert_zero_vertex (jacobi rep_t)
+
+ let suite_jacobi =
+ "Jacobi identities" >:::
+ [ "fund." >:: (fun () -> jacobi_id t);
+ "adj." >:: (fun () -> jacobi_id f);
+ "S2" >:: (fun () -> jacobi_id t6);
+ "S3" >:: (fun () -> jacobi_id t10);
+ "A2" >:: (fun () -> jacobi_id (t_A 2));
+ "A3" >:: (fun () -> jacobi_id (t_A 3));
+ "SAS" >:: (fun () -> jacobi_id t_SAS);
+ "ASA" >:: (fun () -> jacobi_id t_ASA);
+ "S2'" >:: (fun () -> jacobi_id t6_trivial);
+ "S3'" >:: (fun () -> jacobi_id t10_trivial) ]
+
+ let suite_jacobi_long =
+ "Jacobi identities" >:::
+ [ "S4" >:: (fun () -> jacobi_id t15);
+ "S4'" >:: (fun () -> jacobi_id t15_trivial) ]
+
+ (* \thocwmodulesubsection{Casimir Operators}
+ \label{pg:casimir-tests} *)
+
+ (* We can read of the eigenvalues of the Casimir operators for
+ the adjoint, totally symmetric and totally antisymmetric
+ representations of~$\mathrm{SU}(N)$ from table~II of
+ \texttt{hep-ph/0611341}
+ \begin{subequations}
+ \begin{align}
+ C_2(\text{adj}) &= 2N \\
+ C_2(S_n) &= \frac{n(N-1)(N+n)}{N} \\
+ \label{eq:C_2(A_n)}
+ C_2(A_n) &= \frac{n(N-n)(N+1)}{N}
+ \end{align}
+ \end{subequations}
+ adjusted for our normalization.
+ Also from \texttt{arxiv:1912.13302}
+ \begin{equation}
+ C_3(S_1) =(N^2-1)(N^2-4)/N^2=\frac{N_C^4-5N_C^2+4}{N_C^2}
+ \end{equation} *)
+
+ (* Building blocks $n/N_C$ and $N_C+n$ *)
+ let n_over_nc n = const (L.ints [ (n, -1) ])
+ let nc_plus n = const (L.ints [ (1, 1); (n,0) ])
+
+ (* $C_2(S_n) = n/N_C(N_C-1)(N_C+n)$ *)
+ let c2_S n = n_over_nc n *** nc_plus (-1) *** nc_plus n
+
+ (* $C_2(A_n) = n/N_C(N_C-n)(N_C+1)$ *)
+ let c2_A n = n_over_nc n *** nc_plus (-n) *** nc_plus 1
+
+ let casimir_tt i j = c2_S 1 *** delta3 i j
+ let casimir_t6t6 i j = c2_S 2 *** delta6 i j
+ let casimir_t10t10 i j = c2_S 3 *** delta10 i j
+ let casimir_t15t15 i j = c2_S 4 *** delta15 i j
+ let casimir_t3bart3bar i j = c2_A 2 *** delta3bar i j
+ let casimir_tA3tA3 i j = c2_A 3 *** delta_A 3 i j
+
+ (* $C_2(\text{adj})=2N_C$ *)
+ let ca = L.ints [(2, 1)]
+ let casimir_ff a b =
+ [ Arrows { coeff = ca; arrows = 1 <=> 2 };
+ Arrows { coeff = L.int (-2); arrows = [1=>1; 2=>2] }]
+
+ (* $C_3(S_1)=N_C^2-5+4/N_C^2$ *)
+ let c3f = L.ints [(1, 2); (-5, 0); (4, -2)]
+ let casimir_ttt i j = const c3f *** delta3 i j
+
+ let suite_casimir =
+ "Casimir operators" >:::
+
+ [ "t*t" >::
+ (fun () ->
+ equal
+ (casimir_tt 1 2)
+ (t (-1) 1 (-2) *** t (-1) (-2) 2));
+
+ "t*t*t" >::
+ (fun () ->
+ equal
+ (casimir_ttt 1 2)
+ (d (-1) (-2) (-3) ***
+ t (-1) 1 (-4) *** t (-2) (-4) (-5) *** t (-3) (-5) 2));
+
+ "f*f" >::
+ (fun () ->
+ equal
+ (casimir_ff 1 2)
+ (minus *** f (-1) 1 (-2) *** f (-1) (-2) 2));
+
+ "t6*t6" >::
+ (fun () ->
+ equal
+ (casimir_t6t6 1 2)
+ (t6 (-1) 1 (-2) *** t6 (-1) (-2) 2));
+
+ "t3bar*t3bar" >::
+ (fun () ->
+ equal
+ (casimir_t3bart3bar 1 2)
+ (t3bar (-1) 1 (-2) *** t3bar (-1) (-2) 2));
+
+ "tA3*tA3" >::
+ (fun () ->
+ equal
+ (casimir_tA3tA3 1 2)
+ (t_A 3 (-1) 1 (-2) *** t_A 3 (-1) (-2) 2));
+
+ "t_SAS*t_SAS" >::
+ (fun () ->
+ equal
+ (const (L.ints [(3,1); (-9,-1)]) *** delta_SAS 1 2)
+ (t_SAS (-1) 1 (-2) *** t_SAS (-1) (-2) 2));
+
+ "t_ASA*t_ASA" >::
+ (fun () ->
+ equal
+ (const (L.ints [(3,1); (-9,-1)]) *** delta_ASA 1 2)
+ (t_ASA (-1) 1 (-2) *** t_ASA (-1) (-2) 2));
+
+ "t10*t10" >::
+ (fun () ->
+ equal
+ (casimir_t10t10 1 2)
+ (t10 (-1) 1 (-2) *** t10 (-1) (-2) 2)) ]
+
+ let suite_casimir_long =
+ "Casimir operators" >:::
+
+ [ "t15*t15" >::
+ (fun () ->
+ equal
+ (casimir_t15t15 1 2)
+ (t15 (-1) 1 (-2) *** t15 (-1) (-2) 2)) ]
+
+ (* \thocwmodulesubsection{Color Sums} *)
+
+ let suite_colorsums =
+ "(squared) color sums" >:::
+
+ [ "gluon normalization" >::
+ (fun () ->
+ equal
+ (delta8 1 2)
+ (delta8 1 (-1) *** gluon (-1) (-2) *** delta8 (-2) 2));
+
+ "f*f" >::
+ (fun () ->
+ let sum_ff =
+ multiply [ f (-11) (-12) (-13);
+ f (-21) (-22) (-23);
+ gluon (-11) (-21);
+ gluon (-12) (-22);
+ gluon (-13) (-23) ]
+ and expected = ints [(2, 3); (-2, 1)] in
+ equal expected sum_ff);
+
+ "d*d" >::
+ (fun () ->
+ let sum_dd =
+ multiply [ d (-11) (-12) (-13);
+ d (-21) (-22) (-23);
+ gluon (-11) (-21);
+ gluon (-12) (-22);
+ gluon (-13) (-23) ]
+ and expected = ints [(2, 3); (-10, 1); (8, -1)] in
+ equal expected sum_dd);
+
+ "f*d" >::
+ (fun () ->
+ let sum_fd =
+ multiply [ f (-11) (-12) (-13);
+ d (-21) (-22) (-23);
+ gluon (-11) (-21);
+ gluon (-12) (-22);
+ gluon (-13) (-23) ] in
+ assert_zero_vertex sum_fd);
+
+ "Hgg" >::
+ (fun () ->
+ let sum_hgg =
+ multiply [ delta8_loop (-11) (-12);
+ delta8_loop (-21) (-22);
+ gluon (-11) (-21);
+ gluon (-12) (-22) ]
+ and expected = ints [(1, 2); (-1, 0)] in
+ equal expected sum_hgg) ]
+
+ let suite =
+ "SU3" >:::
+ [suite_sum;
+ suite_diff;
+ suite_times;
+ suite_normalization;
+ suite_symmetrization;
+ suite_ghosts;
+ suite_propagators;
+ suite_trace;
+ suite_ff;
+ suite_tf;
+ suite_tt;
+ suite_lie;
+ suite_ward;
+ suite_jacobi;
+ suite_casimir;
+ suite_colorsums]
+
+ let suite_long =
+ "SU3 long" >:::
+ [suite_ward_long;
+ suite_jacobi_long;
+ suite_casimir_long]
+
+ end
+
Index: trunk/omega/src/modellib_PSSSM.ml
===================================================================
--- trunk/omega/src/modellib_PSSSM.ml (revision 8899)
+++ trunk/omega/src/modellib_PSSSM.ml (revision 8900)
@@ -1,1974 +1,1978 @@
(* modellib_PSSSM.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
(* \thocwmodulesection{Extended Supersymmetric Standard Model(s)} *)
(* This is based on the NMSSM implementation by Felix Braam, and extended to
the exotica -- leptoquarks, leptoquarkinos, additional Higgses etc. -- by
Daniel Wiesler. Note that for the Higgs sector vertices the conventions of
the Franke/Fraas paper have been used. *)
module type extMSSM_flags =
sig
val ckm_present : bool
end
module PSSSM : extMSSM_flags =
struct
let ckm_present = false
end
module PSSSM_QCD : extMSSM_flags =
struct
let ckm_present = false
end
module ExtMSSM (Flags : extMSSM_flags) =
struct
open Coupling
let default_width = ref Timelike
let use_fudged_width = ref false
let options = Options.create
[ "constant_width", Arg.Unit (fun () -> default_width := Constant),
"use constant width (also in t-channel)";
"fudged_width", Arg.Set use_fudged_width,
"use fudge factor for charge particle width";
"custom_width", Arg.String (fun f -> default_width := Custom f),
"use custom width";
"cancel_widths", Arg.Unit (fun () -> default_width := Vanishing),
"use vanishing width";
"cms_width", Arg.Unit (fun () -> default_width := Complex_Mass),
"use complex mass scheme";
"running_width", Arg.Unit (fun () -> default_width := Running),
"use running width"]
let caveats () = []
(*additional combinatorics *)
(* yields a list of tuples consistig of the off-diag combinations of the elements in "set" *)
let choose2 set =
List.map (function [x;y] -> (x,y) | _ -> failwith "choose2")
(Combinatorics.choose 2 set)
(* [pairs] *)
(* [pairs] appends the diagonal combinations to [choose2] *)
let rec diag = function
| [] -> []
| x1 :: rest -> (x1, x1) :: diag rest
let pairs l = choose2 l @ diag l
(* [triples] *)
(* rank 3 generalization of [pairs] *)
let rec cloop set i j k =
if i > ((List.length set)-1) then []
else if j > i then cloop set (succ i) (j-i-1) (j-i-1)
else if k > j then cloop set i (succ j) (k-j-1)
else (List.nth set i, List.nth set j, List.nth set k) :: cloop set i j (succ k)
let triples set = cloop set 0 0 0
(* [two_and_one] *)
let rec two_and_one' l1 z n =
if n < 0 then []
else
((fst (List.nth (pairs l1) n)),(snd (List.nth (pairs l1) n)), z):: two_and_one' l1 z (pred n)
let two_and_one l1 l2 =
let f z = two_and_one' l1 z ((List.length (pairs l1))-1)
in
List.flatten ( List.map f l2 )
type gen =
| G of int | GG of gen*gen
let rec string_of_gen = function
| G n when n > 0 -> string_of_int n
| G n -> string_of_int (abs n) ^ "c"
| GG (g1,g2) -> string_of_gen g1 ^ "_" ^ string_of_gen g2
(* With this we distinguish the flavour. *)
type sff =
| SL | SN | SU | SD
let string_of_sff = function
| SL -> "sl" | SN -> "sn" | SU -> "su" | SD -> "sd"
(* With this we distinguish the mass eigenstates. At the moment we have to cheat
a little bit for the sneutrinos. Because we are dealing with massless
neutrinos there is only one sort of sneutrino. *)
type sfm =
| M1 | M2
- let string_of_sfm = function
+ let string_of_sfm = function
| M1 -> "1" | M2 -> "2"
(* We also introduce special types for the charginos and neutralinos. *)
type char =
| C1 | C2 | C1c | C2c | C3 | C3c | C4 | C4c
type neu =
| N1 | N2 | N3 | N4 | N5 | N6 | N7 | N8 | N9 | N10 | N11
let int_of_char = function
| C1 -> 1 | C2 -> 2 | C1c -> -1 | C2c -> -2
| C3 -> 3 | C4 -> 4 | C3c -> -3 | C4c -> -4
let string_of_char c = string_of_int (int_of_char c)
let conj_char = function
| C1 -> C1c | C2 -> C2c | C1c -> C1 | C2c -> C2
| C3 -> C3c | C4 -> C4c | C3c -> C3 | C4c -> C4
let string_of_neu = function
| N1 -> "1" | N2 -> "2" | N3 -> "3" | N4 -> "4" | N5 -> "5" | N6 -> "6"
| N7 -> "7" | N8 -> "8" | N9 -> "9" | N10 -> "10"| N11 -> "11"
(* For NMSSM-like the Higgs bosons, we follow the conventions of
Franke/Fraas. Daniel Wiesler: extended to E6 models. *)
type shiggs =
| S1 | S2 | S3 | S4 | S5 | S6 | S7 | S8 | S9
type phiggs =
| P1 | P2 | P3 | P4 | P5 | P6 | P7
(* [HCx] is always the $H^+$, [HCxc] the $H^-$. *)
type chiggs =
| HC1 | HC2 | HC3 | HC4 | HC5 | HC1c | HC2c | HC3c | HC4c | HC5c
let conj_chiggs = function
| HC1 -> HC1c | HC2 -> HC2c | HC1c -> HC1 | HC2c -> HC2
| HC3 -> HC3c | HC4 -> HC4c | HC3c -> HC3 | HC4c -> HC4
| HC5 -> HC5c | HC5c -> HC5
let string_of_shiggs = function
| S1 -> "1" | S2 -> "2" | S3 -> "3" | S4 -> "4" | S5 -> "5"
| S6 -> "6" | S7 -> "7" | S8 -> "8" | S9 -> "9"
let string_of_phiggs = function
| P1 -> "1" | P2 -> "2" | P3 -> "3" | P4 -> "4" | P5 -> "5"
| P6 -> "6" | P7 -> "7"
let nlist = [ N1; N2; N3; N4; N5; N6; N7; N8; N9; N10; N11 ]
let slist = [ S1; S2; S3; S4; S5; S6; S7; S8; S9 ]
let plist = [ P1; P2; P3; P4; P5; P6; P7 ]
let clist = [ HC1; HC2; HC3; HC4; HC5; HC1c; HC2c; HC3c; HC4c; HC5c ]
let charlist = [ C1; C2; C3; C4; C1c; C2c; C3c; C4c ]
type flavor =
| L of int | N of int
| U of int | D of int
| Sup of sfm*int | Sdown of sfm*int
| Ga | Wp | Wm | Z | Gl
| Slepton of sfm*int | Sneutrino of int
| Neutralino of neu | Chargino of char
| Gluino | SHiggs of shiggs | PHiggs of phiggs
| CHiggs of chiggs
| LQ of sfm*int
| LQino of int
let string_of_fermion_type = function
| L _ -> "l" | U _ -> "u" | D _ -> "d" | N _ -> "n"
| _ -> failwith
"Modellib_PSSSM.ExtMSSM.string_of_fermion_type: invalid fermion type"
let string_of_fermion_gen = function
| L g | U g | D g | N g -> string_of_int (abs (g))
| _ -> failwith
"Modellib_PSSSM.ExtMSSM.string_of_fermion_gen: invalid fermion type"
type gauge = unit
let gauge_symbol () =
failwith "Modellib_PSSSM.ExtMSSM.gauge_symbol: internal error"
(* At this point we will forget graviton and -ino. *)
let family g = [ L g; N g; Slepton (M1,g);
Slepton (M2,g); Sneutrino g;
U g; D g; Sup (M1,g); Sup (M2,g);
Sdown (M1,g); Sdown (M2,g);
LQ (M1,g); LQ (M2,g); LQino g ]
let external_flavors () =
[ "1st Generation matter", ThoList.flatmap family [1; -1];
"2nd Generation matter", ThoList.flatmap family [2; -2];
"3rd Generation matter", ThoList.flatmap family [3; -3];
"Gauge Bosons", [Ga; Z; Wp; Wm; Gl];
"Charginos", List.map (fun a -> Chargino a) charlist;
"Neutralinos", List.map (fun a -> Neutralino a) nlist;
"Higgs Bosons", List.map (fun a -> SHiggs a) slist @
List.map (fun a -> PHiggs a) plist @
List.map (fun a -> CHiggs a) clist;
"Gluino", [Gluino]]
let flavors () = ThoList.flatmap snd (external_flavors ())
let spinor n m =
if n >= 0 && m >= 0 then
Spinor
else if
n <= 0 && m <=0 then
ConjSpinor
else
invalid_arg "Modellib_PSSSM.ExtMSSM.spinor: internal error"
let lorentz = function
| L g -> spinor g 0 | N g -> spinor g 0
| U g -> spinor g 0 | D g -> spinor g 0
| LQino g -> spinor g 0
| Chargino c -> spinor (int_of_char c) 0
| Ga | Gl -> Vector
| Wp | Wm | Z -> Massive_Vector
| SHiggs _ | PHiggs _ | CHiggs _
| Sup _ | Sdown _ | Slepton _ | Sneutrino _ | LQ _ -> Scalar
| Neutralino _ | Gluino -> Majorana
let color = function
| U g -> Color.SUN (if g > 0 then 3 else -3)
| Sup (m,g) -> Color.SUN (if g > 0 then 3 else -3)
| D g -> Color.SUN (if g > 0 then 3 else -3)
| Sdown (m,g) -> Color.SUN (if g > 0 then 3 else -3)
| LQ (m,g) -> Color.SUN (if g > 0 then 3 else -3)
| LQino g -> Color.SUN (if g > 0 then 3 else -3)
| Gl | Gluino -> Color.AdjSUN 3
| _ -> Color.Singlet
let nc () = 3
let prop_spinor n m =
if n >= 0 && m >=0 then
Prop_Spinor
else if
n <=0 && m <=0 then
Prop_ConjSpinor
else
invalid_arg "Modellib_PSSSM.ExtMSSM.prop_spinor: internal error"
let propagator = function
| L g -> prop_spinor g 0 | N g -> prop_spinor g 0
| U g -> prop_spinor g 0 | D g -> prop_spinor g 0
| LQino g -> prop_spinor g 0
| Chargino c -> prop_spinor (int_of_char c) 0
| Ga | Gl -> Prop_Feynman
| Wp | Wm | Z -> Prop_Unitarity
| SHiggs _ | PHiggs _ | CHiggs _ -> Prop_Scalar
| Sup _ | Sdown _ | Slepton _ | Sneutrino _ -> Prop_Scalar
| LQ _ -> Prop_Scalar
| Gluino -> Prop_Majorana
| Neutralino _ -> Prop_Majorana
(* Optionally, ask for the fudge factor treatment for the widths of
charged particles. Currently, this only applies to $W^\pm$ and top. *)
let width f =
if !use_fudged_width then
match f with
| Wp | Wm | U 3 | U (-3) -> Fudged
| _ -> !default_width
else
!default_width
let goldstone _ = None
let conjugate = function
| L g -> L (-g) | N g -> N (-g)
| U g -> U (-g) | D g -> D (-g)
| Sup (m,g) -> Sup (m,-g)
| Sdown (m,g) -> Sdown (m,-g)
| Slepton (m,g) -> Slepton (m,-g)
| Sneutrino g -> Sneutrino (-g)
| Gl -> Gl | Ga -> Ga | Z -> Z
| Wp -> Wm | Wm -> Wp
| SHiggs s -> SHiggs s
| PHiggs p -> PHiggs p
| CHiggs c -> CHiggs (conj_chiggs c)
| Gluino -> Gluino
| Neutralino n -> Neutralino n | Chargino c -> Chargino (conj_char c)
| LQino g -> LQino (-g)
| LQ (m,g) -> LQ (m,-g)
let fermion = function
| L g -> if g > 0 then 1 else -1
| N g -> if g > 0 then 1 else -1
| U g -> if g > 0 then 1 else -1
| D g -> if g > 0 then 1 else -1
| Gl | Ga | Z | Wp | Wm -> 0
| SHiggs _ | PHiggs _ | CHiggs _ -> 0
| Neutralino _ -> 2
| Chargino c -> if (int_of_char c) > 0 then 1 else -1
| Sup _ -> 0 | Sdown _ -> 0
| Slepton _ -> 0 | Sneutrino _ -> 0
| Gluino -> 2
| LQ _ -> 0
| LQino g -> if g > 0 then 1 else -1
(* This model does NOT have a conserved generation quantum number. *)
module Ch = Charges.QQ
let ( // ) = Algebra.Small_Rational.make
let charge = function
| L n -> if n > 0 then -1//1 else 1//1
| Slepton (_,n) -> if n > 0 then -1//1 else 1//1
| N n -> 0//1
| Sneutrino n -> 0//1
| U n -> if n > 0 then 2//3 else -2//3
| Sup (_,n) -> if n > 0 then 2//3 else -2//3
| D n | LQ (_,n) | LQino n -> if n > 0 then -1//3 else 1//3
| Sdown (_,n) -> if n > 0 then -1//3 else 1//3
| Gl | Ga | Z | Neutralino _ | Gluino -> 0//1
| Wp -> 1//1
| Wm -> -1//1
| SHiggs _ | PHiggs _ -> 0//1
| CHiggs (HC1|HC2|HC3|HC4|HC5) -> 1//1
| CHiggs (HC1c|HC2c|HC3c|HC4c|HC5c) -> -1//1
| Chargino (C1|C2|C3|C4) -> 1//1
| Chargino (C1c|C2c|C3c|C4c) -> -1//1
let lepton = function
| L n | N n -> if n > 0 then 1//1 else -1//1
| Slepton (_,n)
| Sneutrino n -> if n > 0 then 1//1 else -1//1
| LQ (_,n) | LQino n -> if n > 0 then 1//1 else -1//1
| _ -> 0//1
let baryon = function
| U n | D n -> if n > 0 then 1//1 else -1//1
| Sup (_,n) | Sdown (_,n) -> if n > 0 then 1//1 else -1//1
| LQ (_,n) | LQino n -> if n > 0 then 1//1 else -1//1
| _ -> 0//1
let charges f =
[ charge f; lepton f; baryon f]
(* We introduce a Boolean type vc as a pseudonym for Vertex Conjugator to
distinguish between vertices containing complex mixing matrices like the
CKM--matrix or the sfermion or neutralino/chargino--mixing matrices, which
have to become complex conjugated. The true--option stands for the conjugated
vertex, the false--option for the unconjugated vertex. *)
type vc = bool
type constant =
| E | G
| Q_lepton | Q_up | Q_down | Q_charg
| G_Z | G_CC | G_CCQ of vc*int*int
| G_NC_neutrino | G_NC_lepton | G_NC_up | G_NC_down
| I_Q_W | I_G_ZWW | G_WWWW | G_ZZWW | G_PZWW | G_PPWW
| G_strong | G_SS | I_G_S
| Gs
| G_NZN of neu*neu | G_CZC of char*char
| G_YUK_FFS of flavor*flavor*shiggs
| G_YUK_FFP of flavor*flavor*phiggs
| G_YUK_LCN of int
| G_YUK_UCD of int*int | G_YUK_DCU of int*int
| G_NHC of vc*neu*char
| G_YUK_C of vc*flavor*char*sff*sfm
| G_YUK_Q of vc*int*flavor*char*sff*sfm
| G_YUK_N of vc*flavor*neu*sff*sfm
| G_YUK_G of vc*flavor*sff*sfm
| G_NWC of neu*char | G_CWN of char*neu
| G_CSC of char*char*shiggs
| G_CPC of char*char*phiggs
| G_WSQ of vc*int*int*sfm*sfm
| G_SLSNW of vc*int*sfm
| G_ZSF of sff*int*sfm*sfm
| G_CICIS of neu*neu*shiggs
| G_CICIP of neu*neu*phiggs
| G_GH_WPC of phiggs | G_GH_WSC of shiggs
| G_GH_ZSP of shiggs*phiggs | G_GH_WWS of shiggs
| G_GH_ZZS of shiggs | G_GH_ZCC
| G_GH_GaCC
| G_GH4_ZZPP of phiggs*phiggs
| G_GH4_ZZSS of shiggs*shiggs
| G_GH4_ZZCC | G_GH4_GaGaCC
| G_GH4_ZGaCC | G_GH4_WWCC
| G_GH4_WWPP of phiggs*phiggs
| G_GH4_WWSS of shiggs*shiggs
| G_GH4_ZWSC of shiggs
| G_GH4_GaWSC of shiggs
| G_GH4_ZWPC of phiggs
| G_GH4_GaWPC of phiggs
| G_WWSFSF of sff*int*sfm*sfm
| G_WPSLSN of vc*int*sfm
| G_H3_SCC of shiggs
| G_H3_SSS of shiggs*shiggs*shiggs
| G_H3_SPP of shiggs*phiggs*phiggs
| G_SFSFS of shiggs*sff*int*sfm*sfm
| G_SFSFP of phiggs*sff*int*sfm*sfm
| G_HSNSL of vc*int*sfm
| G_HSUSD of vc*sfm*sfm*int*int
| G_WPSUSD of vc*sfm*sfm*int*int
| G_WZSUSD of vc*sfm*sfm*int*int
| G_WZSLSN of vc*int*sfm | G_GlGlSQSQ
| G_PPSFSF of sff
| G_ZZSFSF of sff*int*sfm*sfm | G_ZPSFSF of sff*int*sfm*sfm
| G_GlZSFSF of sff*int*sfm*sfm | G_GlPSQSQ
| G_GlWSUSD of vc*sfm*sfm*int*int
| G_YUK_LQ_S of int*shiggs*int
| G_YUK_LQ_P of int*phiggs*int
| G_LQ_NEU of sfm*int*int*neu
| G_LQ_EC_UC of vc*sfm*int*int*int
| G_LQ_GG of sfm*int*int
| G_LQ_SSU of sfm*sfm*sfm*int*int*int
| G_LQ_SSD of sfm*sfm*int*int*int
| G_LQ_S of sfm*sfm*int*shiggs*int
| G_LQ_P of sfm*sfm*int*phiggs*int
| G_ZLQ of int*sfm*sfm
| G_ZZLQLQ | G_ZPLQLQ | G_PPLQLQ | G_ZGlLQLQ | G_PGlLQLQ | G_NLQC | G_GlGlLQLQ
(* Two integer counters for the QCD and EW order of the couplings. *)
- type orders = int * int
+ type coupling_order = QCD | EW
+ let all_coupling_orders () = [QCD; EW]
+ let coupling_order_to_string = function
+ | QCD -> "QCD"
+ | EW -> "EW"
- let orders = function
- | _ -> (0,0)
+ let coupling_orders = function
+ | _ -> failwith "Modellib_PSSSM.ExtMSSM.orders: not implemented yet!"
(* \begin{subequations}
\begin{align}
\alpha_{\text{QED}} &= \frac{1}{137.0359895} \\
\sin^2\theta_w &= 0.23124
\end{align}
\end{subequations}
Here we must perhaps allow for complex input parameters. So split them
into their modulus and their phase. At first, we leave them real; the
generalization to complex parameters is obvious. *)
let parameters () =
{ input = [];
derived = [];
derived_arrays = [] }
module F = Modeltools.Fusions (struct
type f = flavor
type c = constant
let compare = compare
let conjugate = conjugate
end)
(* For the couplings there are generally two possibilities concerning the
sign of the covariant derivative.
\begin{equation}
{\rm CD}^\pm = \partial_\mu \pm \ii g T^a A^a_\mu
\end{equation}
The particle data group defines the signs consistently to be positive.
Since the convention for that signs also influence the phase definitions
of the gaugino/higgsino fields via the off-diagonal entries in their
mass matrices it would be the best to adopt that convention. *)
(*** REVISED: Compatible with CD+. FB ***)
let electromagnetic_currents_3 g =
[ ((L (-g), Ga, L g), FBF (1, Psibar, V, Psi), Q_lepton);
((U (-g), Ga, U g), FBF (1, Psibar, V, Psi), Q_up);
((D (-g), Ga, D g), FBF (1, Psibar, V, Psi), Q_down)]
(*** REVISED: Compatible with CD+. FB***)
let electromagnetic_sfermion_currents g m =
[ ((Ga, Slepton (m,-g), Slepton (m,g)), Vector_Scalar_Scalar 1, Q_lepton);
((Ga, Sup (m,-g), Sup (m,g)), Vector_Scalar_Scalar 1, Q_up);
((Ga, Sdown (m,-g), Sdown (m,g)), Vector_Scalar_Scalar 1, Q_down)]
(*** REVISED: Compatible with CD+. FB***)
let electromagnetic_currents_2 c =
let cc = conj_char c in
[ ((Chargino cc, Ga, Chargino c), FBF (1, Psibar, V, Psi), Q_charg) ]
(*** REVISED: Compatible with CD+. FB***)
let neutral_currents g =
[ ((L (-g), Z, L g), FBF (1, Psibar, VA, Psi), G_NC_lepton);
((N (-g), Z, N g), FBF (1, Psibar, VA, Psi), G_NC_neutrino);
((U (-g), Z, U g), FBF (1, Psibar, VA, Psi), G_NC_up);
((D (-g), Z, D g), FBF (1, Psibar, VA, Psi), G_NC_down)]
(* \begin{equation}
\mathcal{L}_{\textrm{CC}} =
\mp \frac{g}{2\sqrt2} \sum_i \bar\psi_i \gamma^\mu
(1-\gamma_5)(T^+W^+_\mu+T^-W^-_\mu)\psi_i ,
\end{equation}
where the sign corresponds to $\text{CD}_\pm$, respectively. *)
(*** REVISED: Compatible with CD+. ***)
(* Remark: The definition with the other sign compared to the SM files
comes from the fact that $g_{cc} = 1/(2\sqrt{2})$ is used
overwhelmingly often in the SUSY Feynman rules, so that JR
decided to use a different definiton for [g_cc] in SM and MSSM. *)
(** FB **)
let charged_currents g =
[ ((L (-g), Wm, N g), FBF ((-1), Psibar, VL, Psi), G_CC);
((N (-g), Wp, L g), FBF ((-1), Psibar, VL, Psi), G_CC) ]
(* The quark with the inverted generation (the antiparticle) is the outgoing
one, the other the incoming. The vertex attached to the outgoing up-quark
contains the CKM matrix element {\em not} complex conjugated, while the
vertex with the outgoing down-quark has the conjugated CKM matrix
element. *)
(*** REVISED: Compatible with CD+. FB ***)
let charged_quark_currents g h =
[ ((D (-g), Wm, U h), FBF ((-1), Psibar, VL, Psi), G_CCQ (true,g,h));
((U (-g), Wp, D h), FBF ((-1), Psibar, VL, Psi), G_CCQ (false,h,g))]
(*** REVISED: Compatible with CD+.FB ***)
let charged_chargino_currents n c =
let cc = conj_char c in
[ ((Chargino cc, Wp, Neutralino n),
FBF (1, Psibar, VLR, Chi), G_CWN (c,n));
((Neutralino n, Wm, Chargino c),
FBF (1, Chibar, VLR, Psi), G_NWC (n,c)) ]
(*** REVISED: Compatible with CD+. FB***)
let charged_slepton_currents g m =
[ ((Wm, Slepton (m,-g), Sneutrino g), Vector_Scalar_Scalar (-1), G_SLSNW
(true,g,m));
((Wp, Slepton (m,g), Sneutrino (-g)), Vector_Scalar_Scalar 1, G_SLSNW
(false,g,m)) ]
(*** REVISED: Compatible with CD+. FB***)
let charged_squark_currents' g h m1 m2 =
[ ((Wm, Sup (m1,g), Sdown (m2,-h)), Vector_Scalar_Scalar (-1), G_WSQ
(true,g,h,m1,m2));
((Wp, Sup (m1,-g), Sdown (m2,h)), Vector_Scalar_Scalar 1, G_WSQ
(false,g,h,m1,m2)) ]
let charged_squark_currents g h =
List.flatten (Product.list2 (charged_squark_currents' g h) [M1;M2] [M1;M2] )
(*** REVISED: Compatible with CD+. FB ***)
let neutral_sfermion_currents' g m1 m2 =
[ ((Z, Slepton (m1,-g), Slepton (m2,g)), Vector_Scalar_Scalar (-1),
G_ZSF (SL,g,m1,m2));
((Z, Sup (m1,-g), Sup (m2,g)), Vector_Scalar_Scalar (-1),
G_ZSF (SU,g,m1,m2));
((Z, Sdown (m1,-g), Sdown (m2,g)), Vector_Scalar_Scalar (-1),
G_ZSF (SD,g,m1,m2))]
let neutral_sfermion_currents g =
List.flatten (Product.list2 (neutral_sfermion_currents'
g) [M1;M2] [M1;M2]) @
[ ((Z, Sneutrino (-g), Sneutrino g), Vector_Scalar_Scalar (-1),
G_ZSF (SN,g,M1,M1)) ]
(* The reality of the coupling of the Z-boson to two identical neutralinos
makes the vector part of the coupling vanish. So we distinguish them not
by the name but by the structure of the couplings. *)
(*** REVISED: Compatible with CD+. FB***)
let neutral_Z (n,m) =
[ ((Neutralino n, Z, Neutralino m), FBF (1, Chibar, VA, Chi),
(G_NZN (n,m))) ]
(*** REVISED: Compatible with CD+. FB***)
let charged_Z c1 c2 =
let cc1 = conj_char c1 in
((Chargino cc1, Z, Chargino c2), FBF ((-1), Psibar, VA , Psi),
G_CZC (c1,c2))
(*** REVISED: Compatible with CD+.
Remark: This is pure octet. FB***)
let yukawa_v =
[ (Gluino, Gl, Gluino), FBF (1, Chibar, V, Chi), Gs]
(*** REVISED: Independent of the sign of CD. ***)
(*** REVISED: Felix Braam: Compact version using new COMBOS + FF-Couplings *)
let yukawa_higgs_FFS f s =
[((conjugate f, SHiggs s, f ), FBF (1, Psibar, S, Psi),
G_YUK_FFS (conjugate f, f, s))]
let yukawa_higgs_FFP f p =
[((conjugate f, PHiggs p, f), FBF (1, Psibar, P, Psi),
G_YUK_FFP (conjugate f ,f , p))]
(* JR: Only the first charged Higgs. *)
let yukawa_higgs_NLC g =
[ ((N (-g), CHiggs HC1, L g), FBF (1, Psibar, Coupling.SR, Psi),
G_YUK_LCN g);
((L (-g), CHiggs HC1c, N g), FBF (1, Psibar, Coupling.SL, Psi),
G_YUK_LCN g)]
let yukawa_higgs g =
yukawa_higgs_NLC g @
List.flatten ( Product.list2 yukawa_higgs_FFS [L g; U g; D g] [S1; S2; S3]) @
List.flatten ( Product.list2 yukawa_higgs_FFP [L g; U g; D g] [P1; P2])
(* JR: Only the first charged Higgs. *)
(*** REVISED: Independent of the sign of CD. FB***)
let yukawa_higgs_quark (g,h) =
[ ((U (-g), CHiggs HC1, D h), FBF (1, Psibar, SLR, Psi),
G_YUK_UCD (g, h));
((D (-h), CHiggs HC1c, U g), FBF (1, Psibar, SLR, Psi),
G_YUK_DCU (g, h)) ]
(*** REVISED: Compatible with CD+.FB*)
(*** REVISED: Compact version using new COMBOS*)
let yukawa_shiggs_2 c1 c2 s =
let cc1 = conj_char c1 in
((Chargino cc1, SHiggs s, Chargino c2), FBF (1, Psibar, SLR, Psi),
G_CSC (c1,c2,s))
let yukawa_phiggs_2 c1 c2 p =
let cc1 = conj_char c1 in
((Chargino cc1, PHiggs p, Chargino c2), FBF (1, Psibar, SLR, Psi),
G_CPC (c1,c2,p))
let yukawa_higgs_2 =
Product.list3 yukawa_shiggs_2 [C1;C2] [C1;C2] [S1;S2;S3] @
Product.list3 yukawa_phiggs_2 [C1;C2] [C1;C2] [P1;P2]
(* JR: Only the first charged Higgs. *)
(*** REVISED: Compatible with CD+.FB ***)
let higgs_charg_neutr n c =
let cc = conj_char c in
[ ((Neutralino n, CHiggs HC1c, Chargino c), FBF (-1, Chibar, SLR, Psi),
G_NHC (false,n,c));
((Chargino cc, CHiggs HC1, Neutralino n), FBF (-1, Psibar, SLR, Chi),
G_NHC (true,n,c)) ]
(*** REVISED: Compatible with CD+. FB***)
(*** REVISED: Compact version using new COMBOS*)
let shiggs_neutr (n,m,s) =
((Neutralino n, SHiggs s, Neutralino m), FBF (1, Chibar, SP, Chi),
G_CICIS (n,m,s))
let phiggs_neutr (n,m,p) =
((Neutralino n, PHiggs p, Neutralino m), FBF (1, Chibar, SP, Chi),
G_CICIP (n,m,p))
let higgs_neutr =
List.map shiggs_neutr (two_and_one [N1;N2;N3;N4;N5] [S1;S2;S3]) @
List.map phiggs_neutr (two_and_one [N1;N2;N3;N4;N5] [P1;P2])
(*** REVISED: Compatible with CD+. FB***)
let yukawa_n_2 n m g =
[ ((Neutralino n, Slepton (m,-g), L g), FBF (1, Chibar, SLR, Psi),
G_YUK_N (true,L g,n,SL,m));
((L (-g), Slepton (m,g), Neutralino n), FBF (1, Psibar, SLR, Chi),
G_YUK_N (false,L g,n,SL,m));
((Neutralino n, Sup (m,-g), U g), FBF (1, Chibar, SLR, Psi),
G_YUK_N (true,U g,n,SU,m));
((U (-g), Sup (m,g), Neutralino n), FBF (1, Psibar, SLR, Chi),
G_YUK_N (false,U g,n,SU,m));
((Neutralino n, Sdown (m,-g), D g), FBF (1, Chibar, SLR, Psi),
G_YUK_N (true,D g,n,SD,m));
((D (-g), Sdown (m,g), Neutralino n), FBF (1, Psibar, SLR, Chi),
G_YUK_N (false,D g,n,SD,m)) ]
let yukawa_n_3 n g =
[ ((Neutralino n, Sneutrino (-g), N g), FBF (1, Chibar, SLR, Psi),
G_YUK_N (true,N g,n,SN,M1));
((N (-g), Sneutrino g, Neutralino n), FBF (1, Psibar, SLR, Chi),
G_YUK_N (false,N g, n,SN,M1)) ]
let yukawa_n_5 g m =
[ ((U (-g), Sup (m,g), Gluino), FBF (1, Psibar, SLR, Chi),
G_YUK_G (false,U g,SU,m));
((D (-g), Sdown (m,g), Gluino), FBF (1, Psibar, SLR, Chi),
G_YUK_G (false,D g,SD,m));
((Gluino, Sup (m,-g), U g), FBF (1, Chibar, SLR, Psi),
G_YUK_G (true,U g,SU,m));
((Gluino, Sdown (m,-g), D g), FBF (1, Chibar, SLR, Psi),
G_YUK_G (true,D g,SD,m))]
let yukawa_n =
List.flatten (Product.list3 yukawa_n_2 [N1;N2;N3;N4;N5] [M1;M2] [1;2;3]) @
List.flatten (Product.list2 yukawa_n_3 [N1;N2;N3;N4;N5] [1;2;3]) @
List.flatten (Product.list2 yukawa_n_5 [1;2;3] [M1;M2])
(*** REVISED: Compatible with CD+.FB ***)
let yukawa_c_2 c g =
let cc = conj_char c in
[ ((L (-g), Sneutrino g, Chargino cc), BBB (1, Psibar, SLR,
Psibar), G_YUK_C (true,L g,c,SN,M1));
((Chargino c, Sneutrino (-g), L g), PBP (1, Psi, SLR, Psi),
G_YUK_C (false,L g,c,SN,M1)) ]
let yukawa_c_3 c m g =
let cc = conj_char c in
[ ((N (-g), Slepton (m,g), Chargino c), FBF (1, Psibar, SLR,
Psi), G_YUK_C (true,N g,c,SL,m));
((Chargino cc, Slepton (m,-g), N g), FBF (1, Psibar, SLR,
Psi), G_YUK_C (false,N g,c,SL,m)) ]
let yukawa_c c =
ThoList.flatmap (yukawa_c_2 c) [1;2;3] @
List.flatten (Product.list2 (yukawa_c_3 c) [M1;M2] [1;2;3])
(*** REVISED: Compatible with CD+. FB***)
let yukawa_cq' c (g,h) m =
let cc = conj_char c in
[ ((Chargino c, Sup (m,-g), D h), PBP (1, Psi, SLR, Psi),
G_YUK_Q (false,g,D h,c,SU,m));
((D (-h), Sup (m,g), Chargino cc), BBB (1, Psibar, SLR, Psibar),
G_YUK_Q (true,g,D h,c,SU,m));
((Chargino cc, Sdown (m,-g), U h), FBF (1, Psibar, SLR, Psi),
G_YUK_Q (true,g,U h,c,SD,m));
((U (-h), Sdown (m,g), Chargino c), FBF (1, Psibar, SLR, Psi),
G_YUK_Q (false,g,U h,c,SD,m)) ]
let yukawa_cq c =
if Flags.ckm_present then
List.flatten (Product.list2 (yukawa_cq' c) [(1,1);(1,2);(2,1);(2,2);(1,3);(2,3);(3,3);(3,2);(3,1)] [M1;M2])
else
List.flatten (Product.list2 (yukawa_cq' c) [(1,1);(2,2);(3,3)] [M1;M2])
(*** REVISED: Compatible with CD+.
Remark: Singlet and octet gluon exchange. The coupling is divided by
sqrt(2) to account for the correct normalization of the Lie algebra
generators.
**FB*)
let col_currents g =
[ ((D (-g), Gl, D g), FBF ((-1), Psibar, V, Psi), Gs);
((U (-g), Gl, U g), FBF ((-1), Psibar, V, Psi), Gs)]
(*** REVISED: Compatible with CD+.
Remark: Singlet and octet gluon exchange. The coupling is divided by
sqrt(2) to account for the correct normalization of the Lie algebra
generators.
**FB*)
(** LQ-coupl. **DW**)
let chg = function
| M1 -> M2 | M2 -> M1
(** LQ - Yuk's **)
let yuk_lqino_se_uc1' g1 g2 g3 m =
let cm = chg m in
[ ((U (-g3), Slepton (m,-g2), LQino g1), FBF (1, Psibar, SLR, Psi),
G_LQ_EC_UC (true,cm,g1,g2,g3)) ]
let yuk_lqino_se_uc1 g1 g2 g3 =
ThoList.flatmap (yuk_lqino_se_uc1' g1 g2 g3) [M1;M2]
let yuk_lqino_se_uc2' g1 g2 g3 m =
let cm = chg m in
[ ((LQino (-g1), Slepton (m,g2), U g3), FBF (1, Psibar, SLR, Psi),
G_LQ_EC_UC (false,cm,g1,g2,g3)) ]
let yuk_lqino_se_uc2 g1 g2 g3 =
ThoList.flatmap (yuk_lqino_se_uc2' g1 g2 g3) [M1;M2]
let yuk_lqino_sn_dc1 g1 g2 g3 =
[ ((D (-g3), Sneutrino (-g2), LQino g1), FBF (-1, Psibar, SLR, Psi),
G_LQ_EC_UC (true,M2,g1,g2,g3)) ]
let yuk_lqino_sn_dc2 g1 g2 g3 =
[ ((LQino (-g1), Sneutrino g2, D g3), FBF (-1, Psibar, SLR, Psi),
G_LQ_EC_UC (false,M2,g1,g2,g3)) ]
let yuk_lqino_ec_su1' g1 g2 g3 m =
let cm = chg m in
[ ((LQino (-g1), Sup (m,g3), L g2), FBF (1, Psibar, SLR, Psi),
G_LQ_EC_UC (true,cm,g1,g2,g3)) ]
let yuk_lqino_ec_su1 g1 g2 g3 =
ThoList.flatmap (yuk_lqino_ec_su1' g1 g2 g3) [M1;M2]
let yuk_lqino_ec_su2' g1 g2 g3 m =
let cm = chg m in
[ ((L (-g2), Sup (m,-g3), LQino (g1)), FBF (1, Psibar, SLR, Psi),
G_LQ_EC_UC (false,cm,g1,g2,g3)) ]
let yuk_lqino_ec_su2 g1 g2 g3 =
ThoList.flatmap (yuk_lqino_ec_su2' g1 g2 g3) [M1;M2]
let yuk_lqino_nc_sd1 g1 g2 g3 =
[ ((LQino (-g1), Sdown (M1,g3), N g2), FBF (-1, Psibar, SLR, Psi),
G_LQ_EC_UC (true,M2,g1,g2,g3)) ]
let yuk_lqino_nc_sd2 g1 g2 g3 =
[ ((N (-g2), Sdown (M1,-g3), LQino (g1)), FBF (-1, Psibar, SLR, Psi),
G_LQ_EC_UC (false,M2,g1,g2,g3)) ]
let yuk_lq_ec_uc' g1 g2 g3 m =
[ ((L (-g2), LQ (m,g1), U (-g3)), BBB (1, Psibar, SLR, Psibar),
G_LQ_EC_UC (false,m,g1,g2,g3)) ]
let yuk_lq_ec_uc g1 g2 g3 =
ThoList.flatmap (yuk_lq_ec_uc' g1 g2 g3) [M1;M2]
let yuk_lq_ec_uc2' g1 g2 g3 m =
[ ((L (g2), LQ (m,-g1), U (g3)), PBP (1, Psi, SLR, Psi),
G_LQ_EC_UC (true,m,g1,g2,g3)) ]
let yuk_lq_ec_uc2 g1 g2 g3 =
ThoList.flatmap (yuk_lq_ec_uc2' g1 g2 g3) [M1;M2]
let yuk_lq_nc_dc g1 g2 g3 =
[ ((N (-g2), LQ (M2,g1), D (-g3)), BBB (-1, Psibar, SLR, Psibar),
G_LQ_EC_UC (false,M2,g1,g2,g3)) ]
let yuk_lq_nc_dc2 g1 g2 g3 =
[ ((N (g2), LQ (M2,-g1), D (g3)), PBP (-1, Psi, SLR, Psi),
G_LQ_EC_UC (true,M2,g1,g2,g3)) ]
(*** Daniel Wiesler: LQ - F-Term w/ vev ***)
let lq_se_su' g1 g2 g3 m1 m2 m3 =
[ ((LQ (m1,g1), Slepton (m2,-g2), Sup (m3,-g3)), Scalar_Scalar_Scalar 1,
G_LQ_SSU (m1,m2,m3,g1,g2,g3)) ]
let lq_se_su g1 g2 g3 =
List.flatten (Product.list3 (lq_se_su' g1 g2 g3) [M1;M2] [M1;M2] [M1;M2] )
let lq_snu_sd' g1 g2 g3 m1 m2 =
[ ((LQ (m1,g1), Sdown (m2,-g2), Sneutrino (-g3)), Scalar_Scalar_Scalar 1,
G_LQ_SSD (m1,m2,g1,g2,g3)) ]
let lq_snu_sd g1 g2 g3 =
List.flatten (Product.list2 (lq_snu_sd' g1 g2 g3) [M1;M2] [M1;M2] )
(*** Daniel Wiesler: LQ - Higgs ***)
let lq_shiggs' g1 s g2 m1 m2 =
[ ((LQ (m1,g1), SHiggs s, LQ (m2,-g2)), Scalar_Scalar_Scalar 1, G_LQ_S (m1,m2,g1,s,g2))]
let lq_shiggs g1 s g2 =
List.flatten ( Product.list2 (lq_shiggs' g1 s g2) [M1;M2] [M1;M2])
let lq_phiggs' g1 p g2 m1 m2 =
[ ((LQ (m1,g1), PHiggs p, LQ (m2,-g2)), Scalar_Scalar_Scalar 1, G_LQ_P (m1,m2,g1,p,g2))]
let lq_phiggs g1 p g2 =
List.flatten ( Product.list2 (lq_phiggs' g1 p g2) [M1;M2] [M1;M2])
let yuk_lqino_shiggs g1 s g2 =
[ ((LQino (-g1), SHiggs s, LQino g2), FBF (1, Psibar, SLR, Psi),
G_YUK_LQ_S (g1,s,g2)) ]
let yuk_lqino_phiggs g1 p g2 =
[ ((LQino (-g1), PHiggs p, LQino g2), FBF (1, Psibar, SLR, Psi),
G_YUK_LQ_P (g1,p,g2)) ]
(*** Daniel Wiesler: LQ - Neutralinos. ***)
let lqino_lq_neu' n g1 g2 m =
[ ((Neutralino n, LQ (m,-g1), LQino g2), FBF (1, Chibar, SLR, Psi),
G_LQ_NEU (m,g1,g2,n)) ]
let lqino_lq_neu n g1 g2 =
ThoList.flatmap (lqino_lq_neu' n g1 g2) [M1;M2]
let lqino_lq_neu2' n g1 g2 m =
[ ((LQino (-g2), LQ (m,g1), Neutralino n), FBF (1, Psibar, SLR, Chi),
G_LQ_NEU (m,g1,g2,n)) ]
let lqino_lq_neu2 n g1 g2 =
ThoList.flatmap (lqino_lq_neu2' n g1 g2) [M1;M2]
(*** Daniel Wiesler: LQ-LQino-Gluino ***)
let lqino_lq_gg' g1 g2 m =
[ ((Gluino, LQ (m,-g1), LQino g2), FBF (1, Chibar, SLR, Psi),
G_LQ_GG (m,g1,g2)) ]
let lqino_lq_gg g1 g2 =
ThoList.flatmap (lqino_lq_gg' g1 g2) [M1;M2]
(*** Daniel Wiesler: LQ - Gauge ***)
let col_lqino_currents g =
[ ((LQino (-g), Gl, LQino g), FBF ((-1), Psibar, V, Psi), Gs)]
let neutr_lqino_current g =
[ ((LQino (-g), Z, LQino g), FBF (1, Psibar, V, Psi), G_NLQC)]
let col_lq_currents m g =
[ ((Gl, LQ (m,-g), LQ (m,g)), Vector_Scalar_Scalar (-1), Gs)]
let lq_neutr_Z g m1 m2 =
[ ((Z, LQ (m1,-g), LQ (m2,g)), Vector_Scalar_Scalar (-1), G_ZLQ (g,m1,m2))]
let em_lq_currents g m =
[ ((Ga, LQ (m,-g), LQ (m,g)), Vector_Scalar_Scalar 1, Q_down)]
let em_lqino_currents g =
[ ((LQino (-g), Ga, LQino g), FBF (1, Psibar, V, Psi), Q_down)]
let gluon2_lq2' g m =
[ ((LQ (m,g), LQ (m,-g), Gl, Gl), Scalar2_Vector2 2, G_GlGlLQLQ)]
let gluon2_lq2 g =
ThoList.flatmap (gluon2_lq2' g) [M1;M2]
let lq_gauge4' g m =
[ ((Z, Z, LQ (m,g), LQ (m,-g)), Scalar2_Vector2 1, G_ZZLQLQ);
((Z, Ga, LQ (m,g), LQ (m,-g)), Scalar2_Vector2 1, G_ZPLQLQ);
((Ga, Ga, LQ (m,g), LQ (m,-g)), Scalar2_Vector2 1, G_PPLQLQ)]
let lq_gauge4 g =
ThoList.flatmap (lq_gauge4' g) [M1;M2]
let lq_gg_gauge2' g m =
[ ((Z, Gl, LQ (m,g), LQ (m,-g)), Scalar2_Vector2 1, G_ZGlLQLQ);
((Ga, Gl, LQ (m,g), LQ (m,-g)), Scalar2_Vector2 1, G_PGlLQLQ)]
let lq_gg_gauge2 g =
ThoList.flatmap (lq_gg_gauge2' g) [M1;M2]
let col_sfermion_currents g m =
[ ((Gl, Sup (m,-g), Sup (m,g)), Vector_Scalar_Scalar (-1), Gs);
((Gl, Sdown (m,-g), Sdown (m,g)), Vector_Scalar_Scalar (-1), Gs)]
(*** REVISED: Compatible with CD+. **FB*)
let triple_gauge =
[ ((Ga, Wm, Wp), Gauge_Gauge_Gauge 1, I_Q_W);
((Z, Wm, Wp), Gauge_Gauge_Gauge 1, I_G_ZWW);
((Gl, Gl, Gl), Gauge_Gauge_Gauge 1, I_G_S)]
(*** REVISED: Independent of the sign of CD. **FB*)
let gauge4 = Vector4 [(2, C_13_42); (-1, C_12_34); (-1, C_14_23)]
let minus_gauge4 = Vector4 [(-2, C_13_42); (1, C_12_34); (1, C_14_23)]
let quartic_gauge =
[ (Wm, Wp, Wm, Wp), gauge4, G_WWWW;
(Wm, Z, Wp, Z), minus_gauge4, G_ZZWW;
(Wm, Z, Wp, Ga), minus_gauge4, G_PZWW;
(Wm, Ga, Wp, Ga), minus_gauge4, G_PPWW;
(Gl, Gl, Gl, Gl), gauge4, G_SS]
(* The [Scalar_Vector_Vector] couplings do not depend on the choice of the
sign of the covariant derivative since they are quadratic in the
gauge couplings. *)
(* JR: Only the first charged Higgs. *)
(*** REVISED: Compatible with CD+. ***)
(*** Revision: 2005-03-10: first two vertices corrected. ***)
(*** REVISED: Felix Braam: Compact version using new COMBOS*)
(*** REVISED: Felix Braam: Couplings adjusted to FF-convention*)
let gauge_higgs_WPC p=
[ ((Wm, CHiggs HC1, PHiggs p), Vector_Scalar_Scalar 1, G_GH_WPC p);
((Wp, CHiggs HC1c, PHiggs p), Vector_Scalar_Scalar 1, G_GH_WPC p)]
let gauge_higgs_WSC s=
[((Wm, CHiggs HC1, SHiggs s),Vector_Scalar_Scalar 1, G_GH_WSC s);
((Wp, CHiggs HC1c, SHiggs s),Vector_Scalar_Scalar (-1), G_GH_WSC s)]
let gauge_higgs_ZSP s p =
[((Z, SHiggs s, PHiggs p),Vector_Scalar_Scalar 1, G_GH_ZSP (s,p))]
let gauge_higgs_WWS s=
((SHiggs s, Wp, Wm),Scalar_Vector_Vector 1, G_GH_WWS s)
let gauge_higgs_ZZS s=
((SHiggs s, Z, Z), Scalar_Vector_Vector 1, G_GH_ZZS s)
let gauge_higgs_ZCC =
((Z, CHiggs HC1, CHiggs HC1c),Vector_Scalar_Scalar 1, G_GH_ZCC )
let gauge_higgs_GaCC =
((Ga, CHiggs HC1, CHiggs HC1c),Vector_Scalar_Scalar 1, G_GH_GaCC )
let gauge_higgs =
ThoList.flatmap gauge_higgs_WPC [P1;P2] @
ThoList.flatmap gauge_higgs_WSC [S1;S2;S3] @
List.flatten (Product.list2 gauge_higgs_ZSP [S1;S2;S3] [P1;P2]) @
List.map gauge_higgs_WWS [S1;S2;S3] @
List.map gauge_higgs_ZZS [S1;S2;S3] @
[gauge_higgs_ZCC] @ [gauge_higgs_GaCC]
(*** REVISED: Compact version using new COMBOS*)
(*** REVISED: Couplings adjusted to FF-convention*)
let gauge_higgs4_ZZPP (p1,p2) =
((PHiggs p1, PHiggs p2, Z, Z), Scalar2_Vector2 1, G_GH4_ZZPP (p1,p2))
let gauge_higgs4_ZZSS (s1,s2) =
((SHiggs s1, SHiggs s2 , Z, Z), Scalar2_Vector2 1, G_GH4_ZZSS (s1,s2))
(* JR: Only the first charged Higgs. *)
let gauge_higgs4_ZZCC =
((CHiggs HC1, CHiggs HC1c, Z, Z), Scalar2_Vector2 1, G_GH4_ZZCC)
let gauge_higgs4_GaGaCC =
((CHiggs HC1, CHiggs HC1c, Ga, Ga), Scalar2_Vector2 1, G_GH4_GaGaCC)
let gauge_higgs4_ZGaCC =
((CHiggs HC1, CHiggs HC1c, Ga, Z), Scalar2_Vector2 1, G_GH4_ZGaCC )
let gauge_higgs4_WWCC =
((CHiggs HC1, CHiggs HC1c, Wp, Wm), Scalar2_Vector2 1, G_GH4_WWCC )
let gauge_higgs4_WWPP (p1,p2) =
((PHiggs p1, PHiggs p2, Wp, Wm), Scalar2_Vector2 1, G_GH4_WWPP (p1,p2))
let gauge_higgs4_WWSS (s1,s2) =
((SHiggs s1, SHiggs s2, Wp, Wm), Scalar2_Vector2 1, G_GH4_WWSS (s1,s2))
(* JR: Only the first charged Higgs. *)
let gauge_higgs4_ZWSC s =
[ ((CHiggs HC1, SHiggs s, Wm, Z), Scalar2_Vector2 1, G_GH4_ZWSC s);
((CHiggs HC1c, SHiggs s, Wp, Z), Scalar2_Vector2 1, G_GH4_ZWSC s)]
let gauge_higgs4_GaWSC s =
[ ((CHiggs HC1, SHiggs s, Wm, Ga), Scalar2_Vector2 1, G_GH4_GaWSC s);
((CHiggs HC1c, SHiggs s, Wp, Ga), Scalar2_Vector2 1, G_GH4_GaWSC s) ]
let gauge_higgs4_ZWPC p =
[ ((CHiggs HC1, PHiggs p, Wm, Z), Scalar2_Vector2 1, G_GH4_ZWPC p);
((CHiggs HC1c, PHiggs p, Wp, Z), Scalar2_Vector2 (-1), G_GH4_ZWPC p)]
let gauge_higgs4_GaWPC p =
[ ((CHiggs HC1, PHiggs p, Wm, Ga), Scalar2_Vector2 1, G_GH4_GaWPC p);
((CHiggs HC1c, PHiggs p, Wp, Ga), Scalar2_Vector2 (-1),
G_GH4_GaWPC p) ]
let gauge_higgs4 =
List.map gauge_higgs4_ZZPP (pairs [P1;P2]) @
List.map gauge_higgs4_ZZSS (pairs [S1;S2;S3]) @
[gauge_higgs4_ZZCC] @ [gauge_higgs4_GaGaCC] @
[gauge_higgs4_ZGaCC] @ [gauge_higgs4_WWCC] @
List.map gauge_higgs4_WWPP (pairs [P1;P2]) @
List.map gauge_higgs4_WWSS (pairs [S1;S2;S3]) @
ThoList.flatmap gauge_higgs4_ZWSC [S1;S2;S3] @
ThoList.flatmap gauge_higgs4_GaWSC [S1;S2;S3] @
ThoList.flatmap gauge_higgs4_ZWPC [P1;P2] @
ThoList.flatmap gauge_higgs4_GaWPC [P1;P2]
(*** Added by Felix Braam. ***)
let gauge_sfermion4' g m1 m2 =
[ ((Wp, Wm, Slepton (m1,g), Slepton (m2,-g)), Scalar2_Vector2 1,
G_WWSFSF (SL,g,m1,m2));
((Z, Ga, Slepton (m1,g), Slepton (m2,-g)), Scalar2_Vector2 1,
G_ZPSFSF (SL,g,m1,m2));
((Z, Z, Slepton (m1,g), Slepton (m2,-g)), Scalar2_Vector2 1,
G_ZZSFSF (SL,g,m1,m2));
((Wp, Wm, Sup (m1,g), Sup (m2,-g)), Scalar2_Vector2 1, G_WWSFSF
(SU,g,m1,m2));
((Wp, Wm, Sdown (m1,g), Sdown (m2,-g)), Scalar2_Vector2 1, G_WWSFSF
(SD,g,m1,m2));
((Z, Z, Sup (m1,g), Sup (m2,-g)), Scalar2_Vector2 1, G_ZZSFSF
(SU,g,m1,m2));
((Z, Z, Sdown (m1,g), Sdown (m2,-g)), Scalar2_Vector2 1, G_ZZSFSF
(SD,g,m1,m2));
((Z, Ga, Sup (m1,g), Sup (m2,-g)), Scalar2_Vector2 1, G_ZPSFSF
(SU,g,m1,m2));
((Z, Ga, Sdown (m1,g), Sdown (m2,-g)), Scalar2_Vector2 1, G_ZPSFSF
(SD,g,m1,m2)) ]
let gauge_sfermion4'' g m =
[ ((Wp, Ga, Slepton (m,g), Sneutrino (-g)), Scalar2_Vector2 1,
G_WPSLSN (false,g,m));
((Wm, Ga, Slepton (m,-g), Sneutrino g), Scalar2_Vector2 1,
G_WPSLSN (true,g,m));
((Wp, Z, Slepton (m,g), Sneutrino (-g)), Scalar2_Vector2 1,
G_WZSLSN (false,g,m));
((Wm, Z, Slepton (m,-g), Sneutrino g), Scalar2_Vector2 1,
G_WZSLSN (true,g,m));
((Ga, Ga, Slepton (m,g), Slepton (m,-g)), Scalar2_Vector2 1, G_PPSFSF SL);
((Ga, Ga, Sup (m,g), Sup (m,-g)), Scalar2_Vector2 1, G_PPSFSF SU);
((Ga, Ga, Sdown (m,g), Sdown (m,-g)), Scalar2_Vector2 1, G_PPSFSF SD)]
let gauge_sfermion4 g =
List.flatten (Product.list2 (gauge_sfermion4' g) [M1;M2] [M1;M2]) @
ThoList.flatmap (gauge_sfermion4'' g) [M1;M2] @
[ ((Wp, Wm, Sneutrino g, Sneutrino (-g)), Scalar2_Vector2 1, G_WWSFSF
(SN,g,M1,M1));
((Z, Z, Sneutrino g, Sneutrino (-g)), Scalar2_Vector2 1, G_ZZSFSF
(SN,g,M1,M1)) ]
(*** Modified by Felix Braam. ***)
let gauge_squark4'' g h m1 m2 =
[ ((Wp, Ga, Sup (m1,-g), Sdown (m2,h)), Scalar2_Vector2 1, G_WPSUSD
(false,m1,m2,g,h));
((Wm, Ga, Sup (m1,g), Sdown (m2,-h)), Scalar2_Vector2 1, G_WPSUSD
(true,m1,m2,g,h));
((Wp, Z, Sup (m1,-g), Sdown (m2,h)), Scalar2_Vector2 1, G_WZSUSD
(false,m1,m2,g,h));
((Wm, Z, Sup (m1,g), Sdown (m2,-h)), Scalar2_Vector2 1, G_WZSUSD
(true,m1,m2,g,h)) ]
let gauge_squark4' g h = List.flatten (Product.list2 (gauge_squark4'' g h)
[M1;M2] [M1;M2])
let gauge_squark4 =
if Flags.ckm_present then
List.flatten (Product.list2 gauge_squark4' [1;2;3] [1;2;3])
else
ThoList.flatmap (fun g -> gauge_squark4' g g) [1;2;3]
let gluon_w_squark'' g h m1 m2 =
[ ((Gl, Wp, Sup (m1,-g), Sdown (m2,h)),
Scalar2_Vector2 1, G_GlWSUSD (false,m1,m2,g,h));
((Gl, Wm, Sup (m1,g), Sdown (m2,-h)),
Scalar2_Vector2 1, G_GlWSUSD (true,m1,m2,g,h)) ]
let gluon_w_squark' g h =
List.flatten (Product.list2 (gluon_w_squark'' g h) [M1;M2] [M1;M2])
let gluon_w_squark =
if Flags.ckm_present then
List.flatten (Product.list2 gluon_w_squark' [1;2;3] [1;2;3])
else
ThoList.flatmap (fun g -> gluon_w_squark' g g) [1;2;3]
(*** Modified by Felix Braam. ***)
let gluon_gauge_squark' g m1 m2 =
[ ((Gl, Z, Sup (m1,g), Sup (m2,-g)),
Scalar2_Vector2 2, G_GlZSFSF (SU,g,m1,m2));
((Gl, Z, Sdown (m1,g), Sdown (m2,-g)),
Scalar2_Vector2 2, G_GlZSFSF (SD,g,m1,m2)) ]
let gluon_gauge_squark'' g m =
[ ((Gl, Ga, Sup (m,g), Sup (m,-g)), Scalar2_Vector2 2, G_GlPSQSQ);
((Gl, Ga, Sdown (m,g), Sdown (m,-g)), Scalar2_Vector2 (-1), G_GlPSQSQ) ]
(*** Modified by Felix Braam. ***)
let gluon_gauge_squark g =
List.flatten (Product.list2 (gluon_gauge_squark' g) [M1;M2] [M1;M2]) @
ThoList.flatmap (gluon_gauge_squark'' g) [M1;M2]
let gluon2_squark2' g m =
[ ((Gl, Gl, Sup (m,g), Sup (m,-g)), Scalar2_Vector2 2, G_GlGlSQSQ);
((Gl, Gl, Sdown (m,g), Sdown (m,-g)), Scalar2_Vector2 2, G_GlGlSQSQ) ]
let gluon2_squark2 g =
ThoList.flatmap (gluon2_squark2' g) [M1;M2]
(* JR: Only the first charged Higgs. *)
(*** REVISED: Independent of the sign of CD. ***)
(*** REVISED: Felix Braam: Compact version using new COMBOS *)
(*** REVISED: Felix Braam: Couplings adjusted to FF-convention *)
let higgs_SCC s =
((CHiggs HC1, CHiggs HC1c, SHiggs s), Scalar_Scalar_Scalar 1,
G_H3_SCC s )
let higgs_SSS (s1,s2,s3)=
((SHiggs s1, SHiggs s2, SHiggs s3), Scalar_Scalar_Scalar 1,
G_H3_SSS (s1,s2,s3))
let higgs_SPP (p1,p2,s) =
((SHiggs s, PHiggs p1, PHiggs p2), Scalar_Scalar_Scalar 1,
G_H3_SPP (s,p1,p2))
let higgs =
List.map higgs_SCC [S1;S2;S3]@
List.map higgs_SSS (triples [S1;S2;S3])@
List.map higgs_SPP (two_and_one [P1;P2] [S1;S2;S3])
let higgs4 = []
(* The vertices of the type Higgs - Sfermion - Sfermion are independent of
the choice of the CD sign since they are quadratic in the gauge
coupling. *)
(* JR: Only the first charged Higgs. *)
(*** REVISED: Independent of the sign of CD. ***)
let higgs_sneutrino' s g =
((SHiggs s, Sneutrino g, Sneutrino (-g)), Scalar_Scalar_Scalar 1,
G_SFSFS (s,SN,g,M1,M1))
let higgs_sneutrino'' g m =
[((CHiggs HC1, Sneutrino (-g), Slepton (m,g)),
Scalar_Scalar_Scalar 1, G_HSNSL (false,g,m));
((CHiggs HC1c, Sneutrino g, Slepton (m,-g)), Scalar_Scalar_Scalar 1,
G_HSNSL (true,g,m))]
let higgs_sneutrino =
Product.list2 higgs_sneutrino' [S1;S2;S3] [1;2;3] @
List.flatten ( Product.list2 higgs_sneutrino'' [1;2;3] [M1;M2] )
(* Under the assumption that there is no mixing between the left- and
right-handed sfermions for the first two generations there is only a
coupling of the form Higgs - sfermion1 - sfermion2 for the third
generation. All the others are suppressed by $m_f/M_W$. *)
(*** REVISED: Independent of the sign of CD. ***)
let higgs_sfermion_S s g m1 m2 =
[ ((SHiggs s, Slepton (m1,g), Slepton (m2,-g)), Scalar_Scalar_Scalar 1,
G_SFSFS (s,SL,g,m1,m2));
((SHiggs s, Sup (m1,g), Sup (m2,-g)), Scalar_Scalar_Scalar 1,
G_SFSFS (s,SU,g,m1,m2));
((SHiggs s, Sdown (m1,g), Sdown (m2,-g)), Scalar_Scalar_Scalar 1,
G_SFSFS (s,SD,g,m1,m2))]
let higgs_sfermion' g m1 m2 =
(higgs_sfermion_S S1 g m1 m2) @ (higgs_sfermion_S S2 g m1 m2) @ (higgs_sfermion_S S3 g m1 m2)
let higgs_sfermion_P p g m1 m2 =
[ ((PHiggs p, Slepton (m1,g), Slepton (m2,-g)), Scalar_Scalar_Scalar 1,
G_SFSFP (p,SL,g,m1,m2));
((PHiggs p, Sup (m1,g), Sup (m2,-g)), Scalar_Scalar_Scalar 1,
G_SFSFP (p,SU,g,m1,m2));
((PHiggs p, Sdown (m1,g), Sdown (m2,-g)), Scalar_Scalar_Scalar 1,
G_SFSFP (p,SD,g,m1,m2)) ]
let higgs_sfermion'' g m1 m2 =
(higgs_sfermion_P P1 g m1 m2) @ (higgs_sfermion_P P2 g m1 m2)
let higgs_sfermion = List.flatten (Product.list3 higgs_sfermion' [1;2;3] [M1;M2] [M1;M2]) @
List.flatten (Product.list3 higgs_sfermion'' [1;2;3] [M1;M2] [M1;M2])
(* JR: Only the first charged Higgs. *)
(*** REVISED: Independent of the sign of CD. ***)
let higgs_squark' g h m1 m2 =
[ ((CHiggs HC1, Sup (m1,-g), Sdown (m2,h)), Scalar_Scalar_Scalar 1,
G_HSUSD (false,m1,m2,g,h));
((CHiggs HC1c, Sup (m1,g), Sdown (m2,-h)), Scalar_Scalar_Scalar 1,
G_HSUSD (true,m1,m2,g,h)) ]
let higgs_squark_a g h = higgs_squark' g h M1 M1
let higgs_squark_b (g,h) = List.flatten (Product.list2 (higgs_squark' g h)
[M1;M2] [M1;M2])
let higgs_squark =
if Flags.ckm_present then
List.flatten (Product.list2 higgs_squark_a [1;2] [1;2]) @
ThoList.flatmap higgs_squark_b [(1,3);(2,3);(3,3);(3,1);(3,2)]
else
higgs_squark_a 1 1 @ higgs_squark_a 2 2 @ higgs_squark_b (3,3)
let vertices3 =
(ThoList.flatmap electromagnetic_currents_3 [1;2;3] @
ThoList.flatmap electromagnetic_currents_2 [C1;C2] @
List.flatten (Product.list2 electromagnetic_sfermion_currents [1;2;3]
[M1;M2]) @
ThoList.flatmap neutral_currents [1;2;3] @
ThoList.flatmap neutral_sfermion_currents [1;2;3] @
ThoList.flatmap charged_currents [1;2;3] @
List.flatten (Product.list2 charged_slepton_currents [1;2;3]
[M1;M2]) @
(if Flags.ckm_present then
List.flatten (Product.list2 charged_quark_currents [1;2;3]
[1;2;3]) @
List.flatten (Product.list2 charged_squark_currents [1;2;3]
[1;2;3]) @
ThoList.flatmap yukawa_higgs_quark [(1,3);(2,3);(3,3);(3,1);(3,2)]
else
charged_quark_currents 1 1 @
charged_quark_currents 2 2 @
charged_quark_currents 3 3 @
charged_squark_currents 1 1 @
charged_squark_currents 2 2 @
charged_squark_currents 3 3 @
ThoList.flatmap yukawa_higgs_quark [(3,3)]) @
(*i ThoList.flatmap yukawa_higgs [1;2;3] @ i*)
yukawa_higgs 3 @ yukawa_n @
ThoList.flatmap yukawa_c [C1;C2] @
ThoList.flatmap yukawa_cq [C1;C2] @
List.flatten (Product.list2 charged_chargino_currents [N1;N2;N3;N4;N5]
[C1;C2]) @ triple_gauge @
ThoList.flatmap neutral_Z (pairs [N1;N2;N3;N4;N5]) @
Product.list2 charged_Z [C1;C2] [C1;C2] @
gauge_higgs @ higgs @ yukawa_higgs_2 @
(*i List.flatten (Product.list2 yukawa_higgs_quark [1;2;3] [1;2;3]) @ i*)
List.flatten (Product.list2 higgs_charg_neutr [N1;N2;N3;N4;N5] [C1;C2]) @
higgs_neutr @ higgs_sneutrino @ higgs_sfermion @
higgs_squark @ yukawa_v @
ThoList.flatmap col_currents [1;2;3] @
List.flatten (Product.list2 col_sfermion_currents [1;2;3] [M1;M2])) @
List.flatten (Product.list2 col_lq_currents [M1;M2] [1;2;3]) @
ThoList.flatmap col_lqino_currents [1;2;3] @
ThoList.flatmap em_lqino_currents [1;2;3] @
ThoList.flatmap neutr_lqino_current [1;2;3] @
List.flatten (Product.list3 yuk_lqino_se_uc1 [1;2;3] [1;2;3] [1;2;3]) @
List.flatten (Product.list3 yuk_lqino_se_uc2 [1;2;3] [1;2;3] [1;2;3]) @
List.flatten (Product.list3 yuk_lqino_ec_su1 [1;2;3] [1;2;3] [1;2;3]) @
List.flatten (Product.list3 yuk_lqino_ec_su2 [1;2;3] [1;2;3] [1;2;3]) @
List.flatten (Product.list3 yuk_lqino_sn_dc1 [1;2;3] [1;2;3] [1;2;3]) @
List.flatten (Product.list3 yuk_lqino_sn_dc2 [1;2;3] [1;2;3] [1;2;3]) @
List.flatten (Product.list3 yuk_lqino_nc_sd1 [1;2;3] [1;2;3] [1;2;3]) @
List.flatten (Product.list3 yuk_lqino_nc_sd2 [1;2;3] [1;2;3] [1;2;3]) @
List.flatten (Product.list3 yuk_lq_ec_uc [1;2;3] [1;2;3] [1;2;3]) @
List.flatten (Product.list3 yuk_lq_ec_uc2 [1;2;3] [1;2;3] [1;2;3]) @
List.flatten (Product.list3 yuk_lq_nc_dc [1;2;3] [1;2;3] [1;2;3]) @
List.flatten (Product.list3 yuk_lq_nc_dc2 [1;2;3] [1;2;3] [1;2;3]) @
List.flatten (Product.list3 lq_neutr_Z [1;2;3] [M1;M2] [M1;M2]) @
List.flatten (Product.list2 em_lq_currents [1;2;3] [M1;M2]) @
List.flatten (Product.list3 lq_shiggs [1;2;3] [S1;S2;S3;S4;S5;S6;S7;S8;S9] [1;2;3]) @
List.flatten (Product.list3 lq_phiggs [1;2;3] [P1;P2;P3;P4;P5;P6;P7] [1;2;3]) @
List.flatten (Product.list3 yuk_lqino_shiggs [1;2;3] [S1;S2;S3;S4;S5;S6;S7;S8;S9] [1;2;3]) @
List.flatten (Product.list3 yuk_lqino_phiggs [1;2;3] [P1;P2;P3;P4;P5;P6;P7] [1;2;3]) @
List.flatten (Product.list3 lqino_lq_neu nlist [1;2;3] [1;2;3]) @
List.flatten (Product.list3 lqino_lq_neu2 nlist [1;2;3] [1;2;3]) @
List.flatten (Product.list3 lq_se_su [1;2;3] [1;2;3] [1;2;3]) @
List.flatten (Product.list3 lq_snu_sd [1;2;3] [1;2;3] [1;2;3]) @
List.flatten (Product.list2 lqino_lq_gg [1;2;3] [1;2;3])
let vertices4 =
(quartic_gauge @ higgs4 @ gauge_higgs4 @
ThoList.flatmap gauge_sfermion4 [1;2;3] @
gauge_squark4 @ gluon_w_squark @
ThoList.flatmap gluon2_squark2 [1;2;3] @
ThoList.flatmap gluon_gauge_squark [1;2;3] @
ThoList.flatmap gluon2_lq2 [1;2;3] @
ThoList.flatmap lq_gauge4 [1;2;3] @
ThoList.flatmap lq_gg_gauge2 [1;2;3])
let vertices () = (vertices3, vertices4, [])
let table = F.of_vertices (vertices ())
let fuse2 = F.fuse2 table
let fuse3 = F.fuse3 table
let fuse = F.fuse table
let max_degree () = 4
(* SLHA2-Nomenclature for neutral Higgses *)
let flavor_of_string s =
match s with
| "e-" -> L 1 | "e+" -> L (-1)
| "mu-" -> L 2 | "mu+" -> L (-2)
| "tau-" -> L 3 | "tau+" -> L (-3)
| "nue" -> N 1 | "nuebar" -> N (-1)
| "numu" -> N 2 | "numubar" -> N (-2)
| "nutau" -> N 3 | "nutaubar" -> N (-3)
| "se1-" -> Slepton (M1,1) | "se1+" -> Slepton (M1,-1)
| "smu1-" -> Slepton (M1,2) | "smu1+" -> Slepton (M1,-2)
| "stau1-" -> Slepton (M1,3) | "stau1+" -> Slepton (M1,-3)
| "se2-" -> Slepton (M2,1) | "se2+" -> Slepton (M2,-1)
| "smu2-" -> Slepton (M2,2) | "smu2+" -> Slepton (M2,-2)
| "stau2-" -> Slepton (M2,3) | "stau2+" -> Slepton (M2,-3)
| "snue" -> Sneutrino 1 | "snue*" -> Sneutrino (-1)
| "snumu" -> Sneutrino 2 | "snumu*" -> Sneutrino (-2)
| "snutau" -> Sneutrino 3 | "snutau*" -> Sneutrino (-3)
| "u" -> U 1 | "ubar" -> U (-1)
| "c" -> U 2 | "cbar" -> U (-2)
| "t" -> U 3 | "tbar" -> U (-3)
| "d" -> D 1 | "dbar" -> D (-1)
| "s" -> D 2 | "sbar" -> D (-2)
| "b" -> D 3 | "bbar" -> D (-3)
| "A" -> Ga | "Z" | "Z0" -> Z
| "W+" -> Wp | "W-" -> Wm
| "gl" | "g" -> Gl
| "h01" -> SHiggs S1 | "h02" -> SHiggs S2 | "h03" -> SHiggs S3
| "A01" -> PHiggs P1 | "A02" -> PHiggs P2
| "h04" -> SHiggs S4 | "h05" -> SHiggs S5 | "h06" -> SHiggs S6
| "A03" -> PHiggs P3 | "A04" -> PHiggs P4
| "h07" -> SHiggs S7 | "h08" -> SHiggs S8 | "h09" -> SHiggs S9
| "A05" -> PHiggs P5 | "A06" -> PHiggs P6 | "A07" -> PHiggs P7
(* JR: Only the first charged Higgs. *)
| "H+" -> CHiggs HC1 | "H-" -> CHiggs HC1c
| "su1" -> Sup (M1,1) | "su1c" -> Sup (M1,-1)
| "sc1" -> Sup (M1,2) | "sc1c" -> Sup (M1,-2)
| "st1" -> Sup (M1,3) | "st1c" -> Sup (M1,-3)
| "su2" -> Sup (M2,1) | "su2c" -> Sup (M2,-1)
| "sc2" -> Sup (M2,2) | "sc2c" -> Sup (M2,-2)
| "st2" -> Sup (M2,3) | "st2c" -> Sup (M2,-3)
| "sgl" | "sg" -> Gluino
| "sd1" -> Sdown (M1,1) | "sd1c" -> Sdown (M1,-1)
| "ss1" -> Sdown (M1,2) | "ss1c" -> Sdown (M1,-2)
| "sb1" -> Sdown (M1,3) | "sb1c" -> Sdown (M1,-3)
| "sd2" -> Sdown (M2,1) | "sd2c" -> Sdown (M2,-1)
| "ss2" -> Sdown (M2,2) | "ss2c" -> Sdown (M2,-2)
| "sb2" -> Sdown (M2,3) | "sb2c" -> Sdown (M2,-3)
| "neu1" -> Neutralino N1 | "neu2" -> Neutralino N2
| "neu3" -> Neutralino N3 | "neu4" -> Neutralino N4
| "neu5" -> Neutralino N5 | "neu6" -> Neutralino N6
| "neu7" -> Neutralino N7 | "neu8" -> Neutralino N8
| "neu9" -> Neutralino N9 | "neu10" -> Neutralino N10
| "neu11" -> Neutralino N11
| "ch1+" -> Chargino C1 | "ch2+" -> Chargino C2
| "ch1-" -> Chargino C1c | "ch2-" -> Chargino C2c
| "ch3+" -> Chargino C3 | "ch4+" -> Chargino C4
| "ch3-" -> Chargino C3c | "ch4-" -> Chargino C4c
| "lq11" -> LQ (M1,1) | "lq11c" -> LQ (M1,-1)
| "lq12" -> LQ (M2,1) | "lq12c" -> LQ (M2,-1)
| "lq21" -> LQ (M1,2) | "lq21c" -> LQ (M1,-2)
| "lq22" -> LQ (M2,2) | "lq22c" -> LQ (M2,-2)
| "lq31" -> LQ (M1,3) | "lq31c" -> LQ (M1,-3)
| "lq32" -> LQ (M2,3) | "lq32c" -> LQ (M2,-3)
| "lqino1" -> LQino 1 | "lqino1b" -> LQino (-1)
| "lqino2" -> LQino 2 | "lqino2b" -> LQino (-2)
| "lqino3" -> LQino 3 | "lqino3b" -> LQino (-3)
| s -> invalid_arg ("HUBABUBA: %s Modellib_PSSSM.ExtMSSM.flavor_of_string:" ^ s)
let flavor_to_string = function
| L 1 -> "e-" | L (-1) -> "e+"
| L 2 -> "mu-" | L (-2) -> "mu+"
| L 3 -> "tau-" | L (-3) -> "tau+"
| N 1 -> "nue" | N (-1) -> "nuebar"
| N 2 -> "numu" | N (-2) -> "numubar"
| N 3 -> "nutau" | N (-3) -> "nutaubar"
| U 1 -> "u" | U (-1) -> "ubar"
| U 2 -> "c" | U (-2) -> "cbar"
| U 3 -> "t" | U (-3) -> "tbar"
| U _ -> invalid_arg
"Modellib_PSSSM.ExtMSSM.flavor_to_string: invalid up type quark"
| D 1 -> "d" | D (-1) -> "dbar"
| D 2 -> "s" | D (-2) -> "sbar"
| D 3 -> "b" | D (-3) -> "bbar"
| D _ -> invalid_arg
"Modellib_PSSSM.ExtMSSM.flavor_to_string: invalid down type quark"
| Gl -> "gl" | Gluino -> "sgl"
| Ga -> "A" | Z -> "Z"
| Wp -> "W+" | Wm -> "W-"
| SHiggs S1 -> "h01" | SHiggs S2 -> "h02" | SHiggs S3 -> "h03"
| PHiggs P1 -> "A01" | PHiggs P2 -> "A02"
| SHiggs S4 -> "h04" | SHiggs S5 -> "h05" | SHiggs S6 -> "h06"
| PHiggs P3 -> "A03" | PHiggs P4 -> "A04"
| SHiggs S7 -> "h07" | SHiggs S8 -> "h08" | SHiggs S9 -> "h09"
| PHiggs P5 -> "A05" | PHiggs P6 -> "A06" | PHiggs P7 -> "A07"
(* JR: Only the first charged Higgs. *)
| CHiggs HC1 -> "H+" | CHiggs HC1c -> "H-"
| CHiggs HC2 -> "HX_1+" | CHiggs HC2c -> "HX_1-"
| CHiggs HC3 -> "HX_2+" | CHiggs HC3c -> "HX_2-"
| CHiggs HC4 -> "HX_3+" | CHiggs HC4c -> "HX_3-"
| CHiggs HC5 -> "HX_4+" | CHiggs HC5c -> "HX_4-"
| Slepton (M1,1) -> "se1-" | Slepton (M1,-1) -> "se1+"
| Slepton (M1,2) -> "smu1-" | Slepton (M1,-2) -> "smu1+"
| Slepton (M1,3) -> "stau1-" | Slepton (M1,-3) -> "stau1+"
| Slepton (M2,1) -> "se2-" | Slepton (M2,-1) -> "se2+"
| Slepton (M2,2) -> "smu2-" | Slepton (M2,-2) -> "smu2+"
| Slepton (M2,3) -> "stau2-" | Slepton (M2,-3) -> "stau2+"
| Sneutrino 1 -> "snue" | Sneutrino (-1) -> "snue*"
| Sneutrino 2 -> "snumu" | Sneutrino (-2) -> "snumu*"
| Sneutrino 3 -> "snutau" | Sneutrino (-3) -> "snutau*"
| Sup (M1,1) -> "su1" | Sup (M1,-1) -> "su1c"
| Sup (M1,2) -> "sc1" | Sup (M1,-2) -> "sc1c"
| Sup (M1,3) -> "st1" | Sup (M1,-3) -> "st1c"
| Sup (M2,1) -> "su2" | Sup (M2,-1) -> "su2c"
| Sup (M2,2) -> "sc2" | Sup (M2,-2) -> "sc2c"
| Sup (M2,3) -> "st2" | Sup (M2,-3) -> "st2c"
| Sdown (M1,1) -> "sd1" | Sdown (M1,-1) -> "sd1c"
| Sdown (M1,2) -> "ss1" | Sdown (M1,-2) -> "ss1c"
| Sdown (M1,3) -> "sb1" | Sdown (M1,-3) -> "sb1c"
| Sdown (M2,1) -> "sd2" | Sdown (M2,-1) -> "sd2c"
| Sdown (M2,2) -> "ss2" | Sdown (M2,-2) -> "ss2c"
| Sdown (M2,3) -> "sb2" | Sdown (M2,-3) -> "sb2c"
| Neutralino n -> "neu" ^ string_of_neu n
| Chargino C1 -> "ch1+" | Chargino C1c -> "ch1-"
| Chargino C2 -> "ch2+" | Chargino C2c -> "ch2-"
| Chargino C3 -> "ch3+" | Chargino C3c -> "ch3-"
| Chargino C4 -> "ch4+" | Chargino C4c -> "ch4-"
| LQ (M1,1) -> "lq11" | LQ (M1,-1) -> "lq11c"
| LQ (M2,1) -> "lq12" | LQ (M2,-1) -> "lq12c"
| LQ (M1,2) -> "lq21" | LQ (M1,-2) -> "lq21c"
| LQ (M2,2) -> "lq22" | LQ (M2,-2) -> "lq22c"
| LQ (M1,3) -> "lq31" | LQ (M1,-3) -> "lq31c"
| LQ (M2,3) -> "lq32" | LQ (M2,-3) -> "lq32c"
| LQino 1 -> "lqino1" | LQino (-1) -> "lqino1b"
| LQino 2 -> "lqino2" | LQino (-2) -> "lqino2b"
| LQino 3 -> "lqino3" | LQino (-3) -> "lqino3b"
| _ -> invalid_arg "Modellib_PSSSM.ExtMSSM.flavor_to_string"
let flavor_to_TeX = function
| L 1 -> "e^-" | L (-1) -> "e^+"
| L 2 -> "\\mu^-" | L (-2) -> "\\mu^+"
| L 3 -> "\\tau^-" | L (-3) -> "\\tau^+"
| N 1 -> "\\nu_e" | N (-1) -> "\\bar{\\nu}_e"
| N 2 -> "\\nu_\\mu" | N (-2) -> "\\bar{\\nu}_\\mu"
| N 3 -> "\\nu_\\tau" | N (-3) -> "\\bar{\\nu}_\\tau"
| U 1 -> "u" | U (-1) -> "\\bar{u}"
| U 2 -> "c" | U (-2) -> "\\bar{c}"
| U 3 -> "t" | U (-3) -> "\\bar{t}"
| D 1 -> "d" | D (-1) -> "\\bar{d}"
| D 2 -> "s" | D (-2) -> "\\bar{s}"
| D 3 -> "b" | D (-3) -> "\\bar{b}"
| L _ -> invalid_arg
"Modellib_PSSSM.ExtMSSM.flavor_to_TeX: invalid lepton"
| N _ -> invalid_arg
"Modellib_PSSSM.ExtMSSM.flavor_to_TeX: invalid neutrino"
| U _ -> invalid_arg
"Modellib_PSSSM.ExtMSSM.flavor_to_TeX: invalid up type quark"
| D _ -> invalid_arg
"Modellib_PSSSM.ExtMSSM.flavor_to_TeX: invalid down type quark"
| Gl -> "g" | Gluino -> "\\widetilde{g}"
| Ga -> "\\gamma" | Z -> "Z" | Wp -> "W^+" | Wm -> "W^-"
| SHiggs S1 -> "S_1" | SHiggs S2 -> "S_2" | SHiggs S3 -> "S_3"
| SHiggs S4 -> "S_4" | SHiggs S5 -> "S_5" | SHiggs S6 -> "S_6"
| SHiggs S7 -> "S_7" | SHiggs S8 -> "S_8" | SHiggs S9 -> "S_9"
| PHiggs P1 -> "P_1" | PHiggs P2 -> "P_2" | PHiggs P3 -> "P_3"
| PHiggs P4 -> "P_4" | PHiggs P5 -> "P_5" | PHiggs P6 -> "P_6"
| PHiggs P7 -> "P_7"
| CHiggs HC1 -> "H^+" | CHiggs HC1c -> "H^-"
| CHiggs HC2 -> "X_{H,1}^+" | CHiggs HC2c -> "X_{H,1}^-"
| CHiggs HC3 -> "X_{H,2}^+" | CHiggs HC3c -> "X_{H,2}^-"
| CHiggs HC4 -> "X_{H,3}^+" | CHiggs HC4c -> "X_{H,3}^-"
| CHiggs HC5 -> "X_{H,4}^+" | CHiggs HC5c -> "X_{H,4}^-"
| Slepton (M1,1) -> "\\widetilde{e}_1^-"
| Slepton (M1,-1) -> "\\widetilde{e}_1^+"
| Slepton (M1,2) -> "\\widetilde{\\mu}_1^-"
| Slepton (M1,-2) -> "\\widetilde{\\mu}_1^+"
| Slepton (M1,3) -> "\\widetilde{\\tau}_1^-"
| Slepton (M1,-3) -> "\\widetilde{\\tau}_1^+"
| Slepton (M2,1) -> "\\widetilde{e}_2^-"
| Slepton (M2,-1) -> "\\widetilde{e}_2^+"
| Slepton (M2,2) -> "\\widetilde{\\mu}_2^-"
| Slepton (M2,-2) -> "\\widetilde{\\mu}_2^+"
| Slepton (M2,3) -> "\\widetilde{\\tau}_2^-"
| Slepton (M2,-3) -> "\\widetilde{\\tau}_2^+"
| Sneutrino 1 -> "\\widetilde{\\nu}_e"
| Sneutrino (-1) -> "\\widetilde{\\nu}_e^*"
| Sneutrino 2 -> "\\widetilde{\\nu}_\\mu"
| Sneutrino (-2) -> "\\widetilde{\\nu}_\\mu^*"
| Sneutrino 3 -> "\\widetilde{\\nu}_\\tau"
| Sneutrino (-3) -> "\\widetilde{\\nu}_\\tau^*"
| Sup (M1,1) -> "\\widetilde{u}_1"
| Sup (M1,-1) -> "\\widetilde{u}_1^*"
| Sup (M1,2) -> "\\widetilde{c}_1"
| Sup (M1,-2) -> "\\widetilde{c}_1^*"
| Sup (M1,3) -> "\\widetilde{t}_1"
| Sup (M1,-3) -> "\\widetilde{t}_1^*"
| Sup (M2,1) -> "\\widetilde{u}_2"
| Sup (M2,-1) -> "\\widetilde{u}_2^*"
| Sup (M2,2) -> "\\widetilde{c}_2"
| Sup (M2,-2) -> "\\widetilde{c}_2^*"
| Sup (M2,3) -> "\\widetilde{t}_2"
| Sup (M2,-3) -> "\\widetilde{t}_2^*"
| Sdown (M1,1) -> "\\widetilde{d}_1"
| Sdown (M1,-1) -> "\\widetilde{d}_1^*"
| Sdown (M1,2) -> "\\widetilde{s}_1"
| Sdown (M1,-2) -> "\\widetilde{s}_1^*"
| Sdown (M1,3) -> "\\widetilde{b}_1"
| Sdown (M1,-3) -> "\\widetilde{b}_1^*"
| Sdown (M2,1) -> "\\widetilde{d}_2"
| Sdown (M2,-1) -> "\\widetilde{d}_2^*"
| Sdown (M2,2) -> "\\widetilde{s}_2"
| Sdown (M2,-2) -> "\\widetilde{s}_2^*"
| Sdown (M2,3) -> "\\widetilde{b}_2"
| Sdown (M2,-3) -> "\\widetilde{b}_2^*"
| Neutralino N1 -> "\\widetilde{\\chi}^0_1"
| Neutralino N2 -> "\\widetilde{\\chi}^0_2"
| Neutralino N3 -> "\\widetilde{\\chi}^0_3"
| Neutralino N4 -> "\\widetilde{\\chi}^0_4"
| Neutralino N5 -> "\\widetilde{\\chi}^0_5"
| Neutralino N6 -> "\\widetilde{\\chi}^0_6"
| Neutralino N7 -> "\\widetilde{\\chi}^0_7"
| Neutralino N8 -> "\\widetilde{\\chi}^0_8"
| Neutralino N9 -> "\\widetilde{\\chi}^0_9"
| Neutralino N10 -> "\\widetilde{\\chi}^0_{10}"
| Neutralino N11 -> "\\widetilde{\\chi}^0_{11}"
| Slepton _ -> invalid_arg
"Modellib_PSSSM.ExtMSSM.flavor_to_TeX: invalid slepton"
| Sneutrino _ -> invalid_arg
"Modellib_PSSSM.ExtMSSM.flavor_to_TeX: invalid sneutrino"
| Sup _ -> invalid_arg
"Modellib_PSSSM.ExtMSSM.flavor_to_TeX: invalid up type squark"
| Sdown _ -> invalid_arg
"Modellib_PSSSM.ExtMSSM.flavor_to_TeX: invalid down type squark"
| Chargino C1 -> "\\widetilde{\\chi}_1^+"
| Chargino C1c -> "\\widetilde{\\chi}_1^-"
| Chargino C2 -> "\\widetilde{\\chi}_2^+"
| Chargino C2c -> "\\widetilde{\\chi}_2^-"
| Chargino C3 -> "\\widetilde{\\chi}_3^+"
| Chargino C3c -> "\\widetilde{\\chi}_3^-"
| Chargino C4 -> "\\widetilde{\\chi}_4^+"
| Chargino C4c -> "\\widetilde{\\chi}_4^-"
| LQ (M1,1) -> "D_{1,,1}" | LQ (M1,-1) -> "D_{1,,1}^*"
| LQ (M2,1) -> "D_{1,,2}" | LQ (M2,-1) -> "D_{1,,2}^*"
| LQ (M1,2) -> "D_{2,,1}" | LQ (M1,-2) -> "D_{2,,1}^*"
| LQ (M2,2) -> "D_{2,,2}" | LQ (M2,-2) -> "D_{2,,2}^*"
| LQ (M1,3) -> "D_{3,,1}" | LQ (M1,-3) -> "D_{3,,1}^*"
| LQ (M2,3) -> "D_{3,,2}" | LQ (M2,-3) -> "D_{3,,2}^*"
| LQino 1 -> "\\widetilde{D}_1" | LQino (-1) -> "\\bar\\widetilde{D}_1"
| LQino 2 -> "\\widetilde{D}_2" | LQino (-2) -> "\\bar\\widetilde{D}_2"
| LQino 3 -> "\\widetilde{D}_3" | LQino (-3) -> "\\bar\\widetilde{D}_3"
| LQ _ -> invalid_arg
"Modellib_PSSSM.ExtMSSM.flavor_to_TeX: invalid leptoquark type"
| LQino _ -> invalid_arg
"Modellib_PSSSM.ExtMSSM.flavor_to_TeX: invalid leptoquarkino type"
let flavor_symbol = function
| L g when g > 0 -> "l" ^ string_of_int g
| L g -> "l" ^ string_of_int (abs g) ^ "b"
| N g when g > 0 -> "n" ^ string_of_int g
| N g -> "n" ^ string_of_int (abs g) ^ "b"
| U g when g > 0 -> "u" ^ string_of_int g
| U g -> "u" ^ string_of_int (abs g) ^ "b"
| D g when g > 0 -> "d" ^ string_of_int g
| D g -> "d" ^ string_of_int (abs g) ^ "b"
| Gl -> "gl"
| Ga -> "a" | Z -> "z"
| Wp -> "wp" | Wm -> "wm"
| Slepton (M1,g) when g > 0 -> "sl1" ^ string_of_int g
| Slepton (M1,g) -> "sl1c" ^ string_of_int (abs g)
| Slepton (M2,g) when g > 0 -> "sl2" ^ string_of_int g
| Slepton (M2,g) -> "sl2c" ^ string_of_int (abs g)
| Sneutrino g when g > 0 -> "sn" ^ string_of_int g
| Sneutrino g -> "snc" ^ string_of_int (abs g)
| Sup (M1,g) when g > 0 -> "su1" ^ string_of_int g
| Sup (M1,g) -> "su1c" ^ string_of_int (abs g)
| Sup (M2,g) when g > 0 -> "su2" ^ string_of_int g
| Sup (M2,g) -> "su2c" ^ string_of_int (abs g)
| Sdown (M1,g) when g > 0 -> "sd1" ^ string_of_int g
| Sdown (M1,g) -> "sd1c" ^ string_of_int (abs g)
| Sdown (M2,g) when g > 0 -> "sd2" ^ string_of_int g
| Sdown (M2,g) -> "sd2c" ^ string_of_int (abs g)
| Neutralino n -> "neu" ^ (string_of_neu n)
| Chargino c when (int_of_char c) > 0 -> "cp" ^ string_of_char c
| Chargino c -> "cm" ^ string_of_int (abs (int_of_char c))
| Gluino -> "sgl"
| SHiggs s -> "h0" ^ (string_of_shiggs s)
| PHiggs p -> "A0" ^ (string_of_phiggs p)
| CHiggs HC1 -> "hp" | CHiggs HC1c -> "hm"
| CHiggs _ -> invalid_arg "charged Higgs not yet implemented"
| LQ (M1,g) when g > 0 -> "lq" ^ string_of_int g ^ "1"
| LQ (M1,g) -> "lq" ^ string_of_int (abs g) ^ "1c"
| LQ (M2,g) when g > 0 -> "lq" ^ string_of_int g ^ "2"
| LQ (M2,g) -> "lq" ^ string_of_int (abs g) ^ "2c"
| LQino g when g > 0 -> "lqino" ^ string_of_int g
| LQino g -> "lqino" ^ string_of_int (abs g) ^ "b"
let pdg = function
| L g when g > 0 -> 9 + 2*g
| L g -> - 9 + 2*g
| N g when g > 0 -> 10 + 2*g
| N g -> - 10 + 2*g
| U g when g > 0 -> 2*g
| U g -> 2*g
| D g when g > 0 -> - 1 + 2*g
| D g -> 1 + 2*g
| Gl -> 21
| Ga -> 22 | Z -> 23
| Wp -> 24 | Wm -> (-24)
| SHiggs S1 -> 25 | SHiggs S2 -> 35 | PHiggs P1 -> 36
(* JR: Only the first charged Higgs. *)
| CHiggs HC1 -> 37 | CHiggs HC1c -> (-37)
| CHiggs _ -> invalid_arg "charged Higgs not yet implemented"
| Slepton (M1,g) when g > 0 -> 1000009 + 2*g
| Slepton (M1,g) -> - 1000009 + 2*g
| Slepton (M2,g) when g > 0 -> 2000009 + 2*g
| Slepton (M2,g) -> - 2000009 + 2*g
| Sneutrino g when g > 0 -> 1000010 + 2*g
| Sneutrino g -> - 1000010 + 2*g
| Sup (M1,g) when g > 0 -> 1000000 + 2*g
| Sup (M1,g) -> - 1000000 + 2*g
| Sup (M2,g) when g > 0 -> 2000000 + 2*g
| Sup (M2,g) -> - 2000000 + 2*g
| Sdown (M1,g) when g > 0 -> 999999 + 2*g
| Sdown (M1,g) -> - 999999 + 2*g
| Sdown (M2,g) when g > 0 -> 1999999 + 2*g
| Sdown (M2,g) -> - 1999999 + 2*g
| Gluino -> 1000021
(* JR: only the first two charginos. *)
| Chargino C1 -> 1000024 | Chargino C1c -> (-1000024)
| Chargino C2 -> 1000037 | Chargino C2c -> (-1000037)
| Chargino C3 -> 1000039 | Chargino C3c -> (-1000039)
| Chargino C4 -> 1000041 | Chargino C4c -> (-1000041)
| Neutralino N1 -> 1000022 | Neutralino N2 -> 1000023
| Neutralino N3 -> 1000025 | Neutralino N4 -> 1000035
(* According to SLHA2 (not anymore ?!?)*)
| Neutralino N5 -> 1000045 | Neutralino N6 -> 1000046
| Neutralino N7 -> 1000047 | Neutralino N8 -> 1000048
| Neutralino N9 -> 1000049 | Neutralino N10 -> 1000050
| Neutralino N11 -> 1000051
| PHiggs P2 -> 46 | PHiggs P3 -> 47 | PHiggs P4 -> 48
| PHiggs P5 -> 49 | PHiggs P6 -> 50 | PHiggs P7 -> 51
| SHiggs S3 -> 45 | SHiggs S4 -> 52 | SHiggs S5 -> 53
| SHiggs S6 -> 54 | SHiggs S7 -> 55 | SHiggs S8 -> 56
| SHiggs S9 -> 57
| LQ (M1,g) when g > 0 -> 1000059 + g
| LQ (M1,g) -> - 1000059 + g
| LQ (M2,g) when g > 0 -> 2000059 + g
| LQ (M2,g) -> - 2000059 + g
| LQino g when g > 0 -> 59 + g
| LQino g -> -59 + g
(* We must take care of the pdg numbers for the two different kinds of
sfermions in the MSSM. The particle data group in its Monte Carlo particle
numbering scheme takes only into account mixtures of the third generation
squarks and the stau. For the other sfermions we will use the number of the
lefthanded field for the lighter mixed state and the one for the righthanded
for the heavier. Below are the official pdg numbers from the Particle
Data Group. In order not to produce arrays with some million entries in
the Fortran code for the masses and the widths we introduce our private
pdg numbering scheme which only extends not too far beyond 42.
Our private scheme then has the following pdf numbers (for the sparticles
the subscripts $L/R$ and $1/2$ are taken synonymously):
\begin{center}
\renewcommand{\arraystretch}{1.2}
\begin{tabular}{|r|l|l|}\hline
$d$ & down-quark & 1 \\\hline
$u$ & up-quark & 2 \\\hline
$s$ & strange-quark & 3 \\\hline
$c$ & charm-quark & 4 \\\hline
$b$ & bottom-quark & 5 \\\hline
$t$ & top-quark & 6 \\\hline\hline
$e^-$ & electron & 11 \\\hline
$\nu_e$ & electron-neutrino & 12 \\\hline
$\mu^-$ & muon & 13 \\\hline
$\nu_\mu$ & muon-neutrino & 14 \\\hline
$\tau^-$ & tau & 15 \\\hline
$\nu_\tau$ & tau-neutrino & 16 \\\hline\hline
$g$ & gluon & (9) 21 \\\hline
$\gamma$ & photon & 22 \\\hline
$Z^0$ & Z-boson & 23 \\\hline
$W^+$ & W-boson & 24 \\\hline\hline
$h^0$ & light Higgs boson & 25 \\\hline
$H^0$ & heavy Higgs boson & 35 \\\hline
$A^0$ & pseudoscalar Higgs & 36 \\\hline
$H^+$ & charged Higgs & 37 \\\hline\hline
$\tilde{d}_L$ & down-squark 1 & 41 \\\hline
$\tilde{u}_L$ & up-squark 1 & 42 \\\hline
$\tilde{s}_L$ & strange-squark 1 & 43 \\\hline
$\tilde{c}_L$ & charm-squark 1 & 44 \\\hline
$\tilde{b}_L$ & bottom-squark 1 & 45 \\\hline
$\tilde{t}_L$ & top-squark 1 & 46 \\\hline
$\tilde{d}_R$ & down-squark 2 & 47 \\\hline
$\tilde{u}_R$ & up-squark 2 & 48 \\\hline
$\tilde{s}_R$ & strange-squark 2 & 49 \\\hline
$\tilde{c}_R$ & charm-squark 2 & 50 \\\hline
$\tilde{b}_R$ & bottom-squark 2 & 51 \\\hline
$\tilde{t}_R$ & top-squark 2 & 52 \\\hline\hline
$\tilde{e}_L$ & selectron 1 & 53 \\\hline
$\tilde{\nu}_{e,L}$ & electron-sneutrino & 54 \\\hline
$\tilde{\mu}_L$ & smuon 1 & 55 \\\hline
$\tilde{\nu}_{\mu,L}$ & muon-sneutrino & 56 \\\hline
$\tilde{\tau}_L$ & stau 1 & 57 \\\hline
$\tilde{\nu}_{\tau,L}$ & tau-sneutrino & 58 \\\hline
$\tilde{e}_R$ & selectron 2 & 59 \\\hline
$\tilde{\mu}_R$ & smuon 2 & 61 \\\hline
$\tilde{\tau}_R$ & stau 2 & 63 \\\hline\hline
$\tilde{g}$ & gluino & 64 \\\hline
$\tilde{\chi}^0_1$ & neutralino 1 & 65 \\\hline
$\tilde{\chi}^0_2$ & neutralino 2 & 66 \\\hline
$\tilde{\chi}^0_3$ & neutralino 3 & 67 \\\hline
$\tilde{\chi}^0_4$ & neutralino 4 & 68 \\\hline
$\tilde{\chi}^0_4$ & neutralino 5 & 69 \\\hline
$\tilde{\chi4}^+_1$ & chargino 1 & 70 \\\hline
$\tilde{\chi}^+_2$ & chargino 2 & 71 \\\hline\hline
$a$ & pseudoscalar & 72 \\\hline
$s$ & scalar singlet & 73 \\\hline
$\tilde{G}$ & gravitino & -- \\\hline\hline
\end{tabular}
\end{center} *)
let pdg_mw = function
| L g when g > 0 -> 9 + 2*g
| L g -> - 9 + 2*g
| N g when g > 0 -> 10 + 2*g
| N g -> - 10 + 2*g
| U g when g > 0 -> 2*g
| U g -> 2*g
| D g when g > 0 -> - 1 + 2*g
| D g -> 1 + 2*g
| Gl -> 21
| Ga -> 22 | Z -> 23
| Wp -> 24 | Wm -> (-24)
| SHiggs S1 -> 25 | SHiggs S2 -> 35 | PHiggs P1 -> 36
(* JR: Only the first charged Higgs. *)
| CHiggs HC1 -> 37 | CHiggs HC1c -> (-37)
| CHiggs _ -> invalid_arg "charged Higgs not yet implemented"
| Sup (M1,g) when g > 0 -> 40 + 2*g
| Sup (M1,g) -> - 40 + 2*g
| Sup (M2,g) when g > 0 -> 46 + 2*g
| Sup (M2,g) -> - 46 + 2*g
| Sdown (M1,g) when g > 0 -> 39 + 2*g
| Sdown (M1,g) -> - 39 + 2*g
| Sdown (M2,g) when g > 0 -> 45 + 2*g
| Sdown (M2,g) -> - 45 + 2*g
| Slepton (M1,g) when g > 0 -> 51 + 2*g
| Slepton (M1,g) -> - 51 + 2*g
| Slepton (M2,g) when g > 0 -> 57 + 2*g
| Slepton (M2,g) -> - 57 + 2*g
| Sneutrino g when g > 0 -> 52 + 2*g
| Sneutrino g -> - 52 + 2*g
| Gluino -> 64
(* JR: Only the first two charginos. *)
| Chargino C1 -> 70 | Chargino C1c -> (-70)
| Chargino C2 -> 71 | Chargino C2c -> (-71)
| Chargino C3 -> 106 | Chargino C3c -> (-106)
| Chargino C4 -> 107 | Chargino C4c -> (-107)
| Neutralino N1 -> 65 | Neutralino N2 -> 66
| Neutralino N3 -> 67 | Neutralino N4 -> 68
| Neutralino N5 -> 69 | Neutralino N6 -> 100
| Neutralino N7 -> 101 | Neutralino N8 -> 102
| Neutralino N9 -> 103 | Neutralino N10 -> 104
| Neutralino N11 -> 105
| PHiggs P2 -> 72 | PHiggs P3 -> 89 | PHiggs P4 -> 90
| PHiggs P5 -> 91 | PHiggs P6 -> 92 | PHiggs P7 -> 93
| SHiggs S3 -> 73 | SHiggs S4 -> 94 | SHiggs S5 -> 95
| SHiggs S6 -> 96 | SHiggs S7 -> 97 | SHiggs S8 -> 98
| SHiggs S9 -> 99
| LQ (M1,g) when g > 0 -> 78 + 2*g
| LQ (M1,g) -> - 78 + 2*g
| LQ (M2,g) when g > 0 -> 79 + 2*g
| LQ (M2,g) -> - 79 + 2*g
| LQino g when g > 0 -> 85 + g
| LQino g -> - 85 + g
let mass_symbol f =
"mass(" ^ string_of_int (abs (pdg_mw f)) ^ ")"
let width_symbol f =
"width(" ^ string_of_int (abs (pdg_mw f)) ^ ")"
let conj_symbol = function
| false, str -> str
| true, str -> str ^ "_c"
let constant_symbol = function
| E -> "e" | G -> "g" | G_Z -> "gz"
| Q_lepton -> "qlep" | Q_up -> "qup" | Q_down -> "qdwn"
| Q_charg -> "qchar"
| G_NC_lepton -> "gnclep" | G_NC_neutrino -> "gncneu"
| G_NC_up -> "gncup" | G_NC_down -> "gncdwn"
| G_CC -> "gcc"
| G_CCQ (vc,g1,g2) -> conj_symbol (vc, "g_ccq" ) ^ "("
^ string_of_int g1 ^ "," ^ string_of_int g2 ^ ")"
| I_Q_W -> "iqw" | I_G_ZWW -> "igzww"
| G_WWWW -> "gw4" | G_ZZWW -> "gzzww"
| G_PZWW -> "gpzww" | G_PPWW -> "gppww"
| G_GH4_ZZPP (p1,p2) -> "g_ZZA0A0(" ^ string_of_phiggs p1 ^ "," ^
string_of_phiggs p2 ^ ")"
| G_GH4_ZZSS (s1,s2) -> "g_ZZh0h0(" ^ string_of_shiggs s1 ^ "," ^
string_of_shiggs s2 ^ ")"
| G_GH4_ZZCC -> "g_zzhphm"
| G_GH4_GaGaCC -> "g_AAhphm"
| G_GH4_ZGaCC -> "g_zAhphm"
| G_GH4_WWCC -> "g_wwhphm"
| G_GH4_WWPP (p1,p2) -> "g_WWA0A0(" ^ string_of_phiggs p1 ^ "," ^
string_of_phiggs p2 ^ ")"
| G_GH4_WWSS (s1,s2) -> "g_WWh0h0(" ^ string_of_shiggs s1 ^ "," ^
string_of_shiggs s2 ^ ")"
| G_GH4_ZWSC s -> "g_ZWhph0(" ^ string_of_shiggs s ^")"
| G_GH4_GaWSC s -> "g_AWhph0(" ^ string_of_shiggs s ^")"
| G_GH4_ZWPC p -> "g_ZWhpA0(" ^ string_of_phiggs p ^")"
| G_GH4_GaWPC p -> "g_AWhpA0(" ^ string_of_phiggs p ^")"
| G_CICIS (n1,n2,s) -> "g_neuneuh0(" ^ string_of_neu n1 ^ "," ^
string_of_neu n2 ^ "," ^ string_of_shiggs s ^ ")"
| G_CICIP (n1,n2,p) -> "g_neuneuA0(" ^ string_of_neu n1 ^ "," ^
string_of_neu n2 ^ "," ^ string_of_phiggs p ^ ")"
| G_H3_SCC s -> "g_h0hphm(" ^ string_of_shiggs s ^ ")"
| G_H3_SPP (s,p1,p2) -> "g_h0A0A0(" ^ string_of_shiggs s ^ "," ^
string_of_phiggs p1 ^ "," ^ string_of_phiggs p2 ^ ")"
| G_H3_SSS (s1,s2,s3) -> "g_h0h0h0(" ^ string_of_shiggs s1 ^ "," ^
string_of_shiggs s2 ^ "," ^ string_of_shiggs s3 ^ ")"
| G_CSC (c1,c2,s) -> "g_chchh0(" ^ string_of_char c1 ^ "," ^
string_of_char c2 ^ "," ^ string_of_shiggs s ^ ")"
| G_CPC (c1,c2,p) -> "g_chchA0(" ^ string_of_char c1 ^ "," ^
string_of_char c2 ^ "," ^ string_of_phiggs p ^")"
| G_YUK_FFS (f1,f2,s) -> "g_yuk_h0_" ^ string_of_fermion_type f1 ^
string_of_fermion_type f2 ^ "(" ^ string_of_shiggs s ^ "," ^
string_of_fermion_gen f1 ^ ")"
| G_YUK_FFP (f1,f2,p) -> "g_yuk_A0_" ^ string_of_fermion_type f1 ^
string_of_fermion_type f2 ^ "(" ^ string_of_phiggs p ^ "," ^
string_of_fermion_gen f1 ^ ")"
| G_YUK_LCN g -> "g_yuk_hp_ln(" ^ string_of_int g ^ ")"
| G_NWC (n,c) -> "g_nwc(" ^ string_of_char c ^ "," ^ string_of_neu n ^ ")"
| G_CWN (c,n) -> "g_cwn(" ^ string_of_char c ^ "," ^ string_of_neu n ^ ")"
| G_SLSNW (vc,g,m) -> conj_symbol (vc, "g_wslsn") ^ "(" ^ string_of_int g
^ "," ^ string_of_sfm m ^ ")"
| G_NZN (n1,n2) -> "g_zneuneu(" ^ string_of_neu n1 ^ ","
^ string_of_neu n2 ^ ")"
| G_CZC (c1,c2) -> "g_zchch(" ^ string_of_char c1 ^ ","
^ string_of_char c2 ^ ")"
| Gs -> "gs"
| G_YUK_UCD (n,m) -> "g_yuk_hp_ud(" ^ string_of_int n ^ "," ^
string_of_int m ^ ")"
| G_YUK_DCU (n,m) -> "g_yuk_hm_du(" ^ string_of_int n ^ "," ^
string_of_int m ^ ")"
| G_YUK_N (vc,f,n,sf,m) -> conj_symbol (vc, "g_yuk_neu_" ^
string_of_fermion_type f ^ string_of_sff sf) ^ "(" ^
string_of_fermion_gen f ^ "," ^ string_of_neu n ^ "," ^
string_of_sfm m ^ ")"
| G_YUK_G (vc,f,sf,m) -> conj_symbol (vc, "g_yuk_gluino_" ^
string_of_fermion_type f ^ string_of_sff sf) ^ "(" ^
string_of_fermion_gen f ^ "," ^ string_of_sfm m ^ ")"
| G_YUK_C (vc,f,c,sf,m) -> conj_symbol (vc, "g_yuk_char_" ^
string_of_fermion_type f ^ string_of_sff sf) ^ "(" ^
string_of_fermion_gen f ^ "," ^ string_of_char c ^ "," ^
string_of_sfm m ^ ")"
| G_YUK_Q (vc,g1,f,c,sf,m) -> conj_symbol (vc, "g_yuk_char_" ^
string_of_fermion_type f ^ string_of_sff sf) ^"("^string_of_int g1 ^
"," ^ string_of_fermion_gen f ^ "," ^ string_of_char c ^ "," ^
string_of_sfm m ^ ")"
| G_WPSUSD (vc,m1,m2,g1,g2) -> conj_symbol (vc, "g_wA_susd") ^ "(" ^
string_of_int g1 ^ "," ^ string_of_int g2 ^ "," ^ string_of_sfm m1 ^
"," ^ string_of_sfm m2 ^ ")"
| G_WZSUSD (vc,m1,m2,g1,g2) -> conj_symbol (vc, "g_wz_susd") ^ "(" ^
string_of_int g1 ^ "," ^ string_of_int g2 ^ "," ^ string_of_sfm m1
^ "," ^ string_of_sfm m2 ^ ")"
(* 3vertex: Higgs-Gauge a la Franke-Fraas *)
(* Nomenclature consistent with [flavor_of_string] *)
| G_GH_ZSP (s,p) -> "g_zh0a0(" ^ string_of_shiggs s ^ "," ^
string_of_phiggs p ^ ")"
| G_GH_WSC s -> "g_Whph0(" ^ string_of_shiggs s ^ ")"
| G_GH_WPC p -> "g_WhpA0(" ^ string_of_phiggs p^ ")"
| G_GH_ZZS s -> "g_ZZh0(" ^ string_of_shiggs s ^ ")"
| G_GH_WWS s -> "g_WWh0(" ^ string_of_shiggs s ^ ")"
| G_GH_ZCC -> "g_Zhmhp"
| G_GH_GaCC -> "g_Ahmhp"
| G_ZSF (f,g,m1,m2) -> "g_z" ^ string_of_sff f ^ string_of_sff f ^ "(" ^
string_of_int g ^ "," ^ string_of_sfm m1 ^ "," ^ string_of_sfm m2 ^ ")"
| G_HSNSL (vc,g,m) -> conj_symbol (vc, "g_hp_sl" ^ string_of_sfm m ^ "sn1" )
^ "(" ^ string_of_int g ^ ")"
| G_GlGlSQSQ -> "g_gg_sqsq"
| G_PPSFSF f -> "g_AA_" ^ string_of_sff f ^ string_of_sff f
| G_ZZSFSF (f,g,m1,m2) -> "g_zz_" ^ string_of_sff f ^string_of_sff f ^ "(" ^
string_of_int g ^ "," ^ string_of_sfm m1 ^ "," ^ string_of_sfm m2 ^ ")"
| G_ZPSFSF (f,g,m1,m2) -> "g_zA_" ^ string_of_sff f ^string_of_sff f ^ "("
^ string_of_int g ^","^ string_of_sfm m1 ^ "," ^ string_of_sfm m2 ^ ")"
| G_GlPSQSQ -> "g_gA_sqsq"
| G_GlZSFSF (f,g,m1,m2) -> "g_gz_" ^ string_of_sff f ^ string_of_sff f ^
"(" ^ string_of_int g ^ "," ^ string_of_sfm m1 ^ "," ^ string_of_sfm
m2 ^ ")"
| G_GlWSUSD (vc,m1,m2,g1,g2) -> conj_symbol (vc, "g_gw_susd") ^ "(" ^
string_of_int g1 ^ "," ^string_of_int g2 ^ "," ^ string_of_sfm m1 ^ ","
^ string_of_sfm m2 ^ ")"
| G_strong -> "gs" | G_SS -> "gs**2"
| I_G_S -> "igs"
| G_NHC (vc,n,c) -> conj_symbol(vc,"g_neuhmchar") ^ "(" ^
string_of_neu n ^ "," ^ string_of_char c ^ ")"
| G_WWSFSF (f,g,m1,m2) -> "g_ww_" ^ string_of_sff f ^ string_of_sff f ^
"(" ^ string_of_int g ^ "," ^ string_of_sfm m1 ^ "," ^ string_of_sfm m2
^ ")"
| G_WPSLSN (vc,g,m) -> conj_symbol (vc, "g_wA_slsn") ^"("^ string_of_int g
^ "," ^ string_of_sfm m ^ ")"
| G_WZSLSN (vc,g,m) -> conj_symbol (vc, "g_wz_slsn") ^ "(" ^ string_of_int
g ^ "," ^ string_of_sfm m ^ ")"
| G_SFSFS (s,f,g,m1,m2) -> "g_h0_"^ string_of_sff f ^ string_of_sfm m1
^ string_of_sff f ^ string_of_sfm m2 ^ "(" ^ string_of_shiggs s ^ "," ^
string_of_int g ^ ")"
| G_SFSFP (p,f,g,m1,m2) -> "g_A0_"^ string_of_sff f ^ string_of_sfm m1
^ string_of_sff f ^ string_of_sfm m2 ^ "(" ^ string_of_phiggs p ^ "," ^
string_of_int g ^ ")"
| G_HSUSD (vc,m1,m2,g1,g2) -> conj_symbol (vc, "g_hp_su" ^ string_of_sfm m1
^ "sd" ^ string_of_sfm m2 ) ^ "(" ^ string_of_int g1 ^ ","
^ string_of_int g2 ^ ")"
| G_WSQ (vc,g1,g2,m1,m2) -> conj_symbol (vc, "g_wsusd") ^ "("
^ string_of_int g1 ^ "," ^ string_of_int g2 ^ "," ^ string_of_sfm m1 ^
"," ^ string_of_sfm m2 ^ ")"
| G_YUK_LQ_S (g1,s,g3) -> "g_yuk_lq_s(" ^ string_of_int g1 ^ "," ^
string_of_shiggs s ^"," ^ string_of_int g3 ^")"
| G_YUK_LQ_P (g1,p,g3) -> "g_yuk_lq_p(" ^ string_of_int g1 ^ "," ^
string_of_phiggs p ^ "," ^ string_of_int g3 ^ ")"
| G_LQ_NEU (m,g1,g2,n) -> "g_lq_neu(" ^ string_of_sfm m ^ "," ^
string_of_int g1 ^ "," ^ string_of_int g2 ^ "," ^ string_of_neu n ^ ")"
| G_LQ_GG (m,g1,g2) -> "g_lq_gg(" ^ string_of_sfm m ^ "," ^
string_of_int g1 ^ "," ^ string_of_int g2 ^ ")"
| G_LQ_EC_UC (vc,m,g1,g2,g3) -> conj_symbol(vc,"g_lq_ec_uc") ^ "(" ^
string_of_sfm m ^ "," ^ string_of_int g1 ^ "," ^ string_of_int g2 ^ ","
^ string_of_int g3 ^ ")"
| G_LQ_SSU (m1,m2,m3,g1,g2,g3) -> "g_lq_sst(" ^ string_of_sfm m1 ^ "," ^
string_of_sfm m2 ^ "," ^ string_of_sfm m3 ^ "," ^ string_of_int g1 ^ "," ^
string_of_int g2 ^ "," ^ string_of_int g3 ^ ")"
| G_LQ_SSD (m1,m2,g1,g2,g3) -> "g_lq_ssta(" ^ string_of_sfm m1 ^ "," ^
string_of_sfm m2 ^ "," ^ string_of_int g1 ^ "," ^ string_of_int g2 ^
"," ^ string_of_int g3 ^ ")"
| G_LQ_S (m1,m2,g1,s,g2) -> "g_lq_s(" ^ string_of_sfm m1 ^ "," ^ string_of_sfm m2 ^ ","
^ string_of_int g1 ^ "," ^ string_of_shiggs s ^ "," ^ string_of_int g2 ^ ")"
| G_LQ_P (m1,m2,g1,p,g2) -> "g_lq_s(" ^ string_of_sfm m1 ^ "," ^ string_of_sfm m2 ^ ","
^ string_of_int g1 ^ "," ^ string_of_phiggs p ^ "," ^ string_of_int g2 ^ ")"
| G_ZLQ (g,m1,m2) -> "g_zlqlq(" ^ string_of_int g ^ "," ^
string_of_sfm m1 ^ "," ^ string_of_sfm m2 ^ ")"
| G_ZZLQLQ -> "g_zz_lqlq"
| G_ZPLQLQ -> "g_zA_lqlq"
| G_PPLQLQ -> "g_AA_lqlq"
| G_ZGlLQLQ -> "g_zg_lqlq"
| G_PGlLQLQ -> "g_Ag_lqlq"
| G_GlGlLQLQ -> "g_gg_lqlq"
| G_NLQC -> "g_nlqc"
end
Index: trunk/omega/src/omega_Zprime_VM.ml
===================================================================
--- trunk/omega/src/omega_Zprime_VM.ml (revision 8899)
+++ trunk/omega/src/omega_Zprime_VM.ml (revision 8900)
@@ -1,32 +1,26 @@
(* omega_Zprime_VM.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
cf. main AUTHORS file
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.VM)
- (Modellib_Zprime.Zprime(Modellib_Zprime.SM_no_anomalous))
+module O = Omega.Mixed23(Target_VM.Make)(Modellib_Zprime.Zprime(Modellib_Zprime.SM_no_anomalous))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
-i*)
Index: trunk/omega/src/DAG.ml
===================================================================
--- trunk/omega/src/DAG.ml (revision 8899)
+++ trunk/omega/src/DAG.ml (revision 8900)
@@ -1,500 +1,641 @@
(* DAG.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
module type Ord =
sig
type t
val compare : t -> t -> int
end
module type Forest =
sig
module Nodes : Ord
type node = Nodes.t
type edge
type children
type t = edge * children
val compare : t -> t -> int
val for_all : (node -> bool) -> t -> bool
val fold : (node -> 'a -> 'a) -> t -> 'a -> 'a
end
module type T =
sig
type node
type edge
type children
type t
val empty : t
val add_node : node -> t -> t
val add_offspring : node -> edge * children -> t -> t
exception Cycle
val add_offspring_unsafe : node -> edge * children -> t -> t
val is_node : node -> t -> bool
val is_sterile : node -> t -> bool
val is_offspring : node -> edge * children -> t -> bool
val iter_nodes : (node -> unit) -> t -> unit
val map_nodes : (node -> node) -> t -> t
val fold_nodes : (node -> 'a -> 'a) -> t -> 'a -> 'a
val iter : (node -> edge * children -> unit) -> t -> unit
val map : (node -> node) ->
(node -> edge * children -> edge * children) -> t -> t
val fold : (node -> edge * children -> 'a -> 'a) -> t -> 'a -> 'a
val lists : t -> (node * (edge * children) list) list
val dependencies : t -> node -> (node, edge) Tree2.t
val harvest : t -> node -> t -> t
val harvest_list : t -> node list -> t
val size : t -> int
val eval : (node -> 'a) -> (node -> edge -> 'c -> 'd) ->
('a -> 'c -> 'c) -> ('d -> 'a -> 'a) -> 'a -> 'c -> node -> t -> 'a
val eval_memoized : (node -> 'a) -> (node -> edge -> 'c -> 'd) ->
('a -> 'c -> 'c) -> ('d -> 'a -> 'a) -> 'a -> 'c -> node -> t -> 'a
val forest : node -> t -> (node * edge option, node) Tree.t list
val forest_memoized : node -> t -> (node * edge option, node) Tree.t list
val count_trees : node -> t -> int
end
module type Graded_Ord =
sig
include Ord
module G : Ord
val rank : t -> G.t
end
module type Grader = functor (O : Ord) -> Graded_Ord with type t = O.t
module type Graded_Forest =
sig
module Nodes : Graded_Ord
type node = Nodes.t
type edge
type children
type t = edge * children
val compare : t -> t -> int
val for_all : (node -> bool) -> t -> bool
val fold : (node -> 'a -> 'a) -> t -> 'a -> 'a
end
module type Forest_Grader = functor (G : Grader) -> functor (F : Forest) ->
Graded_Forest with type Nodes.t = F.node
and type node = F.node
and type edge = F.edge
and type children = F.children
and type t = F.t
(* \thocwmodulesection{The [Forest] Functor} *)
module Forest (PT : Tuple.Poly) (N : Ord) (E : Ord) :
Forest with module Nodes = N and type edge = E.t
and type node = N.t and type children = N.t PT.t =
struct
module Nodes = N
type edge = E.t
type node = N.t
type children = node PT.t
type t = edge * children
- let compare (e1, n1) (e2, n2) =
- let c = PT.compare N.compare n1 n2 in
+ let compare (edge1, children1) (edge2, children2) =
+ let c = PT.compare N.compare children1 children2 in
if c <> 0 then
c
else
- E.compare e1 e2
+ E.compare edge1 edge2
let for_all f (_, nodes) = PT.for_all f nodes
let fold f (_, nodes) acc = PT.fold_right f nodes acc
end
(* \thocwmodulesection{Gradings} *)
module Chaotic (O : Ord) =
struct
include O
module G =
struct
type t = unit
let compare _ _ = 0
end
let rank _ = ()
end
module Discrete (O : Ord) =
struct
include O
module G = O
let rank x = x
end
module Fake_Grading (O : Ord) =
struct
include O
exception Impossible of string
module G =
struct
type t = unit
let compare _ _ = raise (Impossible "G.compare")
end
let rank _ = raise (Impossible "G.compare")
end
module Grade_Forest (G : Grader) (F : Forest) =
struct
module Nodes = G(F.Nodes)
type node = Nodes.t
type edge = F.edge
type children = F.children
type t = F.t
let compare = F.compare
let for_all = F.for_all
let fold = F.fold
end
-(* \begin{dubious}
- The following can easily be extended to [Map.S] in its full glory,
- if we ever need it.
- \end{dubious} *)
+(* A subset of [Map.S], with graded keys. The map is implemented
+ as a two level map with the outer map from the rank of the key
+ to a map from all key of this rank to the values.
+ Thus we can find query the minimal and maximal ranks
+ and find all keys with a given rank without having to
+ scan the entire map.*)
module type Graded_Map =
sig
+
+(* We implement the subset of [Map.S] from the standard library
+ that we need in our applications. The semantics is identical
+ to [Map.S] so we don't need to duplicate the documentation.
+ It would be trivial to implement the rest, if we ever need it. *)
+
type key
- type rank
type 'a t
val empty : 'a t
val add : key -> 'a -> 'a t -> 'a t
val find : key -> 'a t -> 'a
val mem : key -> 'a t -> bool
val iter : (key -> 'a -> unit) -> 'a t -> unit
val fold : (key -> 'a -> 'b -> 'b) -> 'a t -> 'b -> 'b
+
+(* Here come the additional functions dealing with the [rank].
+ All could be implemented by inspecting all keys in a map,
+ but the keeping track of the grading makes them much more
+ efficient.*)
+ type rank
+
+(* Return a list of all ranks in a map. The application should not
+ rely on the fact that the list is sorted. *)
val ranks : 'a t -> rank list
+
+(* Return the minimal and maximal rank in the map, according to the
+ order of [rank]. *)
val min_max_rank : 'a t -> rank * rank
+
+(* Return all keys with the given [rank]. *)
val ranked : rank -> 'a t -> key list
+
end
module type Graded_Map_Maker = functor (O : Graded_Ord) ->
Graded_Map with type key = O.t and type rank = O.G.t
+(* \begin{dubious}
+ Nested ['a -> 'b opt] functions cry out for the
+ monadic binding operators introduced by O'Caml 4.08.
+ \end{dubious} *)
module Graded_Map (O : Graded_Ord) :
Graded_Map with type key = O.t and type rank = O.G.t =
struct
module M1 = Map.Make(O.G)
module M2 = Map.Make(O)
type key = O.t
type rank = O.G.t
type (+'a) t = 'a M2.t M1.t
let empty = M1.empty
+
+ let map2_of_rank rank map1 =
+ match M1.find_opt rank map1 with
+ | None -> M2.empty
+ | Some map2 -> map2
+
let add key data map1 =
let rank = O.rank key in
- let map2 = try M1.find rank map1 with Not_found -> M2.empty in
- M1.add rank (M2.add key data map2) map1
- let find key map = M2.find key (M1.find (O.rank key) map)
- let mem key map =
- M2.mem key (try M1.find (O.rank key) map with Not_found -> M2.empty)
- let iter f map1 = M1.iter (fun rank -> M2.iter f) map1
- let fold f map1 acc1 = M1.fold (fun rank -> M2.fold f) map1 acc1
+ M1.add rank (M2.add key data (map2_of_rank rank map1)) map1
+
+ let find key map1 =
+ M2.find key (M1.find (O.rank key) map1)
+
+ let mem key map1 =
+ M2.mem key (map2_of_rank (O.rank key) map1)
+
+ let iter f map1 =
+ M1.iter (fun rank -> M2.iter f) map1
+
+ let fold f map1 acc1 =
+ M1.fold (fun rank -> M2.fold f) map1 acc1
(* \begin{dubious}
The set of ranks and its minimum and maximum should be maintained
explicitely!
\end{dubious} *)
module S1 = Set.Make(O.G)
- let ranks map = M1.fold (fun key data acc -> key :: acc) map []
- let rank_set map = M1.fold (fun key data -> S1.add key) map S1.empty
+
+ let ranks map =
+ M1.fold (fun key data acc -> key :: acc) map []
+
+ let rank_set map =
+ M1.fold (fun key data -> S1.add key) map S1.empty
+
let min_max_rank map =
let s = rank_set map in
(S1.min_elt s, S1.max_elt s)
module S2 = Set.Make(O)
- let keys map = M2.fold (fun key data acc -> key :: acc) map []
+
+ let keys map =
+ M2.fold (fun key data acc -> key :: acc) map []
+
let sorted_keys map =
S2.elements (M2.fold (fun key data -> S2.add key) map S2.empty)
- let ranked rank map =
- keys (try M1.find rank map with Not_found -> M2.empty)
+
+ let ranked rank map1 =
+ keys (map2_of_rank rank map1)
+
end
-(* \thocwmodulesection{The DAG Functor} *)
+(* \thocwmodulesection{The DAG Functor} *)
+
+(* Currently, we are \emph{not} using the grading in O'Mega.
+ It seemed to be an interesting idea for structuring DAGs,
+ but we have not yet come up with a real use case \ldots *)
module Maybe_Graded (GMM : Graded_Map_Maker) (F : Graded_Forest) =
struct
module G = F.Nodes.G
type node = F.node
type rank = G.t
type edge = F.edge
type children = F.children
(* If we get tired of graded DAGs, we just have to replace [Graded_Map] by
[Map] here and remove [ranked] below and gain a tiny amount of simplicity
and efficiency. *)
module Parents = GMM(F.Nodes)
module Offspring = Set.Make(F)
type t = Offspring.t Parents.t
let rank = F.Nodes.rank
let ranks = Parents.ranks
let min_max_rank = Parents.min_max_rank
let ranked = Parents.ranked
let empty = Parents.empty
let add_node node dag =
if Parents.mem node dag then
dag
else
Parents.add node Offspring.empty dag
let add_offspring_unsafe node offspring dag =
let offsprings =
try Parents.find node dag with Not_found -> Offspring.empty in
Parents.add node (Offspring.add offspring offsprings)
(F.fold add_node offspring dag)
(*i
let c = ref 0
let offspring_add offspring offsprings =
if Offspring.mem offspring offsprings then
(Printf.eprintf "<<<%d>>>\n" !c; incr c);
Offspring.add offspring offsprings
let add_offspring_unsafe node offspring dag =
let offsprings =
try Parents.find node dag with Not_found -> Offspring.empty in
Parents.add node (offspring_add offspring offsprings)
(F.fold add_node offspring dag)
i*)
exception Cycle
let add_offspring node offspring dag =
if F.for_all (fun n -> F.Nodes.compare n node < 0) offspring then
add_offspring_unsafe node offspring dag
else
raise Cycle
let is_node node dag =
Parents.mem node dag
let is_sterile node dag =
try
Offspring.is_empty (Parents.find node dag)
with
| Not_found -> false
let is_offspring node offspring dag =
try
Offspring.mem offspring (Parents.find node dag)
with
| Not_found -> false
let iter_nodes f dag =
Parents.iter (fun n _ -> f n) dag
let iter f dag =
Parents.iter (fun node -> Offspring.iter (f node)) dag
let map_nodes f dag =
Parents.fold (fun n -> Parents.add (f n)) dag Parents.empty
let map fn fo dag =
Parents.fold (fun node offspring ->
Parents.add (fn node)
(Offspring.fold (fun o -> Offspring.add (fo node o))
offspring Offspring.empty)) dag Parents.empty
let fold_nodes f dag acc =
Parents.fold (fun n _ -> f n) dag acc
let fold f dag acc =
Parents.fold (fun node -> Offspring.fold (f node)) dag acc
(* \begin{dubious}
Note that in it's current incarnation,
[fold add_offspring dag empty] copies \emph{only} the fertile nodes, while
[fold add_offspring dag (fold_nodes add_node dag empty)]
includes sterile ones, as does
[map (fun n -> n) (fun n ec -> ec) dag].
\end{dubious} *)
let dependencies dag node =
let rec dependencies' node' =
let offspring = Parents.find node' dag in
if Offspring.is_empty offspring then
Tree2.leaf node'
else
Tree2.cons
(Offspring.fold
(fun o acc ->
(fst o,
node',
F.fold (fun wf acc' -> dependencies' wf :: acc') o []) :: acc)
offspring [])
in
dependencies' node
let lists dag =
List.sort (fun (n1, _) (n2, _) -> F.Nodes.compare n1 n2)
(Parents.fold (fun node offspring l ->
(node, Offspring.elements offspring) :: l) dag [])
let size dag =
Parents.fold (fun _ _ n -> succ n) dag 0
let rec harvest dag node roots =
Offspring.fold
(fun offspring roots' ->
if is_offspring node offspring roots' then
roots'
else
F.fold (harvest dag)
offspring (add_offspring_unsafe node offspring roots'))
(Parents.find node dag) (add_node node roots)
let harvest_list dag nodes =
List.fold_left (fun roots node -> harvest dag node roots) empty nodes
(* Build a closure once, so that we can recurse faster: *)
let eval f mule muln add null unit node dag =
let rec eval' n =
if is_sterile n dag then
f n
else
Offspring.fold
(fun (e, _ as offspring) v0 ->
add (mule n e (F.fold muln' offspring unit)) v0)
(Parents.find n dag) null
and muln' n = muln (eval' n) in
eval' node
let count_trees node dag =
eval (fun _ -> 1) (fun _ _ p -> p) ( * ) (+) 0 1 node dag
let build_forest evaluator node dag =
evaluator (fun n -> [Tree.leaf (n, None) n])
(fun n e p -> List.map (fun p' -> Tree.cons (n, Some e) p') p)
(fun p1 p2 -> Product.fold2 (fun n nl pl -> (n :: nl) :: pl) p1 p2 [])
(@) [] [[]] node dag
let forest = build_forest eval
(* At least for [count_trees], the memoizing variant [eval_memoized] is
considerably slower than direct recursive evaluation with [eval]. *)
let eval_offspring f mule muln add null unit dag values (node, offspring) =
let muln' n = muln (Parents.find n values) in
let v =
if is_sterile node dag then
f node
else
Offspring.fold
(fun (e, _ as offspring) v0 ->
add (mule node e (F.fold muln' offspring unit)) v0)
offspring null
in
(v, Parents.add node v values)
let eval_memoized' f mule muln add null unit dag =
let result, _ =
List.fold_left
(fun (v, values) -> eval_offspring f mule muln add null unit dag values)
(null, Parents.empty)
(List.sort (fun (n1, _) (n2, _) -> F.Nodes.compare n1 n2)
(Parents.fold
(fun node offspring l -> (node, offspring) :: l) dag [])) in
result
let eval_memoized f mule muln add null unit node dag =
eval_memoized' f mule muln add null unit
(harvest dag node empty)
let forest_memoized = build_forest eval_memoized
end
module type Graded =
sig
include T
type rank
val rank : node -> rank
val ranks : t -> rank list
val min_max_rank : t -> rank * rank
val ranked : rank -> t -> node list
end
module Graded (F : Graded_Forest) = Maybe_Graded(Graded_Map)(F)
(* The following is not a graded map, obviously. But it can pass as one by the
typechecker for constructing non-graded DAGs. *)
module Fake_Graded_Map (O : Graded_Ord) :
Graded_Map with type key = O.t and type rank = O.G.t =
struct
module M = Map.Make(O)
type key = O.t
type (+'a) t = 'a M.t
let empty = M.empty
let add = M.add
let find = M.find
let mem = M.mem
let iter = M.iter
let fold = M.fold
(* We make sure that the remaining three are never called inside [DAG] and
are not visible outside. *)
type rank = O.G.t
exception Impossible of string
let ranks _ = raise (Impossible "ranks")
let min_max_rank _ = raise (Impossible "min_max_rank")
let ranked _ _ = raise (Impossible "ranked")
end
(* We could also have used signature projection with a chaotic or discrete
grading, but the [Graded_Map] can cost some efficiency. This is probably
not the case for the current simple implementation, but future embellishment
can change this. Therefore, the ungraded DAG uses [Map] directly,
without overhead. *)
module Make (F : Forest) =
Maybe_Graded(Fake_Graded_Map)(Grade_Forest(Fake_Grading)(F))
(* \begin{dubious}
If O'Caml had \textit{polymorphic recursion}, we could think
of even more elegant implementations unifying nodes and offspring
(cf.~the generalized tries in~\cite{Okasaki:1998:book}).
\end{dubious} *)
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
+(* \begin{dubious}
+ GADTs to the rescue?
+ \end{dubious} *)
+
+(* \thocwmodulesection{Unit Tests} *)
+
+module Test =
+ struct
+
+ let random_int_list imax n =
+ let imax_plus = succ imax in
+ Array.to_list (Array.init n (fun _ -> Random.int imax_plus))
+
+ module OInts =
+ struct
+ type t = int
+ let compare = compare
+ end
+ module GOInts =
+ struct
+ type t = int
+ let compare = compare
+ module G =
+ struct
+ type t = int
+ let compare = compare
+ end
+ let rank i = i mod 100
+ end
+
+ module GM = Graded_Map(GOInts)
+
+ let int_list_to_string l =
+ ThoList.to_string string_of_int l
+
+ let int_list2_to_string l =
+ ThoList.to_string int_list_to_string l
+
+ let int_pair_to_string (i1, i2) =
+ int_list_to_string [i1; i2]
+
+ let uniq l =
+ ThoList.uniq (List.sort compare l)
+
+ open OUnit
+
+ let assert_equal_int_pair p1 p2 =
+ assert_equal ~printer:int_pair_to_string p1 p2
+
+ let assert_equal_unsorted_int_list l1 l2 =
+ assert_equal ~printer:int_list_to_string
+ (List.sort compare l1)
+ (List.sort compare l2)
+
+ let assert_equal_unsorted_int_list_ignore_duplicates l1 l2 =
+ assert_equal ~printer:int_list_to_string (uniq l1) (uniq l2)
+
+ let squares n =
+ let data =
+ List.map (fun i -> (i, i * i)) (random_int_list 10000 n) in
+ let map =
+ List.fold_left (fun acc (i, s) -> GM.add i s acc) GM.empty data in
+ (data, map)
+
+ let suite_graded_map =
+
+ "Graded_Map" >:::
+ [ "ranks" >::
+ (fun () ->
+ let data, graded_map = squares 100 in
+ assert_equal_unsorted_int_list
+ (uniq (List.map (fun (i, _) -> GOInts.rank i) data))
+ (GM.ranks graded_map));
+
+ "min_max_rank" >::
+ (fun () ->
+ match squares 100 with
+ | [], _ -> failwith "empty test data"
+ | (r0, _) :: data, graded_map ->
+ assert_equal_int_pair
+ (List.fold_left
+ (fun (r_min, r_max) (i, _) ->
+ let r = GOInts.rank i in
+ (min r r_min, max r r_max))
+ (GOInts.rank r0, GOInts.rank r0) data)
+ (GM.min_max_rank graded_map)) ]
+
+(* \begin{dubious}
+ We should add more unit tests, time permitting.
+ \end{dubious} *)
+
+ let suite =
+ "DAG" >:::
+ [suite_graded_map]
+
+ end
Index: trunk/omega/src/omega_Threeshl_nohf.ml
===================================================================
--- trunk/omega/src/omega_Threeshl_nohf.ml (revision 8899)
+++ trunk/omega/src/omega_Threeshl_nohf.ml (revision 8900)
@@ -1,35 +1,26 @@
(* omega_Threeshl_nohf.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.Fortran)
- (Modellib_BSM.Threeshl(Modellib_BSM.Threeshl_no_ckm_no_hf))
+module O = Omega.Mixed23(Target_Fortran.Make)(Modellib_BSM.Threeshl(Modellib_BSM.Threeshl_no_ckm_no_hf))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/target_VM.mli
===================================================================
--- trunk/omega/src/target_VM.mli (revision 0)
+++ trunk/omega/src/target_VM.mli (revision 8900)
@@ -0,0 +1,25 @@
+(* target_VM.mli --
+
+ Copyright (C) 1999-2023 by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+ with contributions from
+ Christian Speckner <cnspeckn@googlemail.com>
+
+ WHIZARD is free software; you can redistribute it and/or modify it
+ under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ WHIZARD is distributed in the hope that it will be useful, but
+ WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
+
+module Make : Target.Maker
Index: trunk/omega/src/target_Fortran_Names.ml
===================================================================
--- trunk/omega/src/target_Fortran_Names.ml (revision 0)
+++ trunk/omega/src/target_Fortran_Names.ml (revision 8900)
@@ -0,0 +1,156 @@
+(* targets_vintage.ml --
+
+ Copyright (C) 1999-2023 by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+ with contributions from
+ Christian Speckner <cnspeckn@googlemail.com>
+ Fabian Bach <fabian.bach@t-online.de> (only parts of this file)
+ Marco Sekulla <marco.sekulla@kit.edu> (only parts of this file)
+ Bijan Chokoufe Nejad <bijan.chokoufe@desy.de> (only parts of this file)
+ So Young Shim <soyoung.shim@desy.de>
+
+ WHIZARD is free software; you can redistribute it and/or modify it
+ under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ WHIZARD is distributed in the hope that it will be useful, but
+ WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
+
+module type T =
+ sig
+ val psi_type : string
+ val psibar_type : string
+ val chi_type : string
+ val grav_type : string
+ val psi_incoming : string
+ val brs_psi_incoming : string
+ val psibar_incoming : string
+ val brs_psibar_incoming : string
+ val chi_incoming : string
+ val brs_chi_incoming : string
+ val grav_incoming : string
+ val psi_outgoing : string
+ val brs_psi_outgoing : string
+ val psibar_outgoing : string
+ val brs_psibar_outgoing : string
+ val chi_outgoing : string
+ val brs_chi_outgoing : string
+ val grav_outgoing : string
+ val psi_propagator : string
+ val psibar_propagator : string
+ val chi_propagator : string
+ val grav_propagator : string
+ val psi_projector : string
+ val psibar_projector : string
+ val chi_projector : string
+ val grav_projector : string
+ val psi_gauss : string
+ val psibar_gauss : string
+ val chi_gauss : string
+ val grav_gauss : string
+ val use_module : string
+ val require_library : string list
+ end
+
+module Dirac : T =
+ struct
+
+ let psi_type = "spinor"
+ let psibar_type = "conjspinor"
+ let chi_type = "???"
+ let grav_type = "???"
+
+ let psi_incoming = "u"
+ let brs_psi_incoming = "brs_u"
+ let psibar_incoming = "vbar"
+ let brs_psibar_incoming = "brs_vbar"
+ let chi_incoming = "???"
+ let brs_chi_incoming = "???"
+ let grav_incoming = "???"
+ let psi_outgoing = "v"
+ let brs_psi_outgoing = "brs_v"
+ let psibar_outgoing = "ubar"
+ let brs_psibar_outgoing = "brs_ubar"
+ let chi_outgoing = "???"
+ let brs_chi_outgoing = "???"
+ let grav_outgoing = "???"
+
+ let psi_propagator = "pr_psi"
+ let psibar_propagator = "pr_psibar"
+ let chi_propagator = "???"
+ let grav_propagator = "???"
+
+ let psi_projector = "pj_psi"
+ let psibar_projector = "pj_psibar"
+ let chi_projector = "???"
+ let grav_projector = "???"
+
+ let psi_gauss = "pg_psi"
+ let psibar_gauss = "pg_psibar"
+ let chi_gauss = "???"
+ let grav_gauss = "???"
+
+ let use_module = "omega95"
+ let require_library =
+ ["omega_spinors_2010_01_A"; "omega_spinor_cpls_2010_01_A"]
+ end
+
+module Majorana : T =
+ struct
+
+ let psi_type = "bispinor"
+ let psibar_type = "bispinor"
+ let chi_type = "bispinor"
+ let grav_type = "vectorspinor"
+
+(* \begin{JR}
+ Because of our rules for fermions we are going to give all incoming fermions
+ a [u] spinor and all outgoing fermions a [v] spinor, no matter whether they
+ are Dirac fermions, antifermions or Majorana fermions.
+ \end{JR} *)
+
+ let psi_incoming = "u"
+ let brs_psi_incoming = "brs_u"
+ let psibar_incoming = "u"
+ let brs_psibar_incoming = "brs_u"
+ let chi_incoming = "u"
+ let brs_chi_incoming = "brs_u"
+ let grav_incoming = "ueps"
+
+ let psi_outgoing = "v"
+ let brs_psi_outgoing = "brs_v"
+ let psibar_outgoing = "v"
+ let brs_psibar_outgoing = "brs_v"
+ let chi_outgoing = "v"
+ let brs_chi_outgoing = "brs_v"
+ let grav_outgoing = "veps"
+
+ let psi_propagator = "pr_psi"
+ let psibar_propagator = "pr_psi"
+ let chi_propagator = "pr_psi"
+ let grav_propagator = "pr_grav"
+
+ let psi_projector = "pj_psi"
+ let psibar_projector = "pj_psi"
+ let chi_projector = "pj_psi"
+ let grav_projector = "pj_grav"
+
+ let psi_gauss = "pg_psi"
+ let psibar_gauss = "pg_psi"
+ let chi_gauss = "pg_psi"
+ let grav_gauss = "pg_grav"
+
+ let use_module = "omega95_bispinors"
+ let require_library =
+ ["omega_bispinors_2010_01_A"; "omega_bispinor_cpls_2010_01_A"]
+ end
Index: trunk/omega/src/omega_THDM_VM.ml
===================================================================
--- trunk/omega/src/omega_THDM_VM.ml (revision 8899)
+++ trunk/omega/src/omega_THDM_VM.ml (revision 8900)
@@ -1,36 +1,27 @@
(* omega_THDM_VM.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
cf. main AUTHORS file
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.VM)
- (Modellib_BSM.TwoHiggsDoublet(Modellib_BSM.THDM))
+module O = Omega.Mixed23(Target_VM.Make)(Modellib_BSM.TwoHiggsDoublet(Modellib_BSM.THDM))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/omega_SM_Higgs.ml
===================================================================
--- trunk/omega/src/omega_SM_Higgs.ml (revision 8899)
+++ trunk/omega/src/omega_SM_Higgs.ml (revision 8900)
@@ -1,35 +1,26 @@
(* omega_SM_Higgs.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.Fortran)
- (Modellib_SM.SM(Modellib_SM.SM_Higgs))
+module O = Omega.Mixed23(Target_Fortran.Make)(Modellib_SM.SM(Modellib_SM.SM_Higgs))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/omega_Simplest_univ.ml
===================================================================
--- trunk/omega/src/omega_Simplest_univ.ml (revision 8899)
+++ trunk/omega/src/omega_Simplest_univ.ml (revision 8900)
@@ -1,35 +1,26 @@
(* omega_Simplest_univ.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.Fortran_Majorana)
- (Modellib_BSM.Simplest(Modellib_BSM.BSM_anom))
+module O = Omega.Mixed23(Target_Fortran.Make_Majorana)(Modellib_BSM.Simplest(Modellib_BSM.BSM_anom))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/omega_Littlest.ml
===================================================================
--- trunk/omega/src/omega_Littlest.ml (revision 8899)
+++ trunk/omega/src/omega_Littlest.ml (revision 8900)
@@ -1,35 +1,26 @@
(* omega_Littlest.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.Fortran_Majorana)
- (Modellib_BSM.Littlest(Modellib_BSM.BSM_bsm))
+module O = Omega.Mixed23(Target_Fortran.Make_Majorana)(Modellib_BSM.Littlest(Modellib_BSM.BSM_bsm))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/omega_MSSM_Hgg.ml
===================================================================
--- trunk/omega/src/omega_MSSM_Hgg.ml (revision 8899)
+++ trunk/omega/src/omega_MSSM_Hgg.ml (revision 8900)
@@ -1,34 +1,26 @@
(* omega_MSSM_Hgg.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23_Majorana_vintage(Targets.Fortran_Majorana)(Modellib_MSSM.MSSM(Modellib_MSSM.MSSM_Hgg))
+module O = Omega.Mixed23_Majorana_vintage(Target_Fortran.Make_Majorana)(Modellib_MSSM.MSSM(Modellib_MSSM.MSSM_Hgg))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/UFOx.ml
===================================================================
--- trunk/omega/src/UFOx.ml (revision 8899)
+++ trunk/omega/src/UFOx.ml (revision 8900)
@@ -1,1770 +1,1879 @@
(* vertex.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
let error_in_string text start_pos end_pos =
let i = max 0 start_pos.Lexing.pos_cnum in
let j = min (String.length text) (max (i + 1) end_pos.Lexing.pos_cnum) in
String.sub text i (j - i)
let error_in_file name start_pos end_pos =
Printf.sprintf
"%s:%d.%d-%d.%d"
name
start_pos.Lexing.pos_lnum
(start_pos.Lexing.pos_cnum - start_pos.Lexing.pos_bol)
end_pos.Lexing.pos_lnum
(end_pos.Lexing.pos_cnum - end_pos.Lexing.pos_bol)
-module SMap = Map.Make (struct type t = string let compare = compare end)
+module SMap = Map.Make(String)
module Expr =
struct
type t = UFOx_syntax.expr
let of_string text =
try
UFOx_parser.input
UFOx_lexer.token
(UFOx_lexer.init_position "" (Lexing.from_string text))
with
| UFO_tools.Lexical_Error (msg, start_pos, end_pos) ->
invalid_arg (Printf.sprintf "lexical error (%s) at: `%s'"
msg (error_in_string text start_pos end_pos))
| UFOx_syntax.Syntax_Error (msg, start_pos, end_pos) ->
invalid_arg (Printf.sprintf "syntax error (%s) at: `%s'"
msg (error_in_string text start_pos end_pos))
| Parsing.Parse_error ->
invalid_arg ("parse error: " ^ text)
let of_strings = function
| [] -> UFOx_syntax.integer 0
| string :: strings ->
List.fold_right
(fun s acc -> UFOx_syntax.add (of_string s) acc)
strings (of_string string)
open UFOx_syntax
let rec map f = function
- | Integer _ | Float _ | Quoted _ as e -> e
+ | Integer _ | Float _ | Quoted _ | Young_Tableau _ as e -> e
| Variable s as e ->
begin match f s with
| Some value -> value
| None -> e
end
| Sum (e1, e2) -> Sum (map f e1, map f e2)
| Difference (e1, e2) -> Difference (map f e1, map f e2)
| Product (e1, e2) -> Product (map f e1, map f e2)
| Quotient (e1, e2) -> Quotient (map f e1, map f e2)
| Power (e1, e2) -> Power (map f e1, map f e2)
| Application (s, el) -> Application (s, List.map (map f) el)
let substitute name value expr =
map (fun s -> if s = name then Some value else None) expr
let rename1 name_map name =
try Some (Variable (SMap.find name name_map)) with Not_found -> None
let rename alist_names value =
let name_map =
List.fold_left
(fun acc (name, name') -> SMap.add name name' acc)
SMap.empty alist_names in
map (rename1 name_map) value
let map_name1 f name =
Some (Variable (f name))
let map_names f value =
map (fun name -> Some (Variable (f name))) value
let half name =
Quotient (Variable name, Integer 2)
let variables = UFOx_syntax.variables
let functions = UFOx_syntax.functions
end
(* It might seem to be a hack to base the decision of whether a
sign or parentheses are required on the textual representation
of a term. However we control the textual representation, it's
efficient and we can avoid duplicating quite a bit of code
testing for terms that might produce minus signs. *)
let starts_with_a_sign s =
String.length s > 0 && let c = s.[0] in c = '-' || c = '+'
let starts_with_a_plus s =
String.length s > 0 && s.[0] = '+'
let starts_with_a_minus s =
String.length s > 0 && s.[0] = '-'
let prepend_binary_plus s =
if starts_with_a_sign s then
s
else
"+" ^ s
(* The safe version that might produce terms like $-(-a)$. *)
let prepend_binary_minus s =
if starts_with_a_sign s then
"-(" ^ s ^ ")"
else
"-" ^ s
(* The version that produces fewer parentheses, but must
assume that a leading minus sign always applies to the
\emph{whole} term! *)
let prepend_binary_minus s =
if starts_with_a_plus s then
"-" ^ String.sub s 1 (String.length s - 1)
else if starts_with_a_minus s then
"+" ^ String.sub s 1 (String.length s - 1)
else
"-" ^ s
module Value =
struct
module S = UFOx_syntax
module Q = Algebra.Q
type builtin =
| Sqrt
| Exp | Log | Log10
| Sin | Asin
| Cos | Acos
| Tan | Atan
| Sinh | Asinh
| Cosh | Acosh
| Tanh | Atanh
| Sec | Asec
| Csc | Acsc
| Conj | Abs
let builtin_to_string = function
| Sqrt -> "sqrt"
| Exp -> "exp"
| Log -> "log"
| Log10 -> "log10"
| Sin -> "sin"
| Cos -> "cos"
| Tan -> "tan"
| Asin -> "asin"
| Acos -> "acos"
| Atan -> "atan"
| Sinh -> "sinh"
| Cosh -> "cosh"
| Tanh -> "tanh"
| Asinh -> "asinh"
| Acosh -> "acosh"
| Atanh -> "atanh"
| Sec -> "sec"
| Csc -> "csc"
| Asec -> "asec"
| Acsc -> "acsc"
| Conj -> "conjg"
| Abs -> "abs"
let builtin_of_string = function
| "cmath.sqrt" -> Sqrt
| "cmath.exp" -> Exp
| "cmath.log" -> Log
| "cmath.log10" -> Log10
| "cmath.sin" -> Sin
| "cmath.cos" -> Cos
| "cmath.tan" -> Tan
| "cmath.asin" -> Asin
| "cmath.acos" -> Acos
| "cmath.atan" -> Atan
| "cmath.sinh" -> Sinh
| "cmath.cosh" -> Cosh
| "cmath.tanh" -> Tanh
| "cmath.asinh" -> Asinh
| "cmath.acosh" -> Acosh
| "cmath.atanh" -> Atanh
| "sec" -> Sec
| "csc" -> Csc
| "asec" -> Asec
| "acsc" -> Acsc
| "complexconjugate" -> Conj
| "abs" -> Abs
| name -> failwith ("UFOx.Value: unsupported function: " ^ name)
type t =
| Integer of int
| Rational of Q.t
| Real of float
| Complex of float * float
| Variable of string
| Sum of t list
| Difference of t * t
| Product of t list
| Quotient of t * t
| Power of t * t
| Application of builtin * t list
(* At first sight, unparsing appears to be simpler than parsing.
Nevertheless, it can become tricky and error prone if one wants
to produce readable output that is not cluttered by too many
parentheses. *)
let signed_string_of_float x =
(if x < 0.0 then "-" else "+") ^ string_of_float (abs_float x)
(* Collect the numerical factors in a [Product] in order to
reduce the number of parentheses required.
\begin{dubious}
We could include [Rational], but is it worth it?
\end{dubious} *)
let collect_factors elist =
let rec collect_factors' factor elist_rev elist =
match factor, elist with
| (Integer 1| Real 1.), [] -> List.rev elist_rev
| _, [] -> factor :: List.rev elist_rev
| Integer i1, Integer i2 :: elist' ->
collect_factors' (Integer (i1 * i2)) elist_rev elist'
| Integer i, Real x :: elist' | Real x, Integer i :: elist' ->
collect_factors' (Real (float i *. x)) elist_rev elist'
| Real x1, Real x2 :: elist' ->
collect_factors' (Real (x1 *. x2)) elist_rev elist'
| _, e :: elist' -> collect_factors' factor (e :: elist_rev) elist' in
collect_factors' (Integer 1) [] elist
let rec to_string = function
| Integer i -> string_of_int i
| Rational q -> Q.to_string q
| Real x -> string_of_float x
| Complex (0.0, 1.0) -> "I"
| Complex (0.0, i) -> group_product (Product [Real i; Complex (0.0, 1.0)])
| Complex (r, 0.0) -> to_string (Real r)
| Complex (r, i) -> group_sum (Sum [Real r; Product [Real i; Complex (0.0, 1.0)]])
| Variable s -> s
| Sum [] -> "0"
| Sum [e] -> to_string e
| Sum (e::es) -> to_string e ^ String.concat "" (List.map with_binary_plus es)
| Difference (e1, e2) -> to_string e1 ^ prepend_binary_minus (group_sum e2)
| Product [] -> "1"
| Product es ->
begin match collect_factors es with
| (Integer (-1) | Real (-1.)) :: es -> "-" ^ to_string (Product es)
| es -> String.concat "*" (List.map group_sum es)
end
| Quotient (e1, e2) -> group_numerator e1 ^ "/" ^ group_denominator e2
| Power ((Power (_, _) as e1, (Power (_, _) as e2))) ->
"(" ^ group_product e1 ^ ")^(" ^ to_string e2 ^ ")"
| Power ((Power (_, _) as e1, e2)) ->
"(" ^ group_product e1 ^ ")^" ^ to_string e2
| Power (e1, (Power (_, _) as e2)) ->
group_product e1 ^ "^(" ^ to_string e2 ^ ")"
| Power ((Integer i as e), Integer p) ->
if p < 0 then
group_product (Real (float_of_int i)) ^ "^(" ^ string_of_int p ^ ")"
else if p = 0 then
"1"
else if p <= 4 then
group_product e ^ "^" ^ string_of_int p
else
group_product (Real (float_of_int i)) ^ "^" ^ string_of_int p
| Power (e1, e2) -> group_product e1 ^ "^" ^ group_product e2
| Application (f, [Integer i]) -> to_string (Application (f, [Real (float i)]))
| Application (f, es) ->
builtin_to_string f ^ "(" ^ String.concat "," (List.map to_string es) ^ ")"
(* Expressions that appear as arguments of [Power]s must be
enclosed in parentheses, unless they are singletons. In
a denominator, we don't have to put function applications
in parentheses.
\begin{dubious}
Check this with \texttt{Whizard}'s parser, since this is the
main (only?) consumer of our output.
\end{dubious} *)
and group_product = function
| Application (_, _) as e -> "(" ^ to_string e ^ ")"
| e -> group_denominator e
(* In numerators, we must be careful not to leave an unprotected minus sign,
since they can appear inside products. *)
and group_numerator = function
| Product (_ :: _ as es) ->
begin match collect_factors es with
| (Integer (-1) | Real (-1.)) :: es -> "(-" ^ to_string (Product es) ^ ")"
| es -> String.concat "*" (List.map group_sum es)
end
| e -> group_denominator e
and group_denominator = function
| Sum [e] | Product [e] -> group_product e
| Sum ( _ :: _) | Difference (_, _)
| Product ( _ :: _) | Quotient (_, _) as e -> "(" ^ to_string e ^ ")"
| e -> to_string e
(* [Sum]s that appear in [Product]s must be
enclosed in parentheses, unless they are singletons. *)
and group_sum = function
| Sum [e] | Product [e] -> group_sum e
| Sum ( _ :: _) | Difference (_, _) as e -> "(" ^ to_string e ^ ")"
| e -> to_string e
(* Add a ['+'] at the front of a term iff if has no sign. *)
and with_binary_plus e =
prepend_binary_plus (to_string e)
let rec to_coupling atom = function
| Integer i -> Coupling.Integer i
| Rational q ->
let n, d = Q.to_ratio q in
Coupling.Quot (Coupling.Integer n, Coupling.Integer d)
| Real x -> Coupling.Float x
| Product es -> Coupling.Prod (List.map (to_coupling atom) es)
| Variable s -> Coupling.Atom (atom s)
| Complex (r, 0.0) -> Coupling.Float r
| Complex (0.0, 1.0) -> Coupling.I
| Complex (0.0, -1.0) -> Coupling.Prod [Coupling.I; Coupling.Integer (-1)]
| Complex (0.0, i) -> Coupling.Prod [Coupling.I; Coupling.Float i]
| Complex (r, 1.0) ->
Coupling.Sum [Coupling.Float r; Coupling.I]
| Complex (r, -1.0) ->
Coupling.Diff (Coupling.Float r, Coupling.I)
| Complex (r, i) ->
Coupling.Sum [Coupling.Float r;
Coupling.Prod [Coupling.I; Coupling.Float i]]
| Sum es -> Coupling.Sum (List.map (to_coupling atom) es)
| Difference (e1, e2) ->
Coupling.Diff (to_coupling atom e1, to_coupling atom e2)
| Quotient (e1, e2) ->
Coupling.Quot (to_coupling atom e1, to_coupling atom e2)
| Power (e1, Integer e2) ->
Coupling.Pow (to_coupling atom e1, e2)
| Power (e1, e2) ->
Coupling.PowX (to_coupling atom e1, to_coupling atom e2)
| Application (f, [e]) -> apply1 (to_coupling atom e) f
| Application (f, []) ->
failwith
("UFOx.Value.to_coupling: " ^ builtin_to_string f ^
": empty argument list")
| Application (f, _::_::_) ->
failwith
("UFOx.Value.to_coupling: " ^ builtin_to_string f ^
": more than one argument in list")
and apply1 e = function
| Sqrt -> Coupling.Sqrt e
| Exp -> Coupling.Exp e
| Log -> Coupling.Log e
| Log10 -> Coupling.Log10 e
| Sin -> Coupling.Sin e
| Cos -> Coupling.Cos e
| Tan -> Coupling.Tan e
| Asin -> Coupling.Asin e
| Acos -> Coupling.Acos e
| Atan -> Coupling.Atan e
| Sinh -> Coupling.Sinh e
| Cosh -> Coupling.Cosh e
| Tanh -> Coupling.Tanh e
| Sec -> Coupling.Quot (Coupling.Integer 1, Coupling.Cos e)
| Csc -> Coupling.Quot (Coupling.Integer 1, Coupling.Sin e)
| Asec -> Coupling.Acos (Coupling.Quot (Coupling.Integer 1, e))
| Acsc -> Coupling.Asin (Coupling.Quot (Coupling.Integer 1, e))
| Conj -> Coupling.Conj e
| Abs -> Coupling.Abs e
| (Asinh | Acosh | Atanh as f) ->
failwith
("UFOx.Value.to_coupling: function `"
^ builtin_to_string f ^ "' not supported yet!")
(* \begin{dubious}
The constant propagation here is incomplete.
[S.Quotient] and [S.Power] are not yet handled
and in [S.Sum] and [S.Product] only adjacent constants
are combined.
\end{dubious}
\begin{dubious}
We could include [Rational], but is it worth it?
\end{dubious} *)
let compress terms = terms
let rec of_expr e =
compress (of_expr' e)
and of_expr' = function
| S.Integer i -> Integer i
| S.Float x -> Real x
| S.Variable "cmath.pi" -> Variable "pi"
| S.Quoted name ->
invalid_arg ("UFOx.Value.of_expr: unexpected quoted variable '" ^
name ^ "'")
+ | S.Young_Tableau y ->
+ invalid_arg ("UFOx.Value.of_expr: unexpected Young tableau '" ^
+ Young.tableau_to_string string_of_int y ^ "'")
| S.Variable name -> Variable name
| S.Sum (e1, e2) ->
begin match of_expr e1, of_expr e2 with
| Integer i1, Integer i2 -> Integer (i1 + i2)
| Integer i, Real x | Real x, Integer i -> Real (float_of_int i +. x)
| Real x1, Real x2 -> Real (x1 +. x2)
| (Integer 0 | Real 0.), e -> e
| e, (Integer 0 | Real 0.) -> e
| Sum e1, Sum e2 -> Sum (e1 @ e2)
| e1, Sum e2 -> Sum (e1 :: e2)
| Sum e1, e2 -> Sum (e1 @ [e2])
| e1, e2 -> Sum [e1; e2]
end
| S.Difference (e1, e2) ->
begin match of_expr e1, of_expr e2 with
| Integer i1, Integer i2 -> Integer (i1 - i2)
| Integer i, Real x -> Real (float_of_int i -. x)
| Real x, Integer i -> Real (x -. float_of_int i)
| Real x1, Real x2 -> Real (x1 -. x2)
| e1, (Integer 0 | Real 0.) -> e1
| e1, e2 -> Difference (e1, e2)
end
| S.Product (e1, e2) ->
begin match of_expr e1, of_expr e2 with
| Integer i1, Integer i2 -> Integer (i1 * i2)
| Integer i, Real x | Real x, Integer i -> Real (float_of_int i *. x)
| Real x1, Real x2 -> Real (x1 *. x2)
| (Integer 0 | Real 0.), _ -> Integer 0
| _, (Integer 0 | Real 0.) -> Integer 0
| (Integer 1 | Real 1.), e -> e
| e, (Integer 1 | Real 1.) -> e
| Product e1, Product e2 -> Product (e1 @ e2)
| e1, Product e2 -> Product (e1 :: e2)
| Product e1, e2 -> Product (e1 @ [e2])
| e1, e2 -> Product [e1; e2]
end
| S.Quotient (e1, e2) ->
begin match of_expr e1, of_expr e2 with
| e1, (Integer 0 | Real 0.) ->
invalid_arg "UFOx.Value: divide by 0"
| e1, (Integer 1 | Real 1.) -> e1
| Integer i1, Integer i2 -> Rational (Q.make i1 i2)
| Real x, Integer i -> Real (x /. float i)
| Integer i, Real x -> Real (float i /. x)
| Real x1, Real x2 -> Real (x1 /. x2)
| e1, e2 -> Quotient (e1, e2)
end
| S.Power (e, p) ->
begin match of_expr e, of_expr p with
| (Integer 0 | Real 0.), (Integer 0 | Real 0.) ->
invalid_arg "UFOx.Value: 0^0"
| _, (Integer 0 | Real 0.) -> Integer 1
| e, (Integer 1 | Real 1.) -> e
| Integer e, Integer p ->
if p < 0 then
Power (Real (float_of_int e), Integer p)
else if p = 0 then
Integer 1
else if p <= 4 then
Power (Integer e, Integer p)
else
Power (Real (float_of_int e), Integer p)
| e, p -> Power (e, p)
end
| S.Application ("complex", [r; i]) ->
begin match of_expr r, of_expr i with
| r, (Integer 0 | Real 0.0) -> r
| Real r, Real i -> Complex (r, i)
| Integer r, Real i -> Complex (float_of_int r, i)
| Real r, Integer i -> Complex (r, float_of_int i)
| Integer r, Integer i -> Complex (float_of_int r, float_of_int i)
| _ -> invalid_arg "UFOx.Value: complex expects two numeric arguments"
end
| S.Application ("complex", _) ->
invalid_arg "UFOx.Value: complex expects two arguments"
| S.Application ("complexconjugate", [e]) ->
Application (Conj, [of_expr e])
| S.Application ("complexconjugate", _) ->
invalid_arg "UFOx.Value: complexconjugate expects single argument"
| S.Application ("cmath.sqrt", [e]) ->
Application (Sqrt, [of_expr e])
| S.Application ("cmath.sqrt", _) ->
invalid_arg "UFOx.Value: sqrt expects single argument"
| S.Application (name, args) ->
Application (builtin_of_string name, List.map of_expr args)
end
let positive integers =
List.filter (fun (i, _) -> i > 0) integers
let not_positive integers =
List.filter (fun (i, _) -> i <= 0) integers
module type Index =
sig
type t = int
val position : t -> int
val factor : t -> int
val unpack : t -> int * int
val pack : int -> int -> t
val map_position : (int -> int) -> t -> t
val to_string : t -> string
val list_to_string : t list -> string
val free : (t * 'r) list -> (t * 'r) list
val summation : (t * 'r) list -> (t * 'r) list
val classes_to_string : ('r -> string) -> (t * 'r) list -> string
val fresh_summation : unit -> t
val named_summation : string -> unit -> t
end
module Index : Index =
struct
type t = int
let free i = positive i
let summation i = not_positive i
let position i =
if i > 0 then
i mod 1000
else
i
let factor i =
if i > 0 then
i / 1000
else
invalid_arg "UFOx.Index.factor: argument not positive"
let unpack i =
if i > 0 then
(position i, factor i)
else
(i, 0)
let pack i j =
if j > 0 then
if i > 0 then
1000 * j + i
else
invalid_arg "UFOx.Index.pack: position not positive"
else if j = 0 then
i
else
invalid_arg "UFOx.Index.pack: factor negative"
let map_position f i =
let pos, fac = unpack i in
pack (f pos) fac
let to_string i =
let pos, fac = unpack i in
if fac = 0 then
Printf.sprintf "%d" pos
else
Printf.sprintf "%d.%d" pos fac
let to_string' = string_of_int
let list_to_string is =
"[" ^ String.concat ", " (List.map to_string is) ^ "]"
let classes_to_string rep_to_string index_classes =
let reps =
ThoList.uniq (List.sort compare (List.map snd index_classes)) in
"[" ^
String.concat ", "
(List.map
(fun r ->
(rep_to_string r) ^ "=" ^
(list_to_string
(List.map
fst
(List.filter (fun (_, r') -> r = r') index_classes))))
reps) ^ "]"
type factory =
{ mutable named : int SMap.t;
mutable used : Sets.Int.t }
let factory =
{ named = SMap.empty;
used = Sets.Int.empty }
let first_anonymous = -1001
let fresh_summation () =
let next_anonymous =
try
pred (Sets.Int.min_elt factory.used)
with
| Not_found -> first_anonymous in
factory.used <- Sets.Int.add next_anonymous factory.used;
next_anonymous
let named_summation name () =
try
SMap.find name factory.named
with
| Not_found ->
begin
let next_named = fresh_summation () in
factory.named <- SMap.add name next_named factory.named;
next_named
end
end
module type Atom =
sig
type t
val map_indices : (int -> int) -> t -> t
val rename_indices : (int -> int) -> t -> t
val contract_pair : t -> t -> t option
val variable : t -> string option
val scalar : t -> bool
val is_unit : t -> bool
val invertible : t -> bool
val invert : t -> t
val of_expr : string -> UFOx_syntax.expr list -> t list
val to_string : t -> string
type r
val classify_indices : t list -> (Index.t * r) list
val disambiguate_indices : t list -> t list
val rep_to_string : r -> string
val rep_to_string_whizard : r -> string
val rep_of_int : bool -> int -> r
+ val rep_of_int_or_young_tableau : bool -> int option -> int Young.tableau option -> r
val rep_conjugate : r -> r
val rep_trivial : r -> bool
type r_omega
val omega : r -> r_omega
end
module type Tensor =
sig
type atom
type 'a linear = ('a list * Algebra.QC.t) list
type t =
| Linear of atom linear
| Ratios of (atom linear * atom linear) list
val map_atoms : (atom -> atom) -> t -> t
val map_indices : (int -> int) -> t -> t
val rename_indices : (int -> int) -> t -> t
val map_coeff : (Algebra.QC.t -> Algebra.QC.t) -> t -> t
val contract_pairs : t -> t
val variables : t -> string list
val of_expr : UFOx_syntax.expr -> t
val of_string : string -> t
val of_strings : string list -> t
val to_string : t -> string
type r
val classify_indices : t -> (Index.t * r) list
val rep_to_string : r -> string
val rep_to_string_whizard : r -> string
val rep_of_int : bool -> int -> r
+ val rep_of_int_or_young_tableau : bool -> int option -> int Young.tableau option -> r
val rep_conjugate : r -> r
val rep_trivial : r -> bool
type r_omega
val omega : r -> r_omega
end
module Tensor (A : Atom) : Tensor
with type atom = A.t and type r = A.r and type r_omega = A.r_omega =
struct
module S = UFOx_syntax
(* TODO: we have to switch to [Algebra.QC] to support complex
coefficients, as used in custom propagators. *)
module Q = Algebra.Q
module QC = Algebra.QC
type atom = A.t
type 'a linear = ('a list * Algebra.QC.t) list
type t =
| Linear of atom linear
| Ratios of (atom linear * atom linear) list
let term_to_string (tensors, c) =
if QC.is_null c then
""
else
match tensors with
| [] -> QC.to_string c
| tensors ->
String.concat
"*" ((if QC.is_unit c then [] else [QC.to_string c]) @
List.map A.to_string tensors)
let linear_to_string = function
| [] -> ""
| term :: terms ->
term_to_string term ^
String.concat "" (List.map (fun t -> prepend_binary_plus (term_to_string t)) terms)
let to_string = function
| Linear terms -> linear_to_string terms
| Ratios ratios ->
String.concat
" + "
(List.map
(fun (n, d) ->
Printf.sprintf "(%s)/(%s)"
(linear_to_string n) (linear_to_string d)) ratios)
let variables_of_atoms atoms =
List.fold_left
(fun acc a ->
match A.variable a with
| None -> acc
| Some name -> Sets.String.add name acc)
Sets.String.empty atoms
let variables_of_linear linear =
List.fold_left
(fun acc (atoms, _) -> Sets.String.union (variables_of_atoms atoms) acc)
Sets.String.empty linear
let variables_set = function
| Linear linear -> variables_of_linear linear
| Ratios ratios ->
List.fold_left
(fun acc (numerator, denominator) ->
Sets.String.union
(variables_of_linear numerator)
(Sets.String.union (variables_of_linear denominator) acc))
Sets.String.empty ratios
let variables t =
Sets.String.elements (variables_set t)
let map_ratios f = function
| Linear n -> Linear (f n)
| Ratios ratios -> Ratios (List.map (fun (n, d) -> (f n, f d)) ratios)
let map_summands f t =
map_ratios (List.map f) t
let map_numerators f = function
| Linear n -> Linear (List.map f n)
| Ratios ratios ->
Ratios (List.map (fun (n, d) -> (List.map f n, d)) ratios)
let map_atoms f t =
map_summands (fun (atoms, q) -> (List.map f atoms, q)) t
let map_indices f t =
map_atoms (A.map_indices f) t
let rename_indices f t =
map_atoms (A.rename_indices f) t
let map_coeff f t =
map_numerators (fun (atoms, q) -> (atoms, f q)) t
type result =
| Matched of atom list
| Unmatched of atom list
(* [contract_pair a rev_prefix suffix] returns
[Unmatched (a :: List.rev_append rev_prefix suffix] if
there is no match (as defined by [A.contract_pair]) and
[Matched] with the reduced list otherwise. *)
let rec contract_pair a rev_prefix = function
| [] -> Unmatched (a :: List.rev rev_prefix)
| a' :: suffix ->
begin match A.contract_pair a a' with
| None -> contract_pair a (a' :: rev_prefix) suffix
| Some a'' ->
if A.is_unit a'' then
Matched (List.rev_append rev_prefix suffix)
else
Matched (List.rev_append rev_prefix (a'' :: suffix))
end
(* Use [contract_pair] to find all pairs that match according
to [A.contract_pair]. *)
let rec contract_pairs1 = function
| ([] | [_] as t) -> t
| a :: t ->
begin match contract_pair a [] t with
| Unmatched ([]) -> []
| Unmatched (a' :: t') -> a' :: contract_pairs1 t'
| Matched t' -> contract_pairs1 t'
end
let contract_pairs t =
map_summands (fun (t', c) -> (contract_pairs1 t', c)) t
let add t1 t2 =
match t1, t2 with
| Linear l1, Linear l2 -> Linear (l1 @ l2)
| Ratios r, Linear l | Linear l, Ratios r ->
Ratios ((l, [([], QC.unit)]) :: r)
| Ratios r1, Ratios r2 -> Ratios (r1 @ r2)
let multiply1 (t1, c1) (t2, c2) =
(List.sort compare (t1 @ t2), QC.mul c1 c2)
let multiply2 t1 t2 =
Product.list2 multiply1 t1 t2
let multiply t1 t2 =
match t1, t2 with
| Linear l1, Linear l2 -> Linear (multiply2 l1 l2)
| Ratios r, Linear l | Linear l, Ratios r ->
Ratios (List.map (fun (n, d) -> (multiply2 l n, d)) r)
| Ratios r1, Ratios r2 ->
Ratios (Product.list2
(fun (n1, d1) (n2, d2) ->
(multiply2 n1 n2, multiply2 d1 d2))
r1 r2)
let rec power n t =
if n < 0 then
invalid_arg "UFOx.Tensor.power: n < 0"
else if n = 0 then
Linear [([], QC.unit)]
else if n = 1 then
t
else
multiply t (power (pred n) t)
let compress ratios =
map_ratios
(fun terms ->
List.map (fun (t, cs) -> (t, QC.sum cs)) (ThoList.factorize terms))
ratios
let rec of_expr e =
contract_pairs (compress (of_expr' e))
and of_expr' = function
| S.Integer i -> Linear [([], QC.make (Q.make i 1) Q.null)]
| S.Float _ -> invalid_arg "UFOx.Tensor.of_expr: unexpected float"
| S.Quoted name ->
invalid_arg ("UFOx.Tensor.of_expr: unexpected quoted variable '" ^
name ^ "'")
+ | S.Young_Tableau y ->
+ invalid_arg ("UFOx.Tensor.of_expr: unexpected top level Young tableau '" ^
+ Young.tableau_to_string string_of_int y ^ "'")
| S.Variable name ->
(* There should be a gatekeeper here or in [A.of_expr]: *)
Linear [(A.of_expr name [], QC.unit)]
| S.Application ("complex", [re; im]) ->
begin match of_expr re, of_expr im with
| Linear [([], re)], Linear [([], im)] ->
if QC.is_real re && QC.is_real im then
- Linear [([], QC.make (QC.real re) (QC.real im))]
+ Linear [([], QC.make (QC.re re) (QC.re im))]
else
invalid_arg ("UFOx.Tensor.of_expr: argument of complex is complex")
| _ ->
invalid_arg "UFOx.Tensor.of_expr: unexpected argument of complex"
end
| S.Application (name, args) ->
Linear [(A.of_expr name args, QC.unit)]
| S.Sum (e1, e2) -> add (of_expr e1) (of_expr e2)
| S.Difference (e1, e2) ->
add (of_expr e1) (of_expr (S.Product (S.Integer (-1), e2)))
| S.Product (e1, e2) -> multiply (of_expr e1) (of_expr e2)
| S.Quotient (n, d) ->
begin match of_expr n, of_expr d with
| n, Linear [] ->
invalid_arg "UFOx.Tensor.of_expr: zero denominator"
| n, Linear [([], q)] -> map_coeff (fun c -> QC.div c q) n
| n, Linear ([(invertibles, q)] as d) ->
if List.for_all A.invertible invertibles then
let inverses = List.map A.invert invertibles in
multiply (Linear [(inverses, QC.inv q)]) n
else
multiply (Ratios [[([], QC.unit)], d]) n
| n, (Linear d as d')->
if List.for_all (fun (t, _) -> List.for_all A.scalar t) d then
multiply (Ratios [[([], QC.unit)], d]) n
else
invalid_arg ("UFOx.Tensor.of_expr: non scalar denominator: " ^
to_string d')
| n, (Ratios _ as d) ->
invalid_arg ("UFOx.Tensor.of_expr: illegal denominator: " ^
to_string d)
end
| S.Power (e, p) ->
begin match of_expr e, of_expr p with
| Linear [([], q)], Linear [([], p)] ->
if QC.is_real p then
- let re_p = QC.real p in
+ let re_p = QC.re p in
if Q.is_integer re_p then
Linear [([], QC.pow q (Q.to_integer re_p))]
else
invalid_arg "UFOx.Tensor.of_expr: rational power of number"
else
invalid_arg "UFOx.Tensor.of_expr: complex power of number"
| Linear [([], q)], _ ->
invalid_arg "UFOx.Tensor.of_expr: non-numeric power of number"
| t, Linear [([], p)] ->
if QC.is_integer p then
- power (Q.to_integer (QC.real p)) t
+ power (Q.to_integer (QC.re p)) t
else
invalid_arg "UFOx.Tensor.of_expr: non integer power of tensor"
| _ -> invalid_arg "UFOx.Tensor.of_expr: non numeric power of tensor"
end
type r = A.r
let rep_to_string = A.rep_to_string
let rep_to_string_whizard = A.rep_to_string_whizard
let rep_of_int = A.rep_of_int
+ let rep_of_int_or_young_tableau = A.rep_of_int_or_young_tableau
let rep_conjugate = A.rep_conjugate
let rep_trivial = A.rep_trivial
let numerators = function
| Linear tensors -> tensors
| Ratios ratios -> ThoList.flatmap fst ratios
let classify_indices' filter tensors =
ThoList.uniq
(List.sort compare
(List.map
(fun (t, c) -> filter (A.classify_indices t))
(numerators tensors)))
(* NB: the number of summation indices is not guarateed to be
the same! Therefore it was foolish to try to check for
uniqueness \ldots *)
let classify_indices tensors =
match classify_indices' Index.free tensors with
| [] ->
(* There's always at least an empty list! *)
failwith "UFOx.Tensor.classify_indices: can't happen!"
| [f] -> f
| _ ->
invalid_arg "UFOx.Tensor.classify_indices: incompatible free indices!"
let disambiguate_indices1 (atoms, q) =
(A.disambiguate_indices atoms, q)
let disambiguate_indices tensors =
map_ratios (List.map disambiguate_indices1) tensors
let check_indices t =
ignore (classify_indices t)
let of_expr e =
let t = disambiguate_indices (of_expr e) in
check_indices t;
t
let of_string s =
of_expr (Expr.of_string s)
let of_strings s =
of_expr (Expr.of_strings s)
type r_omega = A.r_omega
let omega = A.omega
end
module type Lorentz_Atom =
sig
type dirac = private
| C of int * int
| Gamma of int * int * int
| Gamma5 of int * int
| Identity of int * int
| ProjP of int * int
| ProjM of int * int
| Sigma of int * int * int * int
type vector = (* private *)
| Epsilon of int * int * int * int
| Metric of int * int
| P of int * int
type scalar = (* private *)
| Mass of int
| Width of int
| P2 of int
| P12 of int * int
| Variable of string
| Coeff of Value.t
type t = (* private *)
| Dirac of dirac
| Vector of vector
| Scalar of scalar
| Inverse of scalar
val map_indices_scalar : (int -> int) -> scalar -> scalar
val map_indices_vector : (int -> int) -> vector -> vector
val rename_indices_vector : (int -> int) -> vector -> vector
end
module Lorentz_Atom =
struct
type dirac =
| C of int * int
| Gamma of int * int * int
| Gamma5 of int * int
| Identity of int * int
| ProjP of int * int
| ProjM of int * int
| Sigma of int * int * int * int
type vector =
| Epsilon of int * int * int * int
| Metric of int * int
| P of int * int
type scalar =
| Mass of int
| Width of int
| P2 of int
| P12 of int * int
| Variable of string
| Coeff of Value.t
type t =
| Dirac of dirac
| Vector of vector
| Scalar of scalar
| Inverse of scalar
let map_indices_scalar f = function
| Mass i -> Mass (f i)
| Width i -> Width (f i)
| P2 i -> P2 (f i)
| P12 (i, j) -> P12 (f i, f j)
| (Variable _ | Coeff _ as s) -> s
let map_indices_vector f = function
| Epsilon (mu, nu, ka, la) -> Epsilon (f mu, f nu, f ka, f la)
| Metric (mu, nu) -> Metric (f mu, f nu)
| P (mu, n) -> P (f mu, f n)
let rename_indices_vector f = function
| Epsilon (mu, nu, ka, la) -> Epsilon (f mu, f nu, f ka, f la)
| Metric (mu, nu) -> Metric (f mu, f nu)
| P (mu, n) -> P (f mu, n)
end
module Lorentz_Atom' : Atom
with type t = Lorentz_Atom.t and type r_omega = Coupling.lorentz =
struct
type t = Lorentz_Atom.t
open Lorentz_Atom
let map_indices_dirac f = function
| C (i, j) -> C (f i, f j)
| Gamma (mu, i, j) -> Gamma (f mu, f i, f j)
| Gamma5 (i, j) -> Gamma5 (f i, f j)
| Identity (i, j) -> Identity (f i, f j)
| ProjP (i, j) -> ProjP (f i, f j)
| ProjM (i, j) -> ProjM (f i, f j)
| Sigma (mu, nu, i, j) -> Sigma (f mu, f nu, f i, f j)
let rename_indices_dirac = map_indices_dirac
let map_indices_scalar f = function
| Mass i -> Mass (f i)
| Width i -> Width (f i)
| P2 i -> P2 (f i)
| P12 (i, j) -> P12 (f i, f j)
| Variable s -> Variable s
| Coeff c -> Coeff c
let map_indices f = function
| Dirac d -> Dirac (map_indices_dirac f d)
| Vector v -> Vector (map_indices_vector f v)
| Scalar s -> Scalar (map_indices_scalar f s)
| Inverse s -> Inverse (map_indices_scalar f s)
let rename_indices2 fd fv = function
| Dirac d -> Dirac (rename_indices_dirac fd d)
| Vector v -> Vector (rename_indices_vector fv v)
| Scalar s -> Scalar s
| Inverse s -> Inverse s
let rename_indices f atom =
rename_indices2 f f atom
let contract_pair a1 a2 =
match a1, a2 with
| Vector (P (mu1, i1)), Vector (P (mu2, i2)) ->
if mu1 <= 0 && mu1 = mu2 then
if i1 = i2 then
Some (Scalar (P2 i1))
else
Some (Scalar (P12 (i1, i2)))
else
None
| Scalar s, Inverse s' | Inverse s, Scalar s' ->
if s = s' then
Some (Scalar (Coeff (Value.Integer 1)))
else
None
| _ -> None
let variable = function
| Scalar (Variable s) | Inverse (Variable s) -> Some s
| _ -> None
let scalar = function
| Dirac _ | Vector _ -> false
| Scalar _ | Inverse _ -> true
let is_unit = function
| Scalar (Coeff c) | Inverse (Coeff c) ->
begin match c with
| Value.Integer 1 -> true
| Value.Rational q -> Algebra.Q.is_unit q
| _ -> false
end
| _ -> false
let invertible = scalar
let invert = function
| Dirac _ -> invalid_arg "UFOx.Lorentz_Atom.invert Dirac"
| Vector _ -> invalid_arg "UFOx.Lorentz_Atom.invert Vector"
| Scalar s -> Inverse s
| Inverse s -> Scalar s
let i2s = Index.to_string
let dirac_to_string = function
| C (i, j) ->
Printf.sprintf "C(%s,%s)" (i2s i) (i2s j)
| Gamma (mu, i, j) ->
Printf.sprintf "Gamma(%s,%s,%s)" (i2s mu) (i2s i) (i2s j)
| Gamma5 (i, j) ->
Printf.sprintf "Gamma5(%s,%s)" (i2s i) (i2s j)
| Identity (i, j) ->
Printf.sprintf "Identity(%s,%s)" (i2s i) (i2s j)
| ProjP (i, j) ->
Printf.sprintf "ProjP(%s,%s)" (i2s i) (i2s j)
| ProjM (i, j) ->
Printf.sprintf "ProjM(%s,%s)" (i2s i) (i2s j)
| Sigma (mu, nu, i, j) ->
Printf.sprintf "Sigma(%s,%s,%s,%s)" (i2s mu) (i2s nu) (i2s i) (i2s j)
let vector_to_string = function
| Epsilon (mu, nu, ka, la) ->
Printf.sprintf "Epsilon(%s,%s,%s,%s)" (i2s mu) (i2s nu) (i2s ka) (i2s la)
| Metric (mu, nu) ->
Printf.sprintf "Metric(%s,%s)" (i2s mu) (i2s nu)
| P (mu, n) ->
Printf.sprintf "P(%s,%d)" (i2s mu) n
let scalar_to_string = function
| Mass id -> Printf.sprintf "Mass(%d)" id
| Width id -> Printf.sprintf "Width(%d)" id
| P2 id -> Printf.sprintf "P(%d)**2" id
| P12 (id1, id2) -> Printf.sprintf "P(%d)*P(%d)" id1 id2
| Variable s -> s
| Coeff c -> Value.to_string c
let to_string = function
| Dirac d -> dirac_to_string d
| Vector v -> vector_to_string v
| Scalar s -> scalar_to_string s
| Inverse s -> "1/" ^ scalar_to_string s
module S = UFOx_syntax
(* \begin{dubious}
Here we handle some special cases in order to be able to
parse propagators. This needs to be made more general,
but unfortunately the syntax for the propagator extension
is not well documented and appears to be a bit chaotic!
\end{dubious} *)
let quoted_index s =
Index.named_summation s ()
let integer_or_id = function
| S.Integer n -> n
| S.Variable "id" -> 1
| _ -> failwith "UFOx.Lorentz_Atom.integer_or_id: impossible"
let vector_index = function
| S.Integer n -> n
| S.Quoted mu -> quoted_index mu
| S.Variable id ->
let l = String.length id in
if l > 1 then
if id.[0] = 'l' then
int_of_string (String.sub id 1 (pred l))
else
invalid_arg ("UFOx.Lorentz_Atom.vector_index: " ^ id)
else
invalid_arg "UFOx.Lorentz_Atom.vector_index: empty variable"
| _ -> invalid_arg "UFOx.Lorentz_Atom.vector_index"
let spinor_index = function
| S.Integer n -> n
| S.Variable id ->
let l = String.length id in
if l > 1 then
if id.[0] = 's' then
int_of_string (String.sub id 1 (pred l))
else
invalid_arg ("UFOx.Lorentz_Atom.spinor_index: " ^ id)
else
invalid_arg "UFOx.Lorentz_Atom.spinor_index: empty variable"
| _ -> invalid_arg "UFOx.Lorentz_Atom.spinor_index"
let of_expr name args =
match name, args with
| "C", [i; j] -> [Dirac (C (spinor_index i, spinor_index j))]
| "C", _ ->
invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to C()"
| "Epsilon", [mu; nu; ka; la] ->
[Vector (Epsilon (vector_index mu, vector_index nu,
vector_index ka, vector_index la))]
| "Epsilon", _ ->
invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Epsilon()"
| "Gamma", [mu; i; j] ->
[Dirac (Gamma (vector_index mu, spinor_index i, spinor_index j))]
| "Gamma", _ ->
invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Gamma()"
| "Gamma5", [i; j] -> [Dirac (Gamma5 (spinor_index i, spinor_index j))]
| "Gamma5", _ ->
invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Gamma5()"
| "Identity", [i; j] -> [Dirac (Identity (spinor_index i, spinor_index j))]
| "Identity", _ ->
invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Identity()"
| "Metric", [mu; nu] -> [Vector (Metric (vector_index mu, vector_index nu))]
| "Metric", _ ->
invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Metric()"
| "P", [mu; id] -> [Vector (P (vector_index mu, integer_or_id id))]
| "P", _ ->
invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to P()"
| "ProjP", [i; j] -> [Dirac (ProjP (spinor_index i, spinor_index j))]
| "ProjP", _ ->
invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to ProjP()"
| "ProjM", [i; j] -> [Dirac (ProjM (spinor_index i, spinor_index j))]
| "ProjM", _ ->
invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to ProjM()"
| "Sigma", [mu; nu; i; j] ->
if mu <> nu then
[Dirac (Sigma (vector_index mu, vector_index nu,
spinor_index i, spinor_index j))]
else
invalid_arg "UFOx.Lorentz.of_expr: implausible arguments to Sigma()"
| "Sigma", _ ->
invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Sigma()"
| "PSlash", [i; j; id] ->
let mu = Index.fresh_summation () in
[Dirac (Gamma (mu, spinor_index i, spinor_index j));
Vector (P (mu, integer_or_id id))]
| "PSlash", _ ->
invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to PSlash()"
| "Mass", [id] -> [Scalar (Mass (integer_or_id id))]
| "Mass", _ ->
invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Mass()"
| "Width", [id] -> [Scalar (Width (integer_or_id id))]
| "Width", _ ->
invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Width()"
| name, [] ->
[Scalar (Variable name)]
| name, _ ->
invalid_arg ("UFOx.Lorentz.of_expr: invalid tensor '" ^ name ^ "'")
type r = S | V | T | Sp | CSp | Maj | VSp | CVSp | VMaj | Ghost
let rep_trivial = function
| S | Ghost -> true
| V | T | Sp | CSp | Maj | VSp | CVSp | VMaj -> false
let rep_to_string = function
| S -> "0"
| V -> "1"
| T -> "2"
| Sp -> "1/2"
| CSp-> "1/2bar"
| Maj -> "1/2M"
| VSp -> "3/2"
| CVSp -> "3/2bar"
| VMaj -> "3/2M"
| Ghost -> "Ghost"
let rep_to_string_whizard = function
| S -> "0"
| V -> "1"
| T -> "2"
| Sp | CSp | Maj -> "1/2"
| VSp | CVSp | VMaj -> "3/2"
| Ghost -> "Ghost"
let rep_of_int neutral = function
| -1 -> Ghost
| 1 -> S
| 2 -> if neutral then Maj else Sp
| -2 -> if neutral then Maj else CSp (* used by [UFO.Particle.force_conjspinor] *)
| 3 -> V
| 4 -> if neutral then VMaj else VSp
| -4 -> if neutral then VMaj else CVSp (* used by [UFO.Particle.force_conjspinor] *)
| 5 -> T
| s when s > 0 ->
failwith "UFOx.Lorentz: spin > 2 not supported!"
| _ ->
invalid_arg "UFOx.Lorentz: invalid non-positive spin value"
+ let rep_of_int_or_young_tableau neutral i yt =
+ match i, yt with
+ | Some i, None -> rep_of_int neutral i
+ | None, None -> S
+ | _, Some _ -> invalid_arg "UFOx.Lorentz: Young tableau not supported"
+
let rep_conjugate = function
| S -> S
| V -> V
| T -> T
| Sp -> CSp (* ??? *)
| CSp -> Sp (* ??? *)
| Maj -> Maj
| VSp -> CVSp
| CVSp -> VSp
| VMaj -> VMaj
| Ghost -> Ghost
let classify_vector_indices1 = function
| Epsilon (mu, nu, ka, la) -> [(mu, V); (nu, V); (ka, V); (la, V)]
| Metric (mu, nu) -> [(mu, V); (nu, V)]
| P (mu, n) -> [(mu, V)]
let classify_dirac_indices1 = function
| C (i, j) -> [(i, CSp); (j, Sp)] (* ??? *)
| Gamma5 (i, j) | Identity (i, j)
| ProjP (i, j) | ProjM (i, j) -> [(i, CSp); (j, Sp)]
| Gamma (mu, i, j) -> [(mu, V); (i, CSp); (j, Sp)]
| Sigma (mu, nu, i, j) -> [(mu, V); (nu, V); (i, CSp); (j, Sp)]
let classify_indices1 = function
| Dirac d -> classify_dirac_indices1 d
| Vector v -> classify_vector_indices1 v
| Scalar _ | Inverse _ -> []
- module IMap = Map.Make (struct type t = int let compare = compare end)
+ module IMap = Map.Make(Int)
exception Incompatible_factors of r * r
let product rep1 rep2 =
match rep1, rep2 with
| V, V -> T
| V, Sp -> VSp
| V, CSp -> CVSp
| V, Maj -> VMaj
| Sp, V -> VSp
| CSp, V -> CVSp
| Maj, V -> VMaj
| _, _ -> raise (Incompatible_factors (rep1, rep2))
let combine_or_add_index (i, rep) map =
let pos, fac = Index.unpack i in
try
let fac', rep' = IMap.find pos map in
if pos < 0 then
IMap.add pos (fac, rep) map
else if fac <> fac' then
IMap.add pos (0, product rep rep') map
else if rep <> rep' then (* Can be disambiguated! *)
IMap.add pos (0, product rep rep') map
else
invalid_arg (Printf.sprintf "UFO: duplicate subindex %d" pos)
with
| Not_found -> IMap.add pos (fac, rep) map
| Incompatible_factors (rep1, rep2) ->
invalid_arg
(Printf.sprintf
"UFO: incompatible factors (%s,%s) at %d"
(rep_to_string rep1) (rep_to_string rep2) pos)
let combine_or_add_indices atom map =
List.fold_right combine_or_add_index (classify_indices1 atom) map
let project_factors (pos, (fac, rep)) =
if fac = 0 then
(pos, rep)
else
invalid_arg (Printf.sprintf "UFO: leftover subindex %d.%d" pos fac)
let classify_indices atoms =
List.map
project_factors
(IMap.bindings (List.fold_right combine_or_add_indices atoms IMap.empty))
let add_factor fac indices pos =
if pos > 0 then
if Sets.Int.mem pos indices then
Index.pack pos fac
else
pos
else
pos
let disambiguate_indices1 indices atom =
rename_indices2 (add_factor 1 indices) (add_factor 2 indices) atom
let vectorspinors atoms =
List.fold_left
(fun acc (i, r) ->
match r with
| S | V | T | Sp | CSp | Maj | Ghost -> acc
| VSp | CVSp | VMaj -> Sets.Int.add i acc)
Sets.Int.empty (classify_indices atoms)
let disambiguate_indices atoms =
let vectorspinor_indices = vectorspinors atoms in
List.map (disambiguate_indices1 vectorspinor_indices) atoms
type r_omega = Coupling.lorentz
let omega = function
| S -> Coupling.Scalar
| V -> Coupling.Vector
| T -> Coupling.Tensor_2
| Sp -> Coupling.Spinor
| CSp -> Coupling.ConjSpinor
| Maj -> Coupling.Majorana
| VSp -> Coupling.Vectorspinor
| CVSp -> Coupling.Vectorspinor (* TODO: not really! *)
| VMaj -> Coupling.Vectorspinor (* TODO: not really! *)
| Ghost -> Coupling.Scalar
end
module Lorentz = Tensor(Lorentz_Atom')
module type Color_Atom =
sig
type t = (* private *)
| Identity of int * int
| Identity8 of int * int
+ | Delta of int Young.tableau * int * int
| T of int * int * int
+ | TY of int Young.tableau * int * int * int
| F of int * int * int
| D of int * int * int
| Epsilon of int * int * int
| EpsilonBar of int * int * int
| T6 of int * int * int
| K6 of int * int * int
| K6Bar of int * int * int
end
module Color_Atom =
struct
type t =
| Identity of int * int
| Identity8 of int * int
+ | Delta of int Young.tableau * int * int
| T of int * int * int
+ | TY of int Young.tableau * int * int * int
| F of int * int * int
| D of int * int * int
| Epsilon of int * int * int
| EpsilonBar of int * int * int
| T6 of int * int * int
| K6 of int * int * int
| K6Bar of int * int * int
end
module Color_Atom' : Atom
with type t = Color_Atom.t and type r_omega = Color.t =
struct
type t = Color_Atom.t
module S = UFOx_syntax
open Color_Atom
let map_indices f = function
| Identity (i, j) -> Identity (f i, f j)
| Identity8 (a, b) -> Identity8 (f a, f b)
+ | Delta (y, a, b) -> Delta (y, f a, f b)
| T (a, i, j) -> T (f a, f i, f j)
+ | TY (y, a, i, j) -> TY (y, f a, f i, f j)
| F (a, i, j) -> F (f a, f i, f j)
| D (a, i, j) -> D (f a, f i, f j)
| Epsilon (i, j, k) -> Epsilon (f i, f j, f k)
| EpsilonBar (i, j, k) -> EpsilonBar (f i, f j, f k)
| T6 (a, i', j') -> T6 (f a, f i', f j')
| K6 (i', j, k) -> K6 (f i', f j, f k)
| K6Bar (i', j, k) -> K6Bar (f i', f j, f k)
let rename_indices = map_indices
let contract_pair _ _ = None
let variable _ = None
let scalar _ = false
let invertible _ = false
let is_unit _ = false
let invert _ =
invalid_arg "UFOx.Color_Atom.invert"
+ let young_tableau_valid_particle y =
+ Young.standard_tableau ~offset:1 y
+
let of_expr1 name args =
match name, args with
| "Identity", [S.Integer i; S.Integer j] -> Identity (i, j)
| "Identity", _ ->
invalid_arg "UFOx.Color.of_expr: invalid arguments to Identity()"
+ | "Delta", [S.Young_Tableau y; S.Integer i; S.Integer j] ->
+ if young_tableau_valid_particle y then
+ Delta (y, i, j)
+ else
+ invalid_arg ("UFOx.Color.of_expr: invalid Young tableau in Delta: " ^
+ Young.tableau_to_string string_of_int y)
+ | "Delta", _ ->
+ invalid_arg "UFOx.Color.of_expr: invalid arguments to Identity()"
| "T", [S.Integer a; S.Integer i; S.Integer j] -> T (a, i, j)
| "T", _ ->
invalid_arg "UFOx.Color.of_expr: invalid arguments to T()"
+ | "TY", [S.Young_Tableau y; S.Integer a; S.Integer i; S.Integer j] ->
+ if young_tableau_valid_particle y then
+ TY (y, a, i, j)
+ else
+ invalid_arg ("UFOx.Color.of_expr: invalid Young tableau in TY: " ^
+ Young.tableau_to_string string_of_int y)
+ | "TY", _ ->
+ invalid_arg "UFOx.Color.of_expr: invalid arguments to TY()"
| "f", [S.Integer a; S.Integer b; S.Integer c] -> F (a, b, c)
| "f", _ ->
invalid_arg "UFOx.Color.of_expr: invalid arguments to f()"
| "d", [S.Integer a; S.Integer b; S.Integer c] -> D (a, b, c)
| "d", _ ->
invalid_arg "UFOx.Color.of_expr: invalid arguments to d()"
| "Epsilon", [S.Integer i; S.Integer j; S.Integer k] ->
Epsilon (i, j, k)
| "Epsilon", _ ->
invalid_arg "UFOx.Color.of_expr: invalid arguments to Epsilon()"
| "EpsilonBar", [S.Integer i; S.Integer j; S.Integer k] ->
EpsilonBar (i, j, k)
| "EpsilonBar", _ ->
invalid_arg "UFOx.Color.of_expr: invalid arguments to EpsilonBar()"
| "T6", [S.Integer a; S.Integer i'; S.Integer j'] -> T6 (a, i', j')
| "T6", _ ->
invalid_arg "UFOx.Color.of_expr: invalid arguments to T6()"
| "K6", [S.Integer i'; S.Integer j; S.Integer k] -> K6 (i', j, k)
| "K6", _ ->
invalid_arg "UFOx.Color.of_expr: invalid arguments to K6()"
| "K6Bar", [S.Integer i'; S.Integer j; S.Integer k] -> K6Bar (i', j, k)
| "K6Bar", _ ->
invalid_arg "UFOx.Color.of_expr: invalid arguments to K6Bar()"
| name, _ ->
invalid_arg ("UFOx.Color.of_expr: invalid tensor '" ^ name ^ "'")
let of_expr name args =
[of_expr1 name args]
let to_string = function
| Identity (i, j) -> Printf.sprintf "Identity(%d,%d)" i j
| Identity8 (a, b) -> Printf.sprintf "Identity8(%d,%d)" a b
+ | Delta (y, a, b) -> Printf.sprintf "Delta(%s,%d,%d)" (Young.tableau_to_string string_of_int y) a b
| T (a, i, j) -> Printf.sprintf "T(%d,%d,%d)" a i j
+ | TY (y, a, i, j) -> Printf.sprintf "TY(%s,%d,%d,%d)" (Young.tableau_to_string string_of_int y) a i j
| F (a, b, c) -> Printf.sprintf "f(%d,%d,%d)" a b c
| D (a, b, c) -> Printf.sprintf "d(%d,%d,%d)" a b c
| Epsilon (i, j, k) -> Printf.sprintf "Epsilon(%d,%d,%d)" i j k
| EpsilonBar (i, j, k) -> Printf.sprintf "EpsilonBar(%d,%d,%d)" i j k
| T6 (a, i', j') -> Printf.sprintf "T6(%d,%d,%d)" a i' j'
| K6 (i', j, k) -> Printf.sprintf "K6(%d,%d,%d)" i' j k
| K6Bar (i', j, k) -> Printf.sprintf "K6Bar(%d,%d,%d)" i' j k
- type r = S | F | C | A
+ type r = S | F | C | A | YT of int Young.tableau
+
+ let conjugate_tableau y =
+ Young.map (~-) y
+
+ let young_tableau_valid_UFO y =
+ young_tableau_valid_particle y ||
+ young_tableau_valid_particle (conjugate_tableau y)
+
+ let young_to_string y =
+ ThoList.to_string (ThoList.to_string string_of_int) y
let rep_trivial = function
- | S -> true
- | F | C | A -> false
+ | S | YT [] | YT [[]] -> true
+ | F | C | A | YT _ -> false
let rep_to_string = function
| S -> "1"
| F -> "3"
| C -> "3bar"
- | A-> "8"
+ | A -> "8"
+ | YT y -> young_to_string y
let rep_to_string_whizard = function
| S -> "1"
| F -> "3"
| C -> "-3"
- | A-> "8"
+ | A -> "8"
+ | YT y -> young_to_string y
let rep_of_int neutral = function
| 1 -> S
| 3 -> F
| -3 -> C
| 8 -> A
- | 6 | -6 -> failwith "UFOx.Color: sextets not supported yet!"
- | 10 | -10 -> failwith "UFOx.Color: decuplets not supported yet!"
+ | 6 -> YT [[1;2]]
+ | -6 -> YT [[-1;-2]]
+ | 10 -> YT [[1;2;3]]
+ | -10 -> YT [[-1;-2;-3]]
| n ->
invalid_arg
(Printf.sprintf
"UFOx.Color: impossible representation color = %d!" n)
-
+
+ let simplify_young_tableau = function
+ | [] | [[]] -> S
+ | [[i]] ->
+ if i < 0 then
+ C
+ else
+ F
+ | y -> YT y
+
+ let rep_of_int_or_young_tableau neutral i = function
+ | None ->
+ begin match i with
+ | Some i -> rep_of_int neutral i
+ | None ->
+ Printf.eprintf "UFO: warning: missing required attribute color!\n";
+ S
+ end
+ | Some y ->
+ if young_tableau_valid_UFO y then
+ begin match i with
+ | None | Some 0 -> YT y
+ | Some i ->
+ let ri = rep_of_int neutral i in
+ if ri = simplify_young_tableau y then
+ ri
+ else
+ invalid_arg
+ (Printf.sprintf
+ "UFOx.Color.rep_of_int_or_young_tableau: color = %d != color_young = %s"
+ i (young_to_string y))
+ end
+ else
+ invalid_arg
+ ("UFOx.Color.rep_of_int_or_young_tableau: not a standard tableau: " ^ young_to_string y)
+
let rep_conjugate = function
| S -> S
| C -> F
| F -> C
| A -> A
+ | YT y -> YT (conjugate_tableau y)
+
+ (* \begin{dubious}
+ Check the particle/anti-particle assignments for
+ the sextets!
+ \end{dubious} *)
let classify_indices1 = function
| Identity (i, j) -> [(i, C); (j, F)]
| Identity8 (a, b) -> [(a, A); (b, A)]
+ | Delta (y, a, b) -> [(a, YT (conjugate_tableau y)); (b, YT y)]
| T (a, i, j) -> [(i, F); (j, C); (a, A)]
+ | TY (y, a, i, j) -> [(i, YT y); (j, YT (conjugate_tableau y)); (a, A)]
| Color_Atom.F (a, b, c) | D (a, b, c) -> [(a, A); (b, A); (c, A)]
| Epsilon (i, j, k) -> [(i, F); (j, F); (k, F)]
| EpsilonBar (i, j, k) -> [(i, C); (j, C); (k, C)]
- | T6 (a, i', j') ->
- failwith "UFOx.Color: sextets not supported yet!"
- | K6 (i', j, k) ->
- failwith "UFOx.Color: sextets not supported yet!"
- | K6Bar (i', j, k) ->
- failwith "UFOx.Color: sextets not supported yet!"
+ | T6 (a, i, j) -> [(a, A); (i, YT [[1;2]]); (j, YT [[-1;-2]])]
+ | K6 (i, j, k) -> [(i, YT [[-1;-2]]); (j, F); (k, F)]
+ | K6Bar (i, j, k) -> [(i, YT [[1;2]]); (j, C); (k, C)]
let classify_indices tensors =
List.sort compare
(List.fold_right
(fun v acc -> classify_indices1 v @ acc)
tensors [])
let disambiguate_indices atoms =
atoms
type r_omega = Color.t
+ (* Our encoding of charge conjugation only works
+ if the indices start from 1. In [SU3], we use
+ tableau with indices that start from 0. *)
+
(* FIXME: $N_C=3$ should not be hardcoded! *)
+
let omega = function
| S -> Color.Singlet
| F -> Color.SUN (3)
| C -> Color.SUN (-3)
| A -> Color.AdjSUN (3)
-
+ | YT [] | YT [[]] -> Color.Singlet
+ | YT ([] :: _ as y) -> failwith ("UFOx.Color.omega: invalid tableau: " ^ young_to_string y)
+ | YT ((i0 :: _) :: _ as y) ->
+ let y = Young.map (fun i -> abs i - 1) y in
+ if i0 < 0 then
+ Color.YTC y
+ else
+ Color.YT y
+
end
module Color = Tensor(Color_Atom')
module type Test =
sig
val suite : OUnit.test
end
module Test : Test =
struct
open OUnit
let parse_unparse s =
Value.to_string (Value.of_expr (Expr.of_string s))
let apup unparsed expr =
assert_equal ~printer:(fun s -> s) unparsed (parse_unparse expr)
let apup_id expr =
apup expr expr
let suite_arithmetic =
"arithmetic" >:::
[ "1 + 2" >:: (fun () -> apup "3" "1+2");
"1 - 2" >:: (fun () -> apup "-1" "1-2");
"3 * 2" >:: (fun () -> apup "6" "3*2");
"3 * (-2)" >:: (fun () -> apup "-6" "3*(-2)");
"3 / 2" >:: (fun () -> apup "(3/2)" "3/2");
"4 / 12" >:: (fun () -> apup "(1/3)" "4/12");
"4 / (-6)" >:: (fun () -> apup "(-2/3)" "4/(-6)");
"3 * (6 / 12)" >:: (fun () -> apup "3*(1/2)" "3*(6/12)");
"(3 * 6) / 12)" >:: (fun () -> apup "(3/2)" "(3*6)/12") ]
let suite_complex =
"complex" >:::
[ "1+I" >:: (fun () -> apup "1+I" "1+complex(0,1)");
"1-I" >:: (fun () -> apup "1-I" "1-complex(0,1)");
"1-I'" >:: (fun () -> apup "1+(-I)" "1+complex(0,-1)");
"1+I'" >:: (fun () -> apup "1-(-I)" "1-complex(0,-1)");
"1+1.+I" >:: (fun () -> apup "1+(1.+I)" "1+complex(1,1)");
"1+1.-I" >:: (fun () -> apup "1+(1.-I)" "1+complex(1,-1)");
"1-1.-I" >:: (fun () -> apup "1-(1.+I)" "1-complex(1,1)");
"1-1.+I" >:: (fun () -> apup "1-(1.-I)" "1-complex(1,-1)");
"2-I" >:: (fun () -> apup "1-(1.+I)" "1-complex(1,1)");
"-I+1" >:: (fun () -> apup "-I+1" "-complex(0,1)+1");
"1.-I+1" >:: (fun () -> apup "(1.-I)+1" "complex(1,-1)+1");
"1/I" >:: (fun () -> apup "1/I" "1/complex(0,1)");
"1/1" >:: (fun () -> apup "1" "1/complex(1,0)");
"1/(-1)" >:: (fun () -> apup "-1" "1/complex(-1,0)");
"1/(-I)" >:: (fun () -> apup "1/(-I)" "1/complex(0,-1)");
"1/(2*I)" >:: (fun () -> apup "1/(2.*I)" "1/complex(0,2)");
"1/(1+I)" >:: (fun () -> apup "1/(1.+I)" "1/complex(1,1)");
"1/(1-I)" >:: (fun () -> apup "1/(1.-I)" "1/complex(1,-1)");
"I/2" >:: (fun () -> apup "I/2" "complex(0,1)/2");
"1/2" >:: (fun () -> apup "(1/2)" "complex(1,0)/2");
"-1/2" >:: (fun () -> apup "(-1/2)" "complex(-1,0)/2");
"-I/2" >:: (fun () -> apup "(-I)/2" "complex(0,-1)/2");
"(2 * I) / 2" >:: (fun () -> apup "(2.*I)/2" "complex(0,2)/2");
"(1 + I) / 2" >:: (fun () -> apup "(1.+I)/2" "complex(1,1)/2");
"(1 - I) / 2" >:: (fun () -> apup "(1.-I)/2" "complex(1,-1)/2") ]
let suite_product =
"product" >:::
[ "(-a) * (-b)" >:: (fun () -> apup "a*b" "(-a)*(-b)");
"a * (-2*b)" >:: (fun () -> apup "-2*a*b" "a*(-2*b)");
"a * (-2/3*b)" >:: (fun () -> apup "a*(-2/3)*b" "a*(-2/3*b)");
"(-2*a) * (-2*b)" >:: (fun () -> apup "4*a*b" "(-2*a)*(-2*b)") ]
let suite_power =
"power" >:::
[ "a^b^c^d" >:: (fun () -> apup "a^(b^(c^d))" "a**b**c**d");
"(a^b)^c^d" >:: (fun () -> apup "(a^b)^(c^d)" "(a**b)**c**d");
"(a^b)^(c^d)" >:: (fun () -> apup "(a^b)^(c^d)" "(a**b)**(c**d)");
"((a^b)^c)^d" >:: (fun () -> apup "((a^b)^c)^d" "((a**b)**c)**d") ]
let suite_apply =
"apply" >:::
[ "sin(x) * cos(x)**2" >:: (fun () -> apup "sin(x)*(cos(x))^2" "cmath.sin(x)*cmath.cos(x)**2");
"sin(x) / cos(x)**2" >:: (fun () -> apup "sin(x)/(cos(x))^2" "cmath.sin(x)/cmath.cos(x)**2");
"(sin(x) / cos(x))**2" >:: (fun () -> apup "(sin(x)/cos(x))^2" "(cmath.sin(x)/cmath.cos(x))**2") ]
let suite_expr =
"unparse/parse" >:::
[ "a + b" >:: (fun () -> apup_id "a+b");
"a - b" >:: (fun () -> apup_id "a-b");
"a + b - c" >:: (fun () -> apup_id "a+b-c");
"a - b - c" >:: (fun () -> apup_id "a-b-c");
"-a + b - c" >:: (fun () -> apup_id "-a+b-c");
"-a - b - c" >:: (fun () -> apup_id "-a-b-c");
"(a - b) / c" >:: (fun () -> apup_id "(a-b)/c");
"(a - b) / (c + d)" >:: (fun () -> apup_id "(a-b)/(c+d)");
"(a + b - c) / d" >:: (fun () -> apup_id "(a+b-c)/d");
"a^b / c" >:: (fun () -> apup "a^b/c" "a**b/c");
"(a * b)^c / d" >:: (fun () -> apup "(a*b)^c/d" "(a*b)**c/d");
"(a * b)^(c/d)" >:: (fun () -> apup "(a*b)^(c/d)" "(a*b)**(c/d)");
"(a / b)^c / d" >:: (fun () -> apup "(a/b)^c/d" "(a/b)**c/d");
"(a + b)^c / d" >:: (fun () -> apup "(a+b)^c/d" "(a+b)**c/d");
"(a - b)^c / d" >:: (fun () -> apup "(a-b)^c/d" "(a-b)**c/d");
"-a^2" >:: (fun () -> apup "-a^2" "-a**2");
"(-a)^2" >:: (fun () -> apup "(-a)^2" "(-a)**2");
"a-b^2" >:: (fun () -> apup "a-b^2" "a-b**2");
"-a^2 + b + c" >:: (fun () -> apup "-a^2+b+c" "-a**2+b+c");
"a - b^2 + c" >:: (fun () -> apup "a-b^2+c" "a-b**2+c") ]
let suite_bugreports =
"bug reports" >:::
[ "S2HDMIV:lam1" >::
(fun () ->
apup
"(Mh1^2*RA1x1^2+Mh2^2*RA2x1^2+Mh3^2*RA3x1^2-musq*SB^2)/(CB^2*vH^2)"
"(Mh1**2*RA1x1**2 + Mh2**2*RA2x1**2 + Mh3**2*RA3x1**2 - musq*SB**2)/(CB**2*vH**2)");
"loop_sm:AxialZUp" >::
(fun () -> apup "(3/2)*(-ee*sw)/(6*cw)-(1/2)*cw*ee/(2*sw)" "(3.0/2.0)*(-(ee*sw)/(6.*cw))-(1.0/2.0)*((cw*ee)/(2.*sw))");
"loop_sm:AxialZUp'" >:: (fun () -> apup "(3/2)*(-ee*sw)/(6*cw)" "(3.0/2.0)*(-(ee*sw)/(6.*cw))");
"loop_sm:AxialZUp''" >:: (fun () -> apup "(3/2)*(-ee)/2" "(3.0/2.0)*(-ee/2)") ]
let suite =
"UFOx" >:::
[suite_arithmetic;
suite_complex;
suite_product;
suite_power;
suite_apply;
suite_expr;
suite_bugreports]
end
Index: trunk/omega/src/UFO_targets.ml
===================================================================
--- trunk/omega/src/UFO_targets.ml (revision 8899)
+++ trunk/omega/src/UFO_targets.ml (revision 8900)
@@ -1,1548 +1,1548 @@
(* UFO_targets.ml --
Copyright (C) 1999-2017 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
(* \thocwmodulesection{Generating Code for UFO Lorentz Structures} *)
(* \begin{dubious}
O'Caml before 4.02 had a module typing bug that forced us to put
these definitions outside of [Lorentz_Fusion]. Since then, they
might have appeared in more places. Investigate, if it is
worthwhile to encapsulate them again.
\end{dubious} *)
module Q = Algebra.Q
module QC = Algebra.QC
module type T =
sig
(* [lorentz formatter name spins v]
writes a representation of the Lorentz structure [v] of
particles with the Lorentz representations [spins] as a
(Fortran) function [name] to [formatter]. *)
val lorentz :
Format_Fortran.formatter -> string ->
Coupling.lorentz array -> UFO_Lorentz.t -> unit
val propagator :
Format_Fortran.formatter -> string -> string -> string list ->
Coupling.lorentz * Coupling.lorentz ->
UFO_Lorentz.t -> UFO_Lorentz.t -> unit
val fusion_name :
string -> Permutation.Default.t -> Coupling.fermion_lines -> string
val fuse :
Algebra.QC.t -> string ->
Coupling.lorentzn -> Coupling.fermion_lines ->
string -> string list -> string list -> Coupling.fusen -> unit
val eps4_g4_g44_decl : Format_Fortran.formatter -> unit -> unit
val eps4_g4_g44_init : Format_Fortran.formatter -> unit -> unit
val inner_product_functions : Format_Fortran.formatter -> unit -> unit
module type Test =
sig
val suite : OUnit.test
end
module Test : Test
end
module Fortran : T =
struct
open Format_Fortran
let pp_divide ?(indent=0) ff () =
fprintf ff "%*s! %s" indent "" (String.make (70 - indent) '-');
pp_newline ff ()
let conjugate = function
| Coupling.Spinor -> Coupling.ConjSpinor
| Coupling.ConjSpinor -> Coupling.Spinor
| r -> r
let spin_mnemonic = function
| Coupling.Scalar -> "phi"
| Coupling.Spinor -> "psi"
| Coupling.ConjSpinor -> "psibar"
| Coupling.Majorana -> "chi"
| Coupling.Maj_Ghost ->
invalid_arg "UFO_targets: Maj_Ghost"
| Coupling.Vector -> "a"
| Coupling.Massive_Vector -> "v"
| Coupling.Vectorspinor -> "grav" (* itino *)
| Coupling.Tensor_1 ->
invalid_arg "UFO_targets: Tensor_1"
| Coupling.Tensor_2 -> "h"
| Coupling.BRS l ->
invalid_arg "UFO_targets: BRS"
let fortran_type = function
| Coupling.Scalar -> "complex(kind=default)"
| Coupling.Spinor -> "type(spinor)"
| Coupling.ConjSpinor -> "type(conjspinor)"
| Coupling.Majorana -> "type(bispinor)"
| Coupling.Maj_Ghost ->
invalid_arg "UFO_targets: Maj_Ghost"
| Coupling.Vector -> "type(vector)"
| Coupling.Massive_Vector -> "type(vector)"
| Coupling.Vectorspinor -> "type(vectorspinor)"
| Coupling.Tensor_1 ->
invalid_arg "UFO_targets: Tensor_1"
| Coupling.Tensor_2 -> "type(tensor)"
| Coupling.BRS l ->
invalid_arg "UFO_targets: BRS"
(* The \texttt{omegalib} separates time from space. Maybe
not a good idea after all. Mend it locally \ldots *)
type wf =
{ pos : int;
spin : Coupling.lorentz;
name : string;
local_array : string option;
momentum : string;
momentum_array : string;
fortran_type : string }
let wf_table spins =
Array.mapi
(fun i s ->
let spin =
if i = 0 then
conjugate s
else
s in
let pos = succ i in
let i = string_of_int pos in
let name = spin_mnemonic s ^ i in
let local_array =
begin match spin with
| Coupling.Vector | Coupling.Massive_Vector -> Some (name ^ "a")
| _ -> None
end in
{ pos;
spin;
name;
local_array;
momentum = "k" ^ i;
momentum_array = "p" ^ i;
fortran_type = fortran_type spin } )
spins
module L = UFO_Lorentz
(* Format rational ([Q.t]) and complex rational ([QC.t])
numbers as fortran values. *)
let format_rational q =
if Q.is_integer q then
string_of_int (Q.to_integer q)
else
let n, d = Q.to_ratio q in
Printf.sprintf "%d.0_default/%d" n d
let format_complex_rational cq =
- let real = QC.real cq
- and imag = QC.imag cq in
+ let real = QC.re cq
+ and imag = QC.im 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
+ let real = QC.re cq
+ and imag = QC.im 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 + 4) name;
for j = 0 to 3 do
if not (QC.is_null gamma.(i).(j)) then
printf
"@ %s%s%%a(%d)"
(format_complex_rational_factor gamma.(i).(j))
ket.name (succ j)
done;
printf "@]";
nl ()
done;
dsv
(* The same as [dirac_ket_to_fortran], but apply the Dirac matrix
[gamma] to [bra] from the right and return [Bra n]. *)
let dirac_bra_to_fortran_decl ff n indices =
let printf fmt = fprintf ff fmt
and nl = pp_newline ff in
let dsv = Bra n in
printf
" @[<2>complex(kind=default)%s ::@ %s@]"
(dirac_dimension dsv indices) (dsv_name dsv);
nl ()
let dirac_bra_to_fortran_eval ff n indices bra gamma =
let printf fmt = fprintf ff fmt
and nl = pp_newline ff in
let dsv = Bra n in
for j = 0 to 3 do
let name = append_indices (dsv_name dsv) (succ j :: indices) in
printf " @[<%d>%s = 0" (String.length name + 4) name;
for i = 0 to 3 do
if not (QC.is_null gamma.(i).(j)) then
printf
"@ %s%s%%a(%d)"
(format_complex_rational_factor gamma.(i).(j))
bra.name (succ i)
done;
printf "@]";
nl ()
done;
dsv
(* More of the same, but evaluating a spinor sandwich and
returning [Braket n]. *)
let dirac_braket_to_fortran_decl ff n indices =
let printf fmt = fprintf ff fmt
and nl = pp_newline ff in
let dsv = Braket n in
printf
" @[<2>complex(kind=default)%s ::@ %s@]"
(dirac_dimension dsv indices) (dsv_name dsv);
nl ()
let dirac_braket_to_fortran_eval ff n indices bra gamma ket =
let printf fmt = fprintf ff fmt
and nl = pp_newline ff in
let dsv = Braket n in
let name = append_indices (dsv_name dsv) indices in
printf " @[<%d>%s = 0" (String.length name + 4) name;
for i = 0 to 3 do
for j = 0 to 3 do
if not (QC.is_null gamma.(i).(j)) then
printf
"@ %s%s%%a(%d)*%s%%a(%d)"
(format_complex_rational_factor gamma.(i).(j))
bra.name (succ i) ket.name (succ j)
done
done;
printf "@]";
nl ();
dsv
(* Choose among the previous functions according to the position
of [bra] and [ket] among the wavefunctions. If any is in the
first position evaluate the spinor expression with the
corresponding spinor removed, otherwise evaluate the
spinir sandwich. *)
let dirac_bra_or_ket_to_fortran_decl ff n indices bra ket =
if bra = 1 then
dirac_ket_to_fortran_decl ff n indices
else if ket = 1 then
dirac_bra_to_fortran_decl ff n indices
else
dirac_braket_to_fortran_decl ff n indices
let dirac_bra_or_ket_to_fortran_eval ff n indices wfs bra gamma ket =
if bra = 1 then
dirac_ket_to_fortran_eval ff n indices gamma wfs.(pred ket)
else if ket = 1 then
dirac_bra_to_fortran_eval ff n indices wfs.(pred bra) gamma
else
dirac_braket_to_fortran_eval
ff n indices wfs.(pred bra) gamma wfs.(pred ket)
(* UFO summation indices are negative integers. Derive a valid Fortran
variable name. *)
let prefix_summation = "mu"
let prefix_polarization = "nu"
let index_spinor = "alpha"
let index_tensor = "nu"
let index_variable mu =
if mu < 0 then
Printf.sprintf "%s%d" prefix_summation (- mu)
else if mu == 0 then
prefix_polarization
else
Printf.sprintf "%s%d" prefix_polarization mu
let format_indices indices =
String.concat "," (List.map index_variable indices)
module IntPM =
Partial.Make (struct type t = int let compare = compare end)
type tensor =
| DS of dsv
| V of string
| T of UFOx.Lorentz_Atom.vector
| S of UFOx.Lorentz_Atom.scalar
| Inv of UFOx.Lorentz_Atom.scalar
(* Transform the Dirac strings if we have Majorana
fermions involved, in order to implement the algorithm
from JRR's thesis. NB:
The following is for reference only, to better understand what JRR
was doing\ldots *)
(* If the vertex is (suppressing the Lorentz indices of~$\phi_2$ and~$\Gamma$)
\begin{equation}
\label{eq:FVF-Vertex}
\bar\psi \Gamma\phi \psi
= \Gamma_{\alpha\beta} \bar\psi_{\alpha} \phi \psi_{\beta}
\end{equation}
(cf.~[Coupling.FBF] in the hardcoded O'Mega models),
then this is the version implemented by [fuse] below. *)
let tho_print_dirac_current f c wf1 wf2 fusion =
match fusion with
| [1; 3] -> printf "%s_ff(%s,%s,%s)" f c wf1 wf2 (* $\Gamma_{\alpha\beta} \bar\psi_{1,\alpha} \psi_{2,\beta}$ *)
| [3; 1] -> printf "%s_ff(%s,%s,%s)" f c wf2 wf1 (* $\Gamma_{\alpha\beta} \bar\psi_{1,\alpha} \psi_{2,\beta}$ *)
| [2; 3] -> printf "f_%sf(%s,%s,%s)" f c wf1 wf2 (* $\Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta}$ *)
| [3; 2] -> printf "f_%sf(%s,%s,%s)" f c wf2 wf1 (* $\Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta}$ *)
| [1; 2] -> printf "f_f%s(%s,%s,%s)" f c wf1 wf2 (* $\Gamma_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2$ *)
| [2; 1] -> printf "f_f%s(%s,%s,%s)" f c wf2 wf1 (* $\Gamma_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2$ *)
| _ -> ()
(* The corresponding UFO [fuse] exchanges the arguments in the case
of two fermions. This is the natural choice for cyclic permutations. *)
let tho_print_FBF_current f c wf1 wf2 fusion =
match fusion with
| [3; 1] -> printf "f%sf_p120(%s,%s,%s)" f c wf1 wf2 (* $\Gamma_{\alpha\beta} \psi_{1,\beta} \bar\psi_{2,\alpha}$ *)
| [1; 3] -> printf "f%sf_p120(%s,%s,%s)" f c wf2 wf1 (* $\Gamma_{\alpha\beta} \psi_{1,\beta} \bar\psi_{2,\alpha}$ *)
| [2; 3] -> printf "f%sf_p012(%s,%s,%s)" f c wf1 wf2 (* $\Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta}$ *)
| [3; 2] -> printf "f%sf_p012(%s,%s,%s)" f c wf2 wf1 (* $\Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta}$ *)
| [1; 2] -> printf "f%sf_p201(%s,%s,%s)" f c wf1 wf2 (* $\Gamma_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2$ *)
| [2; 1] -> printf "f%sf_p201(%s,%s,%s)" f c wf2 wf1 (* $\Gamma_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2$ *)
| _ -> ()
(* This is how JRR implemented
(see subsection~\ref{sec:dirac-matrices-jrr}) the Dirac matrices
that don't change sign under $C\Gamma^T C^{-1} = \Gamma$,
i.\,e.~$\mathbf{1}$, $\gamma_5$ and~$\gamma_5\gamma_\mu$
(see [Targets.Fortran_Majorana_Fermions.print_fermion_current])
\begin{itemize}
\item In the case of two fermions, the second wave
function [wf2] is always put into the second slot,
as described in JRR's thesis.
\label{pg:JRR-Fusions}
\item In the case of a boson and a fermion, there is no
need for both ["f_%sf"] and ["f_f%s"], since the
latter can be obtained by exchanging arguments.
\end{itemize} *)
let jrr_print_majorana_current_S_P_A f c wf1 wf2 fusion =
match fusion with
| [1; 3] -> printf "%s_ff(%s,%s,%s)" f c wf1 wf2 (*
$(C\Gamma)_{\alpha\beta} \bar\psi_{1,\alpha} \psi_{2,\beta} \cong
C\Gamma $ *)
| [3; 1] -> printf "%s_ff(%s,%s,%s)" f c wf1 wf2 (*
$(C\Gamma)_{\alpha\beta} \psi_{1,\alpha} \bar\psi_{2,\beta} \cong
C\Gamma = C\,C\Gamma^T C^{-1} $ *)
| [2; 3] -> printf "f_%sf(%s,%s,%s)" f c wf1 wf2 (*
$\Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong
\Gamma $ *)
| [3; 2] -> printf "f_%sf(%s,%s,%s)" f c wf2 wf1 (*
$\Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong
\Gamma $ *)
| [1; 2] -> printf "f_%sf(%s,%s,%s)" f c wf2 wf1 (*
$\Gamma_{\alpha\beta} \phi_1 \bar\psi_{2,\beta} \cong
\Gamma = C\Gamma^T C^{-1} $ *)
| [2; 1] -> printf "f_%sf(%s,%s,%s)" f c wf1 wf2 (*
$\Gamma_{\alpha\beta} \phi_1 \bar\psi_{2,\beta} \cong
\Gamma = C\Gamma^T C^{-1} $ *)
| _ -> ()
(* This is how JRR implemented the Dirac matrices
that do change sign under $C\Gamma^T C^{-1} = - \Gamma$,
i.\,e.~$\gamma_\mu$ and~$\sigma_{\mu\nu}$
(see [Targets.Fortran_Majorana_Fermions.print_fermion_current_vector]). *)
let jrr_print_majorana_current_V f c wf1 wf2 fusion =
match fusion with
| [1; 3] -> printf "%s_ff( %s,%s,%s)" f c wf1 wf2 (*
$ (C\Gamma)_{\alpha\beta} \bar\psi_{1,\alpha} \psi_{2,\beta} \cong
C\Gamma $ *)
| [3; 1] -> printf "%s_ff(-%s,%s,%s)" f c wf1 wf2 (*
$-(C\Gamma)_{\alpha\beta} \psi_{1,\alpha} \bar\psi_{2,\beta} \cong
-C\Gamma = C\,C\Gamma^T C^{-1} $ *)
| [2; 3] -> printf "f_%sf( %s,%s,%s)" f c wf1 wf2 (*
$ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong
\Gamma $ *)
| [3; 2] -> printf "f_%sf( %s,%s,%s)" f c wf2 wf1 (*
$ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong
\Gamma $ *)
| [1; 2] -> printf "f_%sf(-%s,%s,%s)" f c wf2 wf1 (*
$-\Gamma_{\alpha\beta} \phi_1 \bar\psi_{2,\beta} \cong
-\Gamma = C\Gamma^T C^{-1} $ *)
| [2; 1] -> printf "f_%sf(-%s,%s,%s)" f c wf1 wf2 (*
$-\Gamma_{\alpha\beta} \phi_1 \bar\psi_{2,\beta} \cong
-\Gamma = C\Gamma^T C^{-1} $ *)
| _ -> ()
(* These two can be unified, if the \texttt{\_c} functions
implement~$\Gamma'=C\Gamma^T C^{-1}$, but we \emph{must}
make sure that the multiplication with~$C$ from the left
happens \emph{after} the transformation~$\Gamma\to\Gamma'$. *)
let jrr_print_majorana_current f c wf1 wf2 fusion =
match fusion with
| [1; 3] -> printf "%s_ff (%s,%s,%s)" f c wf1 wf2 (*
$ (C\Gamma)_{\alpha\beta} \bar\psi_{1,\alpha} \psi_{2,\beta} \cong
C\Gamma $ *)
| [3; 1] -> printf "%s_ff_c(%s,%s,%s)" f c wf1 wf2 (*
$(C\Gamma')_{\alpha\beta} \psi_{1,\alpha} \bar\psi_{2,\beta} \cong
C\Gamma' = C\,C\Gamma^T C^{-1} $ *)
| [2; 3] -> printf "f_%sf (%s,%s,%s)" f c wf1 wf2 (*
$ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong
\Gamma $ *)
| [3; 2] -> printf "f_%sf (%s,%s,%s)" f c wf2 wf1 (*
$ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong
\Gamma $ *)
| [1; 2] -> printf "f_%sf_c(%s,%s,%s)" f c wf2 wf1 (*
$\Gamma'_{\alpha\beta} \phi_1 \bar\psi_{2,\beta} \cong
\Gamma' = C\Gamma^T C^{-1} $ *)
| [2; 1] -> printf "f_%sf_c(%s,%s,%s)" f c wf1 wf2 (*
$\Gamma'_{\alpha\beta} \phi_1 \bar\psi_{2,\beta} \cong
\Gamma' = C\Gamma^T C^{-1} $ *)
| _ -> ()
(* Since we may assume~$C^{-1}=-C=C^T$, this can be rewritten
if the \texttt{\_c} functions implement
\begin{equation}
\Gamma^{\prime\,T}
= \left(C\Gamma^T C^{-1}\right)^T
= \left(C^{-1}\right)^T \Gamma C^T
= C \Gamma C^{-1}
\end{equation}
instead. *)
let jrr_print_majorana_current_transposing f c wf1 wf2 fusion =
match fusion with
| [1; 3] -> printf "%s_ff (%s,%s,%s)" f c wf1 wf2 (*
$ (C\Gamma)_{\alpha\beta} \bar\psi_{1,\alpha} \psi_{2,\beta} \cong
C\Gamma $ *)
| [3; 1] -> printf "%s_ff_c(%s,%s,%s)" f c wf2 wf1 (*
$(C\Gamma')^T_{\alpha\beta} \bar\psi_{1,\alpha} \psi_{2,\beta} \cong
(C\Gamma')^T = - C\Gamma $ *)
| [2; 3] -> printf "f_%sf (%s,%s,%s)" f c wf1 wf2 (*
$ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong
\Gamma $ *)
| [3; 2] -> printf "f_%sf (%s,%s,%s)" f c wf2 wf1 (*
$ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong
\Gamma $ *)
| [1; 2] -> printf "f_f%s_c(%s,%s,%s)" f c wf1 wf2 (*
$\Gamma^{\prime\,T}_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2 \cong
\Gamma^{\prime\,T} = C\Gamma C^{-1}$ *)
| [2; 1] -> printf "f_f%s_c(%s,%s,%s)" f c wf2 wf1 (*
$\Gamma^{\prime\,T}_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2 \cong
\Gamma^{\prime\,T} = C\Gamma C^{-1} $ *)
| _ -> ()
(* where we have used
\begin{equation}
(C\Gamma')^T = \Gamma^{\prime,T}C^T
= C\Gamma C^{-1} C^T = C\Gamma C^{-1} (-C) = - C\Gamma\,.
\end{equation} *)
(* This puts the arguments in the same slots as [tho_print_dirac_current]
above and can be implemented by [fuse], iff we inject the proper
transformations in [dennerize] below.
We notice that we do \emph{not} need the conjugated version for
all combinations, but only for the case of two fermions.
In the two cases of one column spinor~$\psi$, only the original
version appears and in the two cases of one row spinor~$\bar\psi$,
only the conjugated version appears. *)
(* Before we continue, we must however generalize from the
assumption~\eqref{eq:FVF-Vertex} that the fields in the
vertex are always ordered as in~[Coupling.FBF]. First,
even in this case the slots of the fermions must be exchanged
to accomodate the cyclic permutations. Therefore we exchange the
arguments of the [[1; 3]] and [[3; 1]] fusions. *)
let jrr_print_majorana_FBF f c wf1 wf2 fusion =
match fusion with (* [fline = (3, 1)] *)
| [3; 1] -> printf "f%sf_p120_c(%s,%s,%s)" f c wf1 wf2 (*
$(C\Gamma')^T_{\alpha\beta}
\psi_{1,\beta} \bar\psi_{2,\alpha} \cong
(C\Gamma')^T = - C\Gamma $ *)
| [1; 3] -> printf "f%sf_p120 (%s,%s,%s)" f c wf2 wf1 (*
$ (C\Gamma)_{\alpha\beta} \psi_{1,\beta} \bar\psi_{2,\alpha} \cong
C\Gamma $ *)
| [2; 3] -> printf "f%sf_p012 (%s,%s,%s)" f c wf1 wf2 (*
$ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong
\Gamma $ *)
| [3; 2] -> printf "f%sf_p012 (%s,%s,%s)" f c wf2 wf1 (*
$ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong
\Gamma $ *)
| [1; 2] -> printf "f%sf_p201 (%s,%s,%s)" f c wf1 wf2 (*
$\Gamma^{\prime\,T}_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2 \cong
\Gamma^{\prime\,T} = C\Gamma C^{-1}$ *)
| [2; 1] -> printf "f%sf_p201 (%s,%s,%s)" f c wf2 wf1 (*
$\Gamma^{\prime\,T}_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2 \cong
\Gamma^{\prime\,T} = C\Gamma C^{-1} $ *)
| _ -> ()
(* The other two permutations: *)
let jrr_print_majorana_FFB f c wf1 wf2 fusion =
match fusion with (* [fline = (1, 2)] *)
| [3; 1] -> printf "ff%s_p120 (%s,%s,%s)" f c wf1 wf2 (*
$ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong
\Gamma $ *)
| [1; 3] -> printf "ff%s_p120 (%s,%s,%s)" f c wf2 wf1 (*
$ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong
\Gamma $ *)
| [2; 3] -> printf "ff%s_p012 (%s,%s,%s)" f c wf1 wf2 (*
$\Gamma^{\prime\,T}_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2 \cong
\Gamma^{\prime\,T} = C\Gamma C^{-1}$ *)
| [3; 2] -> printf "ff%s_p012 (%s,%s,%s)" f c wf2 wf1 (*
$\Gamma^{\prime\,T}_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2 \cong
\Gamma^{\prime\,T} = C\Gamma C^{-1} $ *)
| [1; 2] -> printf "ff%s_p201 (%s,%s,%s)" f c wf1 wf2 (*
$ (C\Gamma)_{\alpha\beta} \psi_{1,\beta} \bar\psi_{2,\alpha} \cong
C\Gamma $ *)
| [2; 1] -> printf "ff%s_p201_c(%s,%s,%s)" f c wf2 wf1 (*
$(C\Gamma')^T_{\alpha\beta}
\psi_{1,\beta} \bar\psi_{2,\alpha} \cong
(C\Gamma')^T = - C\Gamma $ *)
| _ -> ()
let jrr_print_majorana_BFF f c wf1 wf2 fusion =
match fusion with (* [fline = (2, 3)] *)
| [3; 1] -> printf "%sff_p120 (%s,%s,%s)" f c wf1 wf2 (*
$\Gamma^{\prime\,T}_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2 \cong
\Gamma^{\prime\,T} = C\Gamma C^{-1} $ *)
| [1; 3] -> printf "%sff_p120 (%s,%s,%s)" f c wf2 wf1 (*
$\Gamma^{\prime\,T}_{\alpha\beta} \bar\psi_{1,\alpha} \phi_2 \cong
\Gamma^{\prime\,T} = C\Gamma C^{-1}$ *)
| [2; 3] -> printf "%sff_p012 (%s,%s,%s)" f c wf1 wf2 (*
$ (C\Gamma)_{\alpha\beta} \psi_{1,\beta} \bar\psi_{2,\alpha} \cong
C\Gamma $ *)
| [3; 2] -> printf "%sff_p012_c(%s,%s,%s)" f c wf2 wf1 (*
$(C\Gamma')^T_{\alpha\beta} \psi_{1,\beta} \bar\psi_{2,\alpha} \cong
(C\Gamma')^T = - C\Gamma $ *)
| [1; 2] -> printf "%sff_p201 (%s,%s,%s)" f c wf1 wf2 (*
$ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong
\Gamma $ *)
| [2; 1] -> printf "%sff_p201 (%s,%s,%s)" f c wf2 wf1 (*
$ \Gamma_{\alpha\beta} \phi_1 \psi_{2,\beta} \cong
\Gamma $ *)
| _ -> ()
(* In the model, the necessary
information is provided as [Coupling.fermion_lines], encoded as
[(right,left)] in the usual direction of the lines.
E.\,g.~the case of~\eqref{eq:FVF-Vertex} is~[(3,1)].
Equivalent information is available
as~[(ket, bra)] in [UFO_Lorentz.dirac_string]. *)
let is_majorana = function
| Coupling.Majorana | Coupling.Vectorspinor | Coupling.Maj_Ghost -> true
| _ -> false
let is_dirac = function
| Coupling.Spinor | Coupling.ConjSpinor -> true
| _ -> false
let dennerize ~eval wfs atom =
let printf fmt = fprintf eval fmt
and nl = pp_newline eval in
if is_majorana wfs.(pred atom.L.bra).spin ||
is_majorana wfs.(pred atom.L.ket).spin then
if atom.L.bra = 1 then
(* Fusing one or more bosons with a ket like fermion:
$\chi \leftarrow \Gamma\chi$. *)
(* Don't do anything,
as per subsection~\ref{sec:dirac-matrices-jrr}. *)
atom
else if atom.L.ket = 1 then
(* We fuse one or more bosons with a bra like fermion:
$\bar\chi \leftarrow \bar\chi\Gamma$. *)
(* $\Gamma\to C \Gamma C^{-1}$. *)
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 not atom.L.conjugated then
(* We fuse zero or more bosons with a sandwich of fermions.
$\phi \leftarrow \bar\chi\gamma\chi$.*)
(* Multiply by~$C$ from the left,
as per subsection~\ref{sec:dirac-matrices-jrr}. *)
begin
let atom = L.cc_times atom in
printf " ! multiplied by CC for Majorana"; nl ();
printf " ! %s" (L.dirac_string_to_string atom); nl ();
atom
end
else
(* Transposed: multiply by~$-C$ from the left. *)
begin
let atom = L.minus (L.cc_times atom) in
printf " ! multiplied by -CC for Majorana"; nl ();
printf " ! %s" (L.dirac_string_to_string atom); nl ();
atom
end
else
atom
(* Write the [i]th Dirac string [ds] as Fortran code to [eval], including
a shorthand representation as a comment. Return [ds] with
[ds.L.atom] replaced by the dirac string variable,
i,\,e.~[DS dsv] annotated with the internal and external indices.
In addition write the declaration to [decl]. *)
let dirac_string_to_fortran ~decl ~eval i wfs ds =
let printf fmt = fprintf eval fmt
and nl = pp_newline eval in
let bra = ds.L.atom.L.bra
and ket = ds.L.atom.L.ket in
pp_divide ~indent:4 eval ();
printf " ! %s" (L.dirac_string_to_string ds.L.atom); nl ();
let atom = dennerize ~eval wfs ds.L.atom in
begin match ds.L.indices with
| [] ->
let gamma = L.dirac_string_to_matrix (fun _ -> 0) atom in
dirac_bra_or_ket_to_fortran_decl decl i [] bra ket;
let dsv =
dirac_bra_or_ket_to_fortran_eval eval i [] wfs bra gamma ket in
L.map_atom (fun _ -> DS dsv) ds
| indices ->
dirac_bra_or_ket_to_fortran_decl decl i indices bra ket;
let combinations = Product.power (List.length indices) [0; 1; 2; 3] in
let dsv =
List.map
(fun combination ->
let substitution = IntPM.of_lists indices combination in
let substitute = IntPM.apply substitution in
let indices = List.map substitute indices in
let gamma = L.dirac_string_to_matrix substitute atom in
dirac_bra_or_ket_to_fortran_eval eval i indices wfs bra gamma ket)
combinations in
begin match ThoList.uniq (List.sort compare dsv) with
| [dsv] -> L.map_atom (fun _ -> DS dsv) ds
| _ -> failwith "dirac_string_to_fortran: impossible"
end
end
(* Write the Dirac strings in the list [ds_list] as Fortran code to
[eval], including shorthand representations as comments.
Return the list of variables and corresponding indices to
be contracted. *)
let dirac_strings_to_fortran ~decl ~eval wfs last ds_list =
List.fold_left
(fun (i, acc) ds ->
let i = succ i in
(i, dirac_string_to_fortran ~decl ~eval i wfs ds :: acc))
(last, []) ds_list
(* Perform a nested sum of terms, as printed by [print_term]
(which takes the number of spaces to indent as only argument)
of the cartesian product of [indices] running from 0 to 3. *)
let nested_sums ~decl ~eval initial_indent indices print_term =
let rec nested_sums' indent = function
| [] -> print_term indent
| index :: indices ->
let var = index_variable index in
fprintf eval "%*s@[<2>do %s = 0, 3@]" indent "" var;
pp_newline eval ();
nested_sums' (indent + 2) indices; pp_newline eval ();
fprintf eval "%*s@[<2>end do@]" indent "" in
nested_sums' (initial_indent + 2) indices
(* Polarization indices also need to be summed over, but they
appear only once. *)
let indices_of_contractions contractions =
let index_pairs, polarizations =
L.classify_indices
(ThoList.flatmap (fun ds -> ds.L.indices) contractions) in
try
ThoList.pairs index_pairs @ ThoList.uniq (List.sort compare polarizations)
with
| Invalid_argument s ->
invalid_arg
("indices_of_contractions: " ^
ThoList.to_string string_of_int index_pairs)
(*i Printf.eprintf
"indices_of_contractions: %s / %s\n"
(ThoList.to_string string_of_int index_pairs)
(ThoList.to_string string_of_int polarizations);
i*)
let format_dsv dsv indices =
match dsv, indices with
| Braket _, [] -> dsv_name dsv
| Braket _, ilist ->
Printf.sprintf "%s(%s)" (dsv_name dsv) (format_indices indices)
| (Bra _ | Ket _), [] ->
Printf.sprintf "%s(%s)" (dsv_name dsv) index_spinor
| (Bra _ | Ket _), ilist ->
Printf.sprintf
"%s(%s,%s)" (dsv_name dsv) index_spinor (format_indices indices)
let denominator_name = "denom_"
let mass_name = "m_"
let width_name = "w_"
let format_tensor t =
let indices = t.L.indices in
match t.L.atom with
| DS dsv -> format_dsv dsv indices
| V vector -> Printf.sprintf "%s(%s)" vector (format_indices indices)
| T UFOx.Lorentz_Atom.P (mu, n) ->
Printf.sprintf "p%d(%s)" n (index_variable mu)
| T UFOx.Lorentz_Atom.Epsilon (mu1, mu2, mu3, mu4) ->
Printf.sprintf "eps4_(%s)" (format_indices [mu1; mu2; mu3; mu4])
| T UFOx.Lorentz_Atom.Metric (mu1, mu2) ->
if mu1 > 0 && mu2 > 0 then
Printf.sprintf "g44_(%s)" (format_indices [mu1; mu2])
else
failwith "format_tensor: compress_metrics has failed!"
| S (UFOx.Lorentz_Atom.Mass _) -> mass_name
| S (UFOx.Lorentz_Atom.Width _) -> width_name
| S (UFOx.Lorentz_Atom.P2 i) -> Printf.sprintf "g2_(p%d)" i
| S (UFOx.Lorentz_Atom.P12 (i, j)) -> Printf.sprintf "g12_(p%d,p%d)" i j
| Inv (UFOx.Lorentz_Atom.Mass _) -> "1/" ^ mass_name
| Inv (UFOx.Lorentz_Atom.Width _) -> "1/" ^ width_name
| Inv (UFOx.Lorentz_Atom.P2 i) -> Printf.sprintf "1/g2_(p%d)" i
| Inv (UFOx.Lorentz_Atom.P12 (i, j)) ->
Printf.sprintf "1/g12_(p%d,p%d)" i j
| S (UFOx.Lorentz_Atom.Variable s) -> s
| Inv (UFOx.Lorentz_Atom.Variable s) -> "1/" ^ s
| S (UFOx.Lorentz_Atom.Coeff c) -> UFOx.Value.to_string c
| Inv (UFOx.Lorentz_Atom.Coeff c) -> "1/(" ^ UFOx.Value.to_string c ^ ")"
let rec multiply_tensors ~decl ~eval = function
| [] -> fprintf eval "1";
| [t] -> fprintf eval "%s" (format_tensor t)
| t :: tensors ->
fprintf eval "%s@,*" (format_tensor t);
multiply_tensors ~decl ~eval tensors
let pseudo_wfs_for_denominator =
Array.init
2
(fun i ->
let ii = string_of_int i in
{ pos = i;
spin = Coupling.Scalar;
name = denominator_name;
local_array = None;
momentum = "k" ^ ii;
momentum_array = "p" ^ ii;
fortran_type = fortran_type Coupling.Scalar })
let contract_indices ~decl ~eval indent wf_indices wfs (fusion, contractees) =
let printf fmt = fprintf eval fmt
and nl = pp_newline eval in
let sum_var =
begin match wf_indices with
| [] -> wfs.(0).name
| ilist ->
let indices = String.concat "," ilist in
begin match wfs.(0).local_array with
| None ->
let component =
begin match wfs.(0).spin with
| Coupling.Spinor | Coupling.ConjSpinor | Coupling.Majorana -> "a"
| Coupling.Tensor_2 -> "t"
| Coupling.Vector | Coupling.Massive_Vector ->
failwith "contract_indices: expected local_array for vectors"
| _ -> failwith "contract_indices: unexpected spin"
end in
Printf.sprintf "%s%%%s(%s)" wfs.(0).name component indices
| Some a -> Printf.sprintf "%s(%s)" a indices
end
end in
let indices =
List.filter
(fun i -> UFOx.Index.position i <> 1)
(indices_of_contractions contractees) in
nested_sums
~decl ~eval
indent indices
(fun indent ->
printf "%*s@[<2>%s = %s" indent "" sum_var sum_var;
printf "@ %s" (format_complex_rational_factor fusion.L.coeff);
List.iter (fun i -> printf "@,g4_(%s)*" (index_variable i)) indices;
printf "@,(";
multiply_tensors ~decl ~eval contractees;
printf ")";
begin match fusion.L.denominator with
| [] -> ()
| d -> printf " / %s" denominator_name
end;
printf "@]");
printf "@]";
nl ()
let scalar_expression1 ~decl ~eval fusion =
let printf fmt = fprintf eval fmt in
match fusion.L.dirac, fusion.L.vector with
| [], [] ->
let scalars =
List.map (fun t -> { L.atom = S t; L.indices = [] }) fusion.L.scalar
and inverses =
List.map (fun t -> { L.atom = Inv t; L.indices = [] }) fusion.L.inverse in
let contractees = scalars @ inverses in
printf "@ %s" (format_complex_rational_factor fusion.L.coeff);
multiply_tensors ~decl ~eval contractees
| _, [] ->
invalid_arg
"UFO_targets.Fortran.scalar_expression1: unexpected spinor indices"
| [], _ ->
invalid_arg
"UFO_targets.Fortran.scalar_expression1: unexpected vector indices"
| _, _ ->
invalid_arg
"UFO_targets.Fortran.scalar_expression1: unexpected indices"
let scalar_expression ~decl ~eval indent name fusions =
let printf fmt = fprintf eval fmt
and nl = pp_newline eval in
let sum_var = name in
printf "%*s@[<2>%s =" indent "" sum_var;
List.iter (scalar_expression1 ~decl ~eval) fusions;
printf "@]";
nl ()
let local_vector_copies ~decl ~eval wfs =
begin match wfs.(0).local_array with
| None -> ()
| Some a ->
fprintf
decl " @[<2>complex(kind=default),@ dimension(0:3) ::@ %s@]" a;
pp_newline decl ()
end;
let n = Array.length wfs in
for i = 1 to n - 1 do
match wfs.(i).local_array with
| None -> ()
| Some a ->
fprintf
decl " @[<2>complex(kind=default),@ dimension(0:3) ::@ %s@]" a;
pp_newline decl ();
fprintf eval " @[<2>%s(0) = %s%%t@]" a wfs.(i).name;
pp_newline eval ();
fprintf eval " @[<2>%s(1:3) = %s%%x@]" a wfs.(i).name;
pp_newline eval ()
done
let return_vector ff wfs =
let printf fmt = fprintf ff fmt
and nl = pp_newline ff in
match wfs.(0).local_array with
| None -> ()
| Some a ->
pp_divide ~indent:4 ff ();
printf " @[<2>%s%%t = %s(0)@]" wfs.(0).name a; nl ();
printf " @[<2>%s%%x = %s(1:3)@]" wfs.(0).name a; nl ()
let multiply_coupling_and_scalars ff g_opt wfs =
let printf fmt = fprintf ff fmt
and nl = pp_newline ff in
pp_divide ~indent:4 ff ();
let g =
match g_opt with
| None -> ""
| Some g -> g ^ "*" in
let wfs0name =
match wfs.(0).local_array with
| None -> wfs.(0).name
| Some a -> a in
printf " @[<2>%s = %s%s" wfs0name g wfs0name;
for i = 1 to Array.length wfs - 1 do
match wfs.(i).spin with
| Coupling.Scalar -> printf "@,*%s" wfs.(i).name
| _ -> ()
done;
printf "@]"; nl ()
let local_momentum_copies ~decl ~eval wfs =
let n = Array.length wfs in
fprintf
decl " @[<2>real(kind=default),@ dimension(0:3) ::@ %s"
wfs.(0).momentum_array;
for i = 1 to n - 1 do
fprintf decl ",@ %s" wfs.(i).momentum_array;
fprintf
eval " @[<2>%s(0) = %s%%t@]"
wfs.(i).momentum_array wfs.(i).momentum;
pp_newline eval ();
fprintf
eval " @[<2>%s(1:3) = %s%%x@]"
wfs.(i).momentum_array wfs.(i).momentum;
pp_newline eval ()
done;
fprintf eval " @[<2>%s =" wfs.(0).momentum_array;
for i = 1 to n - 1 do
fprintf eval "@ - %s" wfs.(i).momentum_array
done;
fprintf decl "@]";
pp_newline decl ();
fprintf eval "@]";
pp_newline eval ()
let contractees_of_fusion
~decl ~eval wfs (max_dsv, indices_seen, contractees) fusion =
let max_dsv', dirac_strings =
dirac_strings_to_fortran ~decl ~eval wfs max_dsv fusion.L.dirac
and vectors =
List.fold_left
(fun acc wf ->
match wf.spin, wf.local_array with
| Coupling.Tensor_2, None ->
{ L.atom =
V (Printf.sprintf "%s%d%%t" (spin_mnemonic wf.spin) wf.pos);
L.indices = [UFOx.Index.pack wf.pos 1;
UFOx.Index.pack wf.pos 2] } :: acc
| _, None -> acc
| _, Some a -> { L.atom = V a; L.indices = [wf.pos] } :: acc)
[] (List.tl (Array.to_list wfs))
and tensors =
List.map (L.map_atom (fun t -> T t)) fusion.L.vector
and scalars =
List.map (fun t -> { L.atom = S t; L.indices = [] }) fusion.L.scalar
and inverses =
List.map (fun t -> { L.atom = Inv t; L.indices = [] }) fusion.L.inverse in
let contractees' = dirac_strings @ vectors @ tensors @ scalars @ inverses in
let indices_seen' =
Sets.Int.of_list (indices_of_contractions contractees') in
(max_dsv',
Sets.Int.union indices_seen indices_seen',
(fusion, contractees') :: contractees)
let local_name wf =
match wf.local_array with
| Some a -> a
| None ->
match wf.spin with
| Coupling.Spinor | Coupling.ConjSpinor | Coupling.Majorana ->
wf.name ^ "%a"
| Coupling.Scalar -> wf.name
| Coupling.Tensor_2 -> wf.name ^ "%t"
| Coupling.Vector | Coupling.Massive_Vector ->
failwith "UFO_targets.Fortran.local_name: unexpected spin 1"
| _ ->
failwith "UFO_targets.Fortran.local_name: unhandled spin"
let external_wf_loop ~decl ~eval ~indent wfs (fusion, _ as contractees) =
pp_divide ~indent eval ();
fprintf eval "%*s! %s" indent "" (L.to_string [fusion]); pp_newline eval ();
pp_divide ~indent eval ();
begin match fusion.L.denominator with
| [] -> ()
| denominator ->
scalar_expression ~decl ~eval 4 denominator_name denominator
end;
match wfs.(0).spin with
| Coupling.Scalar ->
contract_indices ~decl ~eval 2 [] wfs contractees
| Coupling.Spinor | Coupling.ConjSpinor | Coupling.Majorana ->
let idx = index_spinor in
fprintf eval "%*s@[<2>do %s = 1, 4@]" indent "" idx; pp_newline eval ();
contract_indices ~decl ~eval 4 [idx] wfs contractees;
fprintf eval "%*send do@]" indent ""; pp_newline eval ()
| Coupling.Vector | Coupling.Massive_Vector ->
let idx = index_variable 1 in
fprintf eval "%*s@[<2>do %s = 0, 3@]" indent "" idx; pp_newline eval ();
contract_indices ~decl ~eval 4 [idx] wfs contractees;
fprintf eval "%*send do@]" indent ""; pp_newline eval ()
| Coupling.Tensor_2 ->
let idx1 = index_variable (UFOx.Index.pack 1 1)
and idx2 = index_variable (UFOx.Index.pack 1 2) in
fprintf eval "%*s@[<2>do %s = 0, 3@]" indent "" idx1;
pp_newline eval ();
fprintf eval "%*s@[<2>do %s = 0, 3@]" (indent + 2) "" idx2;
pp_newline eval ();
contract_indices ~decl ~eval 6 [idx1; idx2] wfs contractees;
fprintf eval "%*send do@]" (indent + 2) ""; pp_newline eval ();
fprintf eval "%*send do@]" indent ""; pp_newline eval ()
| Coupling.Vectorspinor ->
failwith "external_wf_loop: Vectorspinor not supported yet!"
| Coupling.Maj_Ghost ->
failwith "external_wf_loop: unexpected Maj_Ghost"
| Coupling.Tensor_1 ->
failwith "external_wf_loop: unexpected Tensor_1"
| Coupling.BRS _ ->
failwith "external_wf_loop: unexpected BRS"
let fusions_to_fortran ~decl ~eval wfs ?(denominator=[]) ?coupling fusions =
local_vector_copies ~decl ~eval wfs;
local_momentum_copies ~decl ~eval wfs;
begin match denominator with
| [] -> ()
| _ ->
fprintf decl " @[<2>complex(kind=default) :: %s@]" denominator_name;
pp_newline decl ()
end;
let max_dsv, indices_used, contractions =
List.fold_left
(contractees_of_fusion ~decl ~eval wfs)
(0, Sets.Int.empty, [])
fusions in
Sets.Int.iter
(fun index ->
fprintf decl " @[<2>integer ::@ %s@]" (index_variable index);
pp_newline decl ())
indices_used;
begin match wfs.(0).spin with
| Coupling.Spinor | Coupling.ConjSpinor | Coupling.Majorana ->
fprintf decl " @[<2>integer ::@ %s@]" index_spinor;
pp_newline decl ()
| _ -> ()
end;
pp_divide ~indent:4 eval ();
let wfs0name = local_name wfs.(0) in
fprintf eval " %s = 0" wfs0name;
pp_newline eval ();
List.iter (external_wf_loop ~decl ~eval ~indent:4 wfs) contractions;
multiply_coupling_and_scalars eval coupling wfs;
begin match denominator with
| [] -> ()
| denominator ->
pp_divide ~indent:4 eval ();
fprintf eval "%*s! %s" 4 "" (L.to_string denominator);
pp_newline eval ();
scalar_expression ~decl ~eval 4 denominator_name denominator;
fprintf eval
" @[<2>%s =@ %s / %s@]" wfs0name wfs0name denominator_name;
pp_newline eval ()
end;
return_vector eval wfs
(* TODO: eventually, we should include the momentum among
the arguments only if required. But this can wait for
another day. *)
let lorentz ff name spins lorentz =
let printf fmt = fprintf ff fmt
and nl = pp_newline ff in
let wfs = wf_table spins in
let n = Array.length wfs in
printf " @[<4>pure function %s@ (g,@ " name;
for i = 1 to n - 2 do
printf "%s,@ %s,@ " wfs.(i).name wfs.(i).momentum
done;
printf "%s,@ %s" wfs.(n - 1).name wfs.(n - 1).momentum;
printf ")@ result (%s)@]" wfs.(0).name; nl ();
printf " @[<2>%s ::@ %s@]" wfs.(0).fortran_type wfs.(0).name; nl();
printf " @[<2>complex(kind=default),@ intent(in) ::@ g@]"; nl();
for i = 1 to n - 1 do
printf
" @[<2>%s, intent(in) :: %s@]"
wfs.(i).fortran_type wfs.(i).name; nl();
done;
printf " @[<2>type(momentum), intent(in) ::@ %s" wfs.(1).momentum;
for i = 2 to n - 1 do
printf ",@ %s" wfs.(i).momentum
done;
printf "@]";
nl ();
let width = 80 in (* get this from the default formatter instead! *)
let decl_buf = Buffer.create 1024
and eval_buf = Buffer.create 1024 in
let decl = formatter_of_buffer ~width decl_buf
and eval = formatter_of_buffer ~width eval_buf in
fusions_to_fortran ~decl ~eval ~coupling:"g" wfs lorentz;
pp_flush decl ();
pp_flush eval ();
pp_divide ~indent:4 ff ();
(*i printf " ! %s" (L.to_string lorentz); nl ();
pp_divide ~indent:4 ff (); i*)
printf "%s" (Buffer.contents decl_buf);
pp_divide ~indent:4 ff ();
printf " if (g == 0) then"; nl ();
printf " call set_zero (%s)" wfs.(0).name; nl ();
printf " return"; nl ();
printf " end if"; nl ();
pp_divide ~indent:4 ff ();
printf "%s" (Buffer.contents eval_buf);
printf " end function %s@]" name; nl ();
Buffer.reset decl_buf;
Buffer.reset eval_buf;
()
let use_variables ff parameter_module variables =
let printf fmt = fprintf ff fmt
and nl = pp_newline ff in
match variables with
| [] -> ()
| v :: v_list ->
printf " @[<2>use %s, only: %s" parameter_module v;
List.iter (fun s -> printf ", %s" s) v_list;
printf "@]"; nl ()
let propagator ff name parameter_module variables
(bra_spin, ket_spin) numerator denominator =
let printf fmt = fprintf ff fmt
and nl = pp_newline ff in
let width = 80 in (* get this from the default formatter instead! *)
let wf_name = spin_mnemonic ket_spin
and wf_type = fortran_type ket_spin in
let wfs = wf_table [| ket_spin; ket_spin |] in
printf
" @[<4>pure function pr_U_%s@ (k2, %s, %s, %s2)"
name mass_name width_name wf_name;
printf " result (%s1)@]" wf_name; nl ();
use_variables ff parameter_module variables;
printf " %s :: %s1" wf_type wf_name; nl ();
printf " type(momentum), intent(in) :: k2"; nl ();
printf
" real(kind=default), intent(in) :: %s, %s"
mass_name width_name; nl ();
printf " %s, intent(in) :: %s2" wf_type wf_name; nl ();
let decl_buf = Buffer.create 1024
and eval_buf = Buffer.create 1024 in
let decl = formatter_of_buffer ~width decl_buf
and eval = formatter_of_buffer ~width eval_buf in
fusions_to_fortran ~decl ~eval wfs ~denominator numerator;
pp_flush decl ();
pp_flush eval ();
pp_divide ~indent:4 ff ();
printf "%s" (Buffer.contents decl_buf);
pp_divide ~indent:4 ff ();
printf "%s" (Buffer.contents eval_buf);
printf " end function pr_U_%s@]" name; nl ();
Buffer.reset decl_buf;
Buffer.reset eval_buf;
()
let scale_coupling c g =
if c = 1 then
g
else if c = -1 then
"-" ^ g
else
Printf.sprintf "%d*%s" c g
let scale_coupling z g =
format_complex_rational_factor z ^ g
(* As a prototypical example consider the vertex
\begin{subequations}
\label{eq:cyclic-UFO-fusions}
\begin{equation}
\bar\psi\fmslash{A}\psi =
\tr\left(\psi\otimes\bar\psi\fmslash{A}\right)
\end{equation}
encoded as \texttt{FFV} in the SM UFO file. This example
is useful, because all three fields have different type
and we can use the Fortran compiler to check our
implementation.
In this case we need to generate the following function
calls with the arguments in the following order
\begin{center}
\begin{tabular}{lcl}
\texttt{F12}:&$\psi_1\bar\psi_2\to A$&
\texttt{FFV\_p201(g,psi1,p1,psibar2,p2)} \\
\texttt{F21}:&$\bar\psi_1\psi_2\to A$&
\texttt{FFV\_p201(g,psi2,p2,psibar1,p1)} \\
\texttt{F23}:&$\bar\psi_1 A_2 \to \bar\psi$&
\texttt{FFV\_p012(g,psibar1,p1,A2,p2)} \\
\texttt{F32}:&$A_1\bar\psi_2 \to \bar\psi$&
\texttt{FFV\_p012(g,psibar2,p2,A1,p1)} \\
\texttt{F31}:&$A_1\psi_2\to \psi$&
\texttt{FFV\_p120(g,A1,p1,psi2,p2)} \\
\texttt{F13}:&$\psi_1A_2\to \psi$&
\texttt{FFV\_p120(g,A2,p2,psi1,p1)}
\end{tabular}
\end{center} *)
(* Fortunately, all Fermi signs have been taken
care of by [Fusions] and we can concentrate on
injecting the wave functions into the correct slots. *)
(* The other possible cases are
\begin{equation}
\bar\psi\fmslash{A}\psi
\end{equation}
which would be encoded as \texttt{FVF} in a UFO file
\begin{center}
\begin{tabular}{lcl}
\texttt{F12}:&$\bar\psi_1 A_2 \to \bar\psi$&
\texttt{FVF\_p201(g,psibar1,p1,A2,p2)} \\
\texttt{F21}:&$A_1\bar\psi_2 \to \bar\psi$&
\texttt{FVF\_p201(g,psibar2,p2,A1,p1)} \\
\texttt{F23}:&$A_1\psi_2\to \psi$&
\texttt{FVF\_p012(g,A1,p1,psi2,p2)} \\
\texttt{F32}:&$\psi_1A_2\to \psi$&
\texttt{FVF\_p012(g,A2,p2,psi1,p1)} \\
\texttt{F31}:&$\psi_1\bar\psi_2\to A$&
\texttt{FVF\_p120(g,psi1,p1,psibar2,p2)} \\
\texttt{F13}:&$\bar\psi_1\psi_2\to A$&
\texttt{FVF\_p120(g,psi2,p2,psibar1,p1)}
\end{tabular}
\end{center}
and
\begin{equation}
\bar\psi\fmslash{A}\psi =
\tr\left(\fmslash{A}\psi\otimes\bar\psi\right)\,,
\end{equation}
corresponding to \texttt{VFF}
\begin{center}
\begin{tabular}{lcl}
\texttt{F12}:&$A_1\psi_2\to \psi$&
\texttt{VFF\_p201(g,A1,p1,psi2,p2)} \\
\texttt{F21}:&$\psi_1A_2\to \psi$&
\texttt{VFF\_p201(g,A2,p2,psi1,p1)} \\
\texttt{F23}:&$\psi_1\bar\psi_2\to A$&
\texttt{VFF\_p012(g,psi1,p1,psibar2,p2)} \\
\texttt{F32}:&$\bar\psi_1\psi_2\to A$&
\texttt{VFF\_p012(g,psi2,p2,psibar1,p1)} \\
\texttt{F31}:&$\bar\psi_1 A_2 \to \bar\psi$&
\texttt{VFF\_p120(g,psibar1,p1,A2,p2)} \\
\texttt{F13}:&$A_1\bar\psi_2 \to \bar\psi$&
\texttt{VFF\_p120(g,psibar2,p2,A1,p1)}
\end{tabular}
\end{center}
\end{subequations} *)
(* \begin{dubious}
Once the Majorana code generation is fully debugged,
we should replace the lists by reverted lists everywhere
in order to become a bit more efficient.
\end{dubious} *)
module P = Permutation.Default
let factor_cyclic f12__n =
let f12__, fn = ThoList.split_last f12__n in
let cyclic = ThoList.cycle_until fn (List.sort compare f12__n) in
(P.of_list (List.map pred cyclic),
P.of_lists (List.tl cyclic) f12__)
let ccs_to_string ccs =
String.concat "" (List.map (fun (f, i) -> Printf.sprintf "_c%x%x" i f) ccs)
let fusion_name v perm ccs =
Printf.sprintf "%s_p%s%s" v (P.to_string perm) (ccs_to_string ccs)
let fuse_dirac c v s fl g wfs ps fusion =
let g = scale_coupling c g
and cyclic, factor = factor_cyclic fusion in
let wfs_ps = List.map2 (fun wf p -> (wf, p)) wfs ps in
let args = P.list (P.inverse factor) wfs_ps in
printf "@[<2>%s(@,%s" (fusion_name v cyclic []) g;
List.iter (fun (wf, p) -> printf ",@,%s,@,%s" wf p) args;
printf ")@]"
(* 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 with 4-fermion operators involving Majoranas.
\end{dubious} *)
let charge_conjugations fl2 =
ThoList.filtermap
(fun ((i, f), (i', f')) ->
match (i, f), (i', f') with
| (1, 2), _ | (2, 1), _ -> Some (f, i) (* $\chi^T\Gamma'$ *)
| _, (2, 3) -> Some (f, i) (* $\chi^T(C\Gamma')\chi$ *)
| _ -> None)
fl2
(*i
let fuse_majorana c v s fl g wfs ps fusion =
let g = scale_coupling c g
and cyclic, factor = factor_cyclic fusion in
let wfs_ps = List.map2 (fun wf p -> (wf, p)) wfs ps in
let wfs_ps_string =
String.concat "," (List.map (fun (wf, p) -> wf ^ "," ^ p) wfs_ps) in
let args = P.list (P.inverse factor) wfs_ps in
let args_string =
String.concat "," (List.map (fun (wf, p) -> wf ^ "," ^ p) args) in
let f12__, fn = ThoList.split_last fusion in
Printf.eprintf
"fusion : %d < %s\n" fn (ThoList.to_string string_of_int f12__);
Printf.eprintf "cyclic : %s\n" (P.to_string cyclic);
Printf.eprintf "factor : %s\n" (P.to_string factor);
let unit = ThoList.range 1 (List.length fusion) in
Printf.eprintf "permutation : %s -> %s\n"
(ThoList.to_string string_of_int unit)
(ThoList.to_string
string_of_int (List.map (map_indices cyclic unit) unit));
Printf.eprintf "permutation raw : %s -> %s\n"
(ThoList.to_string string_of_int unit)
(ThoList.to_string
string_of_int (List.map (map_indices_raw fusion) unit));
Printf.eprintf "fermion lines : %s\n"
(ThoList.to_string (fun (i, f) -> Printf.sprintf "%d>%d" i f) fl);
let fl2 = permute_fermion_lines2 cyclic factor unit fl in
let fl = permute_fermion_lines cyclic unit fl in
Printf.eprintf "permuted : %s\n"
(ThoList.to_string (fun (i, f) -> Printf.sprintf "%d>%d" i f) fl);
Printf.eprintf "arguments : %s\n" wfs_ps_string;
Printf.eprintf "permuted : %s\n" args_string;
Printf.eprintf
">> %s(%s,%s)\n"
(fusion_name v cyclic (charge_conjugations fl2)) g args_string;
printf "%s(%s,%s)" (fusion_name v cyclic (charge_conjugations fl2)) g args_string
i*)
let charge_conjugations fl2 =
ThoList.filtermap
(fun ((i, f), (i', f')) ->
match (i, f), (i', f') with
| _, (2, 3) -> Some (f, i)
| _ -> None)
fl2
let fuse_majorana c v s fl g wfs ps fusion =
let g = scale_coupling c g
and cyclic, factor = factor_cyclic fusion in
let wfs_ps = List.map2 (fun wf p -> (wf, p)) wfs ps in
let args = P.list (P.inverse factor) wfs_ps in
let unit = ThoList.range 1 (List.length fusion) in
let ccs =
charge_conjugations (permute_fermion_lines2 cyclic factor unit fl) in
printf "@[<2>%s(%s" (fusion_name v cyclic ccs) g;
List.iter (fun (wf, p) -> printf ",@,%s,@,%s" wf p) args;
printf ")@]"
let fuse c v s fl g wfs ps fusion =
if List.exists is_majorana s then
fuse_majorana c v s fl g wfs ps fusion
else
fuse_dirac c v s fl g wfs ps fusion
let eps4_g4_g44_decl ff () =
let printf fmt = fprintf ff fmt
and nl = pp_newline ff in
printf " @[<2>integer,@ dimension(0:3)";
printf ",@ save,@ private ::@ g4_@]"; nl ();
printf " @[<2>integer,@ dimension(0:3,0:3)";
printf ",@ save,@ private ::@ g44_@]"; nl ();
printf " @[<2>integer,@ dimension(0:3,0:3,0:3,0:3)";
printf ",@ save,@ private ::@ eps4_@]"; nl ()
let eps4_g4_g44_init ff () =
let printf fmt = fprintf ff fmt
and nl = pp_newline ff in
printf " @[<2>data g4_@ /@ 1, -1, -1, -1 /@]"; nl ();
printf " @[<2>data g44_(0,:)@ /@ 1, 0, 0, 0 /@]"; nl ();
printf " @[<2>data g44_(1,:)@ /@ 0, -1, 0, 0 /@]"; nl ();
printf " @[<2>data g44_(2,:)@ /@ 0, 0, -1, 0 /@]"; nl ();
printf " @[<2>data g44_(3,:)@ /@ 0, 0, 0, -1 /@]"; nl ();
for mu1 = 0 to 3 do
for mu2 = 0 to 3 do
for mu3 = 0 to 3 do
printf " @[<2>data eps4_(%d,%d,%d,:)@ /@ " mu1 mu2 mu3;
for mu4 = 0 to 3 do
if mu4 <> 0 then
printf ",@ ";
let mus = [mu1; mu2; mu3; mu4] in
if List.sort compare mus = [0; 1; 2; 3] then
printf "%2d" (Combinatorics.sign mus)
else
printf "%2d" 0;
done;
printf " /@]";
nl ()
done
done
done
let inner_product_functions ff () =
let printf fmt = fprintf ff fmt
and nl = pp_newline ff in
printf " pure function g2_ (p) result (p2)"; nl();
printf " real(kind=default), dimension(0:3), intent(in) :: p"; nl();
printf " real(kind=default) :: p2"; nl();
printf " p2 = p(0)*p(0) - p(1)*p(1) - p(2)*p(2) - p(3)*p(3)"; nl();
printf " end function g2_"; nl();
printf " pure function g12_ (p1, p2) result (p12)"; nl();
printf " real(kind=default), dimension(0:3), intent(in) :: p1, p2"; nl();
printf " real(kind=default) :: p12"; nl();
printf " p12 = p1(0)*p2(0) - p1(1)*p2(1) - p1(2)*p2(2) - p1(3)*p2(3)"; nl();
printf " end function g12_"; nl()
module type Test =
sig
val suite : OUnit.test
end
module Test : Test =
struct
open OUnit
let assert_mappings fusion =
let unit = ThoList.range 1 (List.length fusion) in
let cyclic, factor = factor_cyclic fusion in
let raw = map_indices_raw fusion
and map1 = map_indices cyclic unit
and map2 = map_indices2 factor unit in
let map i = map2 (map1 i) in
assert_equal ~printer:(ThoList.to_string string_of_int)
(List.map raw unit) (List.map map unit)
let suite_mappings =
"mappings" >:::
[ "1<-2" >::
(fun () ->
List.iter assert_mappings (Combinatorics.permute [1;2;3]));
"1<-3" >::
(fun () ->
List.iter assert_mappings (Combinatorics.permute [1;2;3;4])) ]
let suite =
"UFO_targets" >:::
[suite_mappings]
end
end
Index: trunk/omega/src/modellib_NoH.ml
===================================================================
--- trunk/omega/src/modellib_NoH.ml (revision 8899)
+++ trunk/omega/src/modellib_NoH.ml (revision 8900)
@@ -1,2924 +1,2931 @@
(* modellib_NoH.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
Marco Sekulla <marco.sekulla@kit.edu>
Fabian Bach <fabian.bach@t-online.de> (only parts of this file)
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
(* \thocwmodulesection{Minimal Higgsless Model (Unitarity Gauge)} *)
module type NoH_flags =
sig
val triple_anom : bool
val quartic_anom : bool
val k_matrix : bool
val ckm_present : bool
val top_anom : bool
val top_anom_4f : bool
end
module NoH_k_matrix : NoH_flags =
struct
let triple_anom = false
let quartic_anom = false
let k_matrix = true
let ckm_present = false
let top_anom = false
let top_anom_4f = false
end
(* \thocwmodulesection{Minimal Higgsless Model including unitarization} *)
module NoH (Flags : NoH_flags) =
struct
open Coupling
let default_width = ref Timelike
let use_fudged_width = ref false
let options = Options.create
[ "constant_width", Arg.Unit (fun () -> default_width := Constant),
"use constant width (also in t-channel)";
"fudged_width", Arg.Set use_fudged_width,
"use fudge factor for charge particle width";
"custom_width", Arg.String (fun f -> default_width := Custom f),
"use custom width";
"cancel_widths", Arg.Unit (fun () -> default_width := Vanishing),
"use vanishing width";
"cms_width", Arg.Unit (fun () -> default_width := Complex_Mass),
"use complex mass scheme";
"running_width", Arg.Unit (fun () -> default_width := Running),
"use running width"]
let caveats () = []
type f_aux_top = TTGG | TBWA | TBWZ | TTWW | BBWW | (*i top auxiliary field "flavors" *)
QGUG | QBUB | QW | DL | DR |
QUQD1L | QUQD1R | QUQD8L | QUQD8R
type matter_field = L of int | N of int | U of int | D of int
type gauge_boson = Ga | Wp | Wm | Z | Gl
type other = Phip | Phim | Phi0
| Aux_top of int*int*int*bool*f_aux_top (*i lorentz*color*charge*top-side*flavor *)
type flavor = M of matter_field | G of gauge_boson | O of other
let matter_field f = M f
let gauge_boson f = G f
let other f = O f
type field =
| Matter of matter_field
| Gauge of gauge_boson
| Other of other
let field = function
| M f -> Matter f
| G f -> Gauge f
| O f -> Other f
type gauge = unit
let gauge_symbol () =
failwith "Modellib.NoH.gauge_symbol: internal error"
let family n = List.map matter_field [ L n; N n; U n; D n ]
let rec aux_top_flavors (f,l,co,ch) = List.append
( List.map other [ Aux_top(l,co,ch/2,true,f); Aux_top(l,co,ch/2,false,f) ] )
( if ch > 1 then List.append
( List.map other [ Aux_top(l,co,-ch/2,true,f); Aux_top(l,co,-ch/2,false,f) ] )
( aux_top_flavors (f,l,co,(ch-2)) )
else [] )
let external_flavors () =
[ "1st Generation", ThoList.flatmap family [1; -1];
"2nd Generation", ThoList.flatmap family [2; -2];
"3rd Generation", ThoList.flatmap family [3; -3];
"Gauge Bosons", List.map gauge_boson [Ga; Z; Wp; Wm; Gl];
"Goldstone Bosons", List.map other [Phip; Phim; Phi0] ]
let flavors () = List.append
( ThoList.flatmap snd (external_flavors ()) )
( ThoList.flatmap aux_top_flavors
[ (TTGG,2,1,1); (TBWA,2,0,2); (TBWZ,2,0,2); (TTWW,2,0,1); (BBWW,2,0,1);
(QGUG,1,1,1); (QBUB,1,0,1); (QW,1,0,3); (DL,0,0,3); (DR,0,0,3);
(QUQD1L,0,0,3); (QUQD1R,0,0,3); (QUQD8L,0,1,3); (QUQD8R,0,1,3) ] )
let spinor n =
if n >= 0 then
Spinor
else
ConjSpinor
let lorentz_aux = function
| 2 -> Tensor_1
| 1 -> Vector
| 0 -> Scalar
| _ -> invalid_arg ("NoH.lorentz_aux: wrong value")
let lorentz = function
| M f ->
begin match f with
| L n -> spinor n | N n -> spinor n
| U n -> spinor n | D n -> spinor n
end
| G f ->
begin match f with
| Ga | Gl -> Vector
| Wp | Wm | Z -> Massive_Vector
end
| O f ->
begin match f with
| Aux_top (l,_,_,_,_) -> lorentz_aux l
| _ -> Scalar
end
- let color = function
+ let color = function
| M (U n) -> Color.SUN (if n > 0 then 3 else -3)
| M (D n) -> Color.SUN (if n > 0 then 3 else -3)
| G Gl -> Color.AdjSUN 3
| O (Aux_top (_,co,_,_,_)) -> if co == 0 then Color.Singlet else Color.AdjSUN 3
| _ -> Color.Singlet
let nc () = 3
let prop_spinor n =
if n >= 0 then
Prop_Spinor
else
Prop_ConjSpinor
let prop_aux = function
| 2 -> Aux_Tensor_1
| 1 -> Aux_Vector
| 0 -> Aux_Scalar
| _ -> invalid_arg ("NoH.prop_aux: wrong value")
let propagator = function
| M f ->
begin match f with
| L n -> prop_spinor n | N n -> prop_spinor n
| U n -> prop_spinor n | D n -> prop_spinor n
end
| G f ->
begin match f with
| Ga | Gl -> Prop_Feynman
| Wp | Wm | Z -> Prop_Unitarity
end
| O f ->
begin match f with
| Phip | Phim | Phi0 -> Only_Insertion
| Aux_top (l,_,_,_,_) -> prop_aux l
end
(* Optionally, ask for the fudge factor treatment for the widths of
charged particles. Currently, this only applies to $W^\pm$ and top. *)
let width f =
if !use_fudged_width then
match f with
| G Wp | G Wm | M (U 3) | M (U (-3)) -> Fudged
| _ -> !default_width
else
!default_width
let goldstone = function
| G f ->
begin match f with
| Wp -> Some (O Phip, Coupling.Integer 1)
| Wm -> Some (O Phim, Coupling.Integer 1)
| Z -> Some (O Phi0, Coupling.Integer 1)
| _ -> None
end
| _ -> None
let conjugate = function
| M f ->
M (begin match f with
| L n -> L (-n) | N n -> N (-n)
| U n -> U (-n) | D n -> D (-n)
end)
| G f ->
G (begin match f with
| Gl -> Gl | Ga -> Ga | Z -> Z
| Wp -> Wm | Wm -> Wp
end)
| O f ->
O (begin match f with
| Phip -> Phim | Phim -> Phip | Phi0 -> Phi0
| Aux_top (l,co,ch,n,f) -> Aux_top (l,co,(-ch),(not n),f)
end)
let fermion = function
| M f ->
begin match f with
| L n -> if n > 0 then 1 else -1
| N n -> if n > 0 then 1 else -1
| U n -> if n > 0 then 1 else -1
| D n -> if n > 0 then 1 else -1
end
| G f ->
begin match f with
| Gl | Ga | Z | Wp | Wm -> 0
end
| O _ -> 0
(* Electrical charge, lepton number, baryon number. We could avoid the
rationals altogether by multiplying the first and last by 3 \ldots *)
module Ch = Charges.QQ
let ( // ) = Algebra.Small_Rational.make
let generation' = function
| 1 -> [ 1//1; 0//1; 0//1]
| 2 -> [ 0//1; 1//1; 0//1]
| 3 -> [ 0//1; 0//1; 1//1]
| -1 -> [-1//1; 0//1; 0//1]
| -2 -> [ 0//1; -1//1; 0//1]
| -3 -> [ 0//1; 0//1; -1//1]
| n -> invalid_arg ("NoH.generation': " ^ string_of_int n)
let generation f =
if Flags.ckm_present then
[]
else
match f with
| M (L n | N n | U n | D n) -> generation' n
| G _ | O _ -> [0//1; 0//1; 0//1]
let charge = function
| M f ->
begin match f with
| L n -> if n > 0 then -1//1 else 1//1
| N n -> 0//1
| U n -> if n > 0 then 2//3 else -2//3
| D n -> if n > 0 then -1//3 else 1//3
end
| G f ->
begin match f with
| Gl | Ga | Z -> 0//1
| Wp -> 1//1
| Wm -> -1//1
end
| O f ->
begin match f with
| Phi0 -> 0//1
| Phip -> 1//1
| Phim -> -1//1
| Aux_top (_,_,ch,_,_) -> ch//1
end
let lepton = function
| M f ->
begin match f with
| L n | N n -> if n > 0 then 1//1 else -1//1
| U _ | D _ -> 0//1
end
| G _ | O _ -> 0//1
let baryon = function
| M f ->
begin match f with
| L _ | N _ -> 0//1
| U n | D n -> if n > 0 then 1//1 else -1//1
end
| G _ | O _ -> 0//1
let charges f =
[ charge f; lepton f; baryon f] @ generation f
type constant =
| Unit | Half | Pi | Alpha_QED | Sin2thw
| Sinthw | Costhw | E | G_weak | I_G_weak | Vev
| Q_lepton | Q_up | Q_down | G_CC | G_CCQ of int*int
| G_NC_neutrino | G_NC_lepton | G_NC_up | G_NC_down
| G_TVA_ttA | G_TVA_bbA
| G_VLR_ttZ | G_TVA_ttZ | G_TVA_bbZ
| G_VLR_btW | G_VLR_tbW
| G_TLR_btW | G_TRL_tbW
| G_TLR_btWZ | G_TRL_tbWZ
| G_TLR_btWA | G_TRL_tbWA
| G_TVA_ttWW | G_TVA_bbWW
| G_TVA_ttG | G_TVA_ttGG
| G_VLR_qGuG | G_VLR_qBuB
| G_VLR_qBuB_u | G_VLR_qBuB_d | G_VLR_qBuB_e | G_VL_qBuB_n
| G_VL_qW | G_VL_qW_u | G_VL_qW_d
| G_SL_DttR | G_SR_DttR | G_SL_DttL | G_SLR_DbtR | G_SL_DbtL
| C_quqd1R_bt | C_quqd1R_tb | C_quqd1L_bt | C_quqd1L_tb
| C_quqd8R_bt | C_quqd8R_tb | C_quqd8L_bt | C_quqd8L_tb
| I_Q_W | I_G_ZWW
| G_WWWW | G_ZZWW | G_AZWW | G_AAWW
| I_G1_AWW | I_G1_ZWW
| I_G1_plus_kappa_plus_G4_AWW
| I_G1_plus_kappa_plus_G4_ZWW
| I_G1_plus_kappa_minus_G4_AWW
| I_G1_plus_kappa_minus_G4_ZWW
| I_G1_minus_kappa_plus_G4_AWW
| I_G1_minus_kappa_plus_G4_ZWW
| I_G1_minus_kappa_minus_G4_AWW
| I_G1_minus_kappa_minus_G4_ZWW
| I_lambda_AWW | I_lambda_ZWW
| G5_AWW | G5_ZWW
| I_kappa5_AWW | I_kappa5_ZWW
| I_lambda5_AWW | I_lambda5_ZWW
| Alpha_WWWW0 | Alpha_ZZWW1 | Alpha_WWWW2
| Alpha_ZZWW0 | Alpha_ZZZZ
| D_Alpha_ZZWW0_S | D_Alpha_ZZWW0_T | D_Alpha_ZZWW1_S
| D_Alpha_ZZWW1_T | D_Alpha_ZZWW1_U | D_Alpha_WWWW0_S
| D_Alpha_WWWW0_T | D_Alpha_WWWW0_U | D_Alpha_WWWW2_S
| D_Alpha_WWWW2_T | D_Alpha_ZZZZ_S | D_Alpha_ZZZZ_T
| Gs | I_Gs | G2
| Mass of flavor | Width of flavor
| K_Matrix_Coeff of int | K_Matrix_Pole of int
(* Two integer counters for the QCD and EW order of the couplings. *)
- type orders = int * int
-
- let orders = function
+ type coupling_order = QCD | EW
+ let all_coupling_orders () = [QCD; EW]
+ let coupling_order_to_string = function
+ | QCD -> "QCD"
+ | EW -> "EW"
+ let coupling_orders = function
| Q_lepton | Q_up | Q_down | G_NC_lepton | G_NC_neutrino
| G_NC_up | G_NC_down | G_CC | G_CCQ _
| I_Q_W
| I_G_ZWW | I_G1_AWW | I_G1_ZWW | I_G_weak
| Half | Unit
| I_G1_plus_kappa_plus_G4_AWW
| I_G1_plus_kappa_plus_G4_ZWW
| I_G1_minus_kappa_plus_G4_AWW
| I_G1_minus_kappa_plus_G4_ZWW
| I_G1_plus_kappa_minus_G4_AWW
| I_G1_plus_kappa_minus_G4_ZWW
| I_G1_minus_kappa_minus_G4_AWW
| I_G1_minus_kappa_minus_G4_ZWW | I_kappa5_AWW
| I_kappa5_ZWW | G5_AWW | G5_ZWW
| I_lambda_AWW | I_lambda_ZWW | I_lambda5_AWW
| I_lambda5_ZWW | G_TVA_ttA | G_TVA_bbA
| G_VLR_ttZ | G_TVA_ttZ | G_TVA_bbZ
| G_VLR_btW | G_VLR_tbW | G_TLR_btW | G_TRL_tbW
| G_TLR_btWA | G_TRL_tbWA | G_TLR_btWZ | G_TRL_tbWZ
| G_VLR_qBuB | G_VLR_qBuB_u | G_VLR_qBuB_d
| G_VLR_qBuB_e | G_VL_qBuB_n | G_VL_qW | G_VL_qW_u | G_VL_qW_d
| G_SL_DttR | G_SR_DttR | G_SL_DttL | G_SLR_DbtR | G_SL_DbtL
- | G_TVA_ttWW | G_TVA_bbWW -> (0,1)
+ | G_TVA_ttWW | G_TVA_bbWW -> [(EW, 1)]
| G_WWWW | G_ZZWW | G_AZWW | G_AAWW
| Alpha_WWWW0 | Alpha_WWWW2 | Alpha_ZZWW0
| Alpha_ZZWW1 | Alpha_ZZZZ
| D_Alpha_WWWW0_S | D_Alpha_WWWW0_T | D_Alpha_WWWW0_U
| D_Alpha_WWWW2_S | D_Alpha_WWWW2_T | D_Alpha_ZZWW0_S
| D_Alpha_ZZWW0_T | D_Alpha_ZZWW1_S | D_Alpha_ZZWW1_T
- | D_Alpha_ZZWW1_U | D_Alpha_ZZZZ_S | D_Alpha_ZZZZ_T -> (0,2)
+ | D_Alpha_ZZWW1_U | D_Alpha_ZZZZ_S | D_Alpha_ZZZZ_T -> [(EW, 2)]
| Gs | I_Gs | G_TVA_ttG | G_TVA_ttGG | G_VLR_qGuG
| C_quqd1R_bt | C_quqd1R_tb | C_quqd1L_bt | C_quqd1L_tb
- | C_quqd8R_bt | C_quqd8R_tb | C_quqd8L_bt | C_quqd8L_tb -> (1,0)
- | G2 -> (2,0)
+ | C_quqd8R_bt | C_quqd8R_tb | C_quqd8L_bt | C_quqd8L_tb -> [(QCD, 1)]
+ | G2 -> [(QCD, 2)]
(* These constants are not used, hence initialized to zero. *)
| Sinthw | Sin2thw | Costhw | Pi
| Alpha_QED | G_weak | K_Matrix_Coeff _
- | K_Matrix_Pole _ | Mass _ | Width _ | Vev | E -> (0,0)
+ | K_Matrix_Pole _ | Mass _ | Width _ | Vev | E -> []
(* \begin{dubious}
The current abstract syntax for parameter dependencies is admittedly
tedious. Later, there will be a parser for a convenient concrete syntax
as a part of a concrete syntax for models. But as these examples show,
it should include simple functions.
\end{dubious} *)
(* \begin{subequations}
\begin{align}
\alpha_{\text{QED}} &= \frac{1}{137.0359895} \\
\sin^2\theta_w &= 0.23124
\end{align}
\end{subequations} *)
let input_parameters =
[ Alpha_QED, 1. /. 137.0359895;
Sin2thw, 0.23124;
Mass (G Z), 91.187;
Mass (M (N 1)), 0.0; Mass (M (L 1)), 0.51099907e-3;
Mass (M (N 2)), 0.0; Mass (M (L 2)), 0.105658389;
Mass (M (N 3)), 0.0; Mass (M (L 3)), 1.77705;
Mass (M (U 1)), 5.0e-3; Mass (M (D 1)), 3.0e-3;
Mass (M (U 2)), 1.2; Mass (M (D 2)), 0.1;
Mass (M (U 3)), 174.0; Mass (M (D 3)), 4.2 ]
(* \begin{subequations}
\begin{align}
e &= \sqrt{4\pi\alpha} \\
\sin\theta_w &= \sqrt{\sin^2\theta_w} \\
\cos\theta_w &= \sqrt{1-\sin^2\theta_w} \\
g &= \frac{e}{\sin\theta_w} \\
m_W &= \cos\theta_w m_Z \\
v &= \frac{2m_W}{g} \\
g_{CC} =
-\frac{g}{2\sqrt2} &= -\frac{e}{2\sqrt2\sin\theta_w} \\
Q_{\text{lepton}} =
-q_{\text{lepton}}e &= e \\
Q_{\text{up}} =
-q_{\text{up}}e &= -\frac{2}{3}e \\
Q_{\text{down}} =
-q_{\text{down}}e &= \frac{1}{3}e \\
\ii q_We =
\ii g_{\gamma WW} &= \ii e \\
\ii g_{ZWW} &= \ii g \cos\theta_w \\
\ii g_{WWW} &= \ii g
\end{align}
\end{subequations} *)
let derived_parameters =
[ Real E, Sqrt (Prod [Integer 4; Atom Pi; Atom Alpha_QED]);
Real Sinthw, Sqrt (Atom Sin2thw);
Real Costhw, Sqrt (Diff (Integer 1, Atom Sin2thw));
Real G_weak, Quot (Atom E, Atom Sinthw);
Real (Mass (G Wp)), Prod [Atom Costhw; Atom (Mass (G Z))];
Real Vev, Quot (Prod [Integer 2; Atom (Mass (G Wp))], Atom G_weak);
Real Q_lepton, Atom E;
Real Q_up, Prod [Quot (Integer (-2), Integer 3); Atom E];
Real Q_down, Prod [Quot (Integer 1, Integer 3); Atom E];
Real G_CC, Neg (Quot (Atom G_weak, Prod [Integer 2; Sqrt (Integer 2)]));
Complex I_Q_W, Prod [I; Atom E];
Complex I_G_weak, Prod [I; Atom G_weak];
Complex I_G_ZWW, Prod [I; Atom G_weak; Atom Costhw] ]
(* \begin{equation}
- \frac{g}{2\cos\theta_w}
\end{equation} *)
let g_over_2_costh =
Quot (Neg (Atom G_weak), Prod [Integer 2; Atom Costhw])
(* \begin{subequations}
\begin{align}
- \frac{g}{2\cos\theta_w} g_V
&= - \frac{g}{2\cos\theta_w} (T_3 - 2 q \sin^2\theta_w) \\
- \frac{g}{2\cos\theta_w} g_A
&= - \frac{g}{2\cos\theta_w} T_3
\end{align}
\end{subequations} *)
let nc_coupling c t3 q =
(Real_Array c,
[Prod [g_over_2_costh; Diff (t3, Prod [Integer 2; q; Atom Sin2thw])];
Prod [g_over_2_costh; t3]])
let half = Quot (Integer 1, Integer 2)
let derived_parameter_arrays =
[ nc_coupling G_NC_neutrino half (Integer 0);
nc_coupling G_NC_lepton (Neg half) (Integer (-1));
nc_coupling G_NC_up half (Quot (Integer 2, Integer 3));
nc_coupling G_NC_down (Neg half) (Quot (Integer (-1), Integer 3)) ]
let parameters () =
{ input = input_parameters;
derived = derived_parameters;
derived_arrays = derived_parameter_arrays }
module F = Modeltools.Fusions (struct
type f = flavor
type c = constant
let compare = compare
let conjugate = conjugate
end)
(* \begin{equation}
\mathcal{L}_{\textrm{EM}} =
- e \sum_i q_i \bar\psi_i\fmslash{A}\psi_i
\end{equation} *)
let mgm ((m1, g, m2), fbf, c) = ((M m1, G g, M m2), fbf, c)
let mom ((m1, o, m2), fbf, c) = ((M m1, O o, M m2), fbf, c)
let electromagnetic_currents n =
List.map mgm
[ ((L (-n), Ga, L n), FBF (1, Psibar, V, Psi), Q_lepton);
((U (-n), Ga, U n), FBF (1, Psibar, V, Psi), Q_up);
((D (-n), Ga, D n), FBF (1, Psibar, V, Psi), Q_down) ]
let color_currents n =
List.map mgm
[ ((U (-n), Gl, U n), FBF ((-1), Psibar, V, Psi), Gs);
((D (-n), Gl, D n), FBF ((-1), Psibar, V, Psi), Gs) ]
(* \begin{equation}
\mathcal{L}_{\textrm{NC}} =
- \frac{g}{2\cos\theta_W}
\sum_i \bar\psi_i\fmslash{Z}(g_V^i-g_A^i\gamma_5)\psi_i
\end{equation} *)
let neutral_currents n =
List.map mgm
[ ((L (-n), Z, L n), FBF (1, Psibar, VA, Psi), G_NC_lepton);
((N (-n), Z, N n), FBF (1, Psibar, VA, Psi), G_NC_neutrino);
((U (-n), Z, U n), FBF (1, Psibar, VA, Psi), G_NC_up);
((D (-n), Z, D n), FBF (1, Psibar, VA, Psi), G_NC_down) ]
(* \begin{equation}
\mathcal{L}_{\textrm{CC}} =
- \frac{g}{2\sqrt2} \sum_i \bar\psi_i
(T^+\fmslash{W}^+ + T^-\fmslash{W}^-)(1-\gamma_5)\psi_i
\end{equation} *)
let charged_currents' n =
List.map mgm
[ ((L (-n), Wm, N n), FBF (1, Psibar, VL, Psi), G_CC);
((N (-n), Wp, L n), FBF (1, Psibar, VL, Psi), G_CC) ]
let charged_currents'' n =
List.map mgm
[ ((D (-n), Wm, U n), FBF (1, Psibar, VL, Psi), G_CC);
((U (-n), Wp, D n), FBF (1, Psibar, VL, Psi), G_CC) ]
let charged_currents_triv =
ThoList.flatmap charged_currents' [1;2;3] @
ThoList.flatmap charged_currents'' [1;2;3]
let charged_currents_ckm =
let charged_currents_2 n1 n2 =
List.map mgm
[ ((D (-n1), Wm, U n2), FBF (1, Psibar, VL, Psi), G_CCQ (n2,n1));
((U (-n1), Wp, D n2), FBF (1, Psibar, VL, Psi), G_CCQ (n1,n2)) ] in
ThoList.flatmap charged_currents' [1;2;3] @
List.flatten (Product.list2 charged_currents_2 [1;2;3] [1;2;3])
(* \begin{equation}
\mathcal{L}_{\textrm{TGC}} =
- e \partial_\mu A_\nu W_+^\mu W_-^\nu + \ldots
- e \cot\theta_w \partial_\mu Z_\nu W_+^\mu W_-^\nu + \ldots
\end{equation} *)
let tgc ((g1, g2, g3), t, c) = ((G g1, G g2, G g3), t, c)
let standard_triple_gauge =
List.map tgc
[ ((Ga, Wm, Wp), Gauge_Gauge_Gauge 1, I_Q_W);
((Z, Wm, Wp), Gauge_Gauge_Gauge 1, I_G_ZWW);
((Gl, Gl, Gl), Gauge_Gauge_Gauge 1, I_Gs)]
(* \begin{multline}
\mathcal{L}_{\textrm{TGC}}(g_1,\kappa)
= g_1 \mathcal{L}_T(V,W^+,W^-) \\
+ \frac{\kappa+g_1}{2} \Bigl(\mathcal{L}_T(W^-,V,W^+)
- \mathcal{L}_T(W^+,V,W^-)\Bigr)\\
+ \frac{\kappa-g_1}{2} \Bigl(\mathcal{L}_L(W^-,V,W^+)
- \mathcal{L}_T(W^+,V,W^-)\Bigr)
\end{multline} *)
(* \begin{dubious}
The whole thing in the LEP2 workshop notation:
\begin{multline}
\ii\mathcal{L}_{\textrm{TGC},V} / g_{WWV} = \\
g_1^V V^\mu (W^-_{\mu\nu}W^{+,\nu}-W^+_{\mu\nu}W^{-,\nu})
+ \kappa_V W^+_\mu W^-_\nu V^{\mu\nu}
+ \frac{\lambda_V}{m_W^2} V_{\mu\nu}
W^-_{\rho\mu} W^{+,\hphantom{\nu}\rho}_{\hphantom{+,}\nu} \\
+ \ii g_5^V \epsilon_{\mu\nu\rho\sigma}
\left( (\partial^\rho W^{-,\mu}) W^{+,\nu}
- W^{-,\mu}(\partial^\rho W^{+,\nu}) \right) V^\sigma \\
+ \ii g_4^V W^-_\mu W^+_\nu (\partial^\mu V^\nu + \partial^\nu V^\mu)
- \frac{\tilde\kappa_V}{2} W^-_\mu W^+_\nu \epsilon^{\mu\nu\rho\sigma}
V_{\rho\sigma}
- \frac{\tilde\lambda_V}{2m_W^2}
W^-_{\rho\mu} W^{+,\mu}_{\hphantom{+,\mu}\nu} \epsilon^{\nu\rho\alpha\beta}
V_{\alpha\beta}
\end{multline}
using the conventions of Itzykson and Zuber with $\epsilon^{0123} = +1$.
\end{dubious} *)
(* \begin{dubious}
This is equivalent to the notation of Hagiwara et al.~\cite{HPZH87}, if we
remember that they have opposite signs for~$g_{WWV}$:
\begin{multline}
\mathcal{L}_{WWV} / (-g_{WWV}) = \\
\ii g_1^V \left( W^\dagger_{\mu\nu} W^\mu
- W^\dagger_\mu W^\mu_{\hphantom{\mu}\nu} \right) V^\nu
+ \ii \kappa_V W^\dagger_\mu W_\nu V^{\mu\nu}
+ \ii \frac{\lambda_V}{m_W^2}
W^\dagger_{\lambda\mu} W^\mu_{\hphantom{\mu}\nu} V^{\nu\lambda} \\
- g_4^V W^\dagger_\mu W_\nu
\left(\partial^\mu V^\nu + \partial^\nu V^\mu \right)
+ g_5^V \epsilon^{\mu\nu\lambda\sigma}
\left( W^\dagger_\mu \stackrel{\leftrightarrow}{\partial_\lambda}
W_\nu \right) V_\sigma\\
+ \ii \tilde\kappa_V W^\dagger_\mu W_\nu \tilde{V}^{\mu\nu}
+ \ii\frac{\tilde\lambda_V}{m_W^2}
W^\dagger_{\lambda\mu} W^\mu_{\hphantom{\mu}\nu} \tilde{V}^{\nu\lambda}
\end{multline}
Here $V^\mu$ stands for either the photon or the~$Z$ field, $W^\mu$ is the
$W^-$ field, $W_{\mu\nu} = \partial_\mu W_\nu - \partial_\nu W_\mu$,
$V_{\mu\nu} = \partial_\mu V_\nu - \partial_\nu V_\mu$, and
$\tilde{V}_{\mu\nu} = \frac{1}{2} \epsilon_{\mu\nu\lambda\sigma}
V^{\lambda\sigma}$.
\end{dubious} *)
let anomalous_triple_gauge =
List.map tgc
[ ((Ga, Wm, Wp), Dim4_Vector_Vector_Vector_T (-1),
I_G1_AWW);
((Z, Wm, Wp), Dim4_Vector_Vector_Vector_T (-1),
I_G1_ZWW);
((Wm, Ga, Wp), Dim4_Vector_Vector_Vector_T 1,
I_G1_plus_kappa_minus_G4_AWW);
((Wm, Z, Wp), Dim4_Vector_Vector_Vector_T 1,
I_G1_plus_kappa_minus_G4_ZWW);
((Wp, Ga, Wm), Dim4_Vector_Vector_Vector_T (-1),
I_G1_plus_kappa_plus_G4_AWW);
((Wp, Z, Wm), Dim4_Vector_Vector_Vector_T (-1),
I_G1_plus_kappa_plus_G4_ZWW);
((Wm, Ga, Wp), Dim4_Vector_Vector_Vector_L (-1),
I_G1_minus_kappa_plus_G4_AWW);
((Wm, Z, Wp), Dim4_Vector_Vector_Vector_L (-1),
I_G1_minus_kappa_plus_G4_ZWW);
((Wp, Ga, Wm), Dim4_Vector_Vector_Vector_L 1,
I_G1_minus_kappa_minus_G4_AWW);
((Wp, Z, Wm), Dim4_Vector_Vector_Vector_L 1,
I_G1_minus_kappa_minus_G4_ZWW);
((Ga, Wm, Wp), Dim4_Vector_Vector_Vector_L5 (-1),
I_kappa5_AWW);
((Z, Wm, Wp), Dim4_Vector_Vector_Vector_L5 (-1),
I_kappa5_ZWW);
((Ga, Wm, Wp), Dim4_Vector_Vector_Vector_T5 (-1),
G5_AWW);
((Z, Wm, Wp), Dim4_Vector_Vector_Vector_T5 (-1),
G5_ZWW);
((Ga, Wp, Wm), Dim6_Gauge_Gauge_Gauge (-1),
I_lambda_AWW);
((Z, Wp, Wm), Dim6_Gauge_Gauge_Gauge (-1),
I_lambda_ZWW);
((Ga, Wp, Wm), Dim6_Gauge_Gauge_Gauge_5 (-1),
I_lambda5_AWW);
((Z, Wp, Wm), Dim6_Gauge_Gauge_Gauge_5 (-1),
I_lambda5_ZWW) ]
let triple_gauge =
if Flags.triple_anom then
anomalous_triple_gauge
else
standard_triple_gauge
(* \begin{equation}
\mathcal{L}_{\textrm{QGC}} =
- g^2 W_{+,\mu} W_{-,\nu} W_+^\mu W_-^\nu + \ldots
\end{equation} *)
(* Actually, quartic gauge couplings are a little bit more straightforward
using auxiliary fields. Here we have to impose the antisymmetry manually:
\begin{subequations}
\begin{multline}
(W^{+,\mu}_1 W^{-,\nu}_2 - W^{+,\nu}_1 W^{-,\mu}_2)
(W^+_{3,\mu} W^-_{4,\nu} - W^+_{3,\nu} W^-_{4,\mu}) \\
= 2(W^+_1W^+_3)(W^-_2W^-_4) - 2(W^+_1W^-_4)(W^-_2W^+_3)
\end{multline}
also ($V$ can be $A$ or $Z$)
\begin{multline}
(W^{+,\mu}_1 V^\nu_2 - W^{+,\nu}_1 V^\mu_2)
(W^-_{3,\mu} V_{4,\nu} - W^-_{3,\nu} V_{4,\mu}) \\
= 2(W^+_1W^-_3)(V_2V_4) - 2(W^+_1V_4)(V_2W^-_3)
\end{multline}
\end{subequations} *)
(* \begin{subequations}
\begin{multline}
W^{+,\mu} W^{-,\nu} W^+_\mu W^-_\nu
\end{multline}
\end{subequations} *)
let qgc ((g1, g2, g3, g4), t, c) = ((G g1, G g2, G g3, G g4), t, c)
let gauge4 = Vector4 [(2, C_13_42); (-1, C_12_34); (-1, C_14_23)]
let minus_gauge4 = Vector4 [(-2, C_13_42); (1, C_12_34); (1, C_14_23)]
let standard_quartic_gauge =
List.map qgc
[ (Wm, Wp, Wm, Wp), gauge4, G_WWWW;
(Wm, Z, Wp, Z), minus_gauge4, G_ZZWW;
(Wm, Z, Wp, Ga), minus_gauge4, G_AZWW;
(Wm, Ga, Wp, Ga), minus_gauge4, G_AAWW;
(Gl, Gl, Gl, Gl), gauge4, G2 ]
(* \begin{subequations}
\begin{align}
\mathcal{L}_4
&= \alpha_4 \left( \frac{g^4}{2}\left( (W^+_\mu W^{-,\mu})^2
+ W^+_\mu W^{+,\mu} W^-_\mu W^{-,\mu}
\right)\right.\notag \\
&\qquad\qquad\qquad \left.
+ \frac{g^4}{\cos^2\theta_w} W^+_\mu Z^\mu W^-_\nu Z^\nu
+ \frac{g^4}{4\cos^4\theta_w} (Z_\mu Z^\mu)^2 \right) \\
\mathcal{L}_5
&= \alpha_5 \left( g^4 (W^+_\mu W^{-,\mu})^2
+ \frac{g^4}{\cos^2\theta_w} W^+_\mu W^{-,\mu} Z_\nu Z^\nu
+ \frac{g^4}{4\cos^4\theta_w} (Z_\mu Z^\mu)^2 \right)
\end{align}
\end{subequations}
or
\begin{multline}
\mathcal{L}_4 + \mathcal{L}_5
= (\alpha_4+2\alpha_5) g^4 \frac{1}{2} (W^+_\mu W^{-,\mu})^2 \\
+ 2\alpha_4 g^4 \frac{1}{4} W^+_\mu W^{+,\mu} W^-_\mu W^{-,\mu}
+ \alpha_4 \frac{g^4}{\cos^2\theta_w} W^+_\mu Z^\mu W^-_\nu Z^\nu \\
+ 2\alpha_5 \frac{g^4}{\cos^2\theta_w} \frac{1}{2} W^+_\mu W^{-,\mu} Z_\nu Z^\nu
+ (2\alpha_4 + 2\alpha_5) \frac{g^4}{\cos^4\theta_w} \frac{1}{8} (Z_\mu Z^\mu)^2
\end{multline}
and therefore
\begin{subequations}
\begin{align}
\alpha_{(WW)_0} &= (\alpha_4+2\alpha_5) g^4 \\
\alpha_{(WW)_2} &= 2\alpha_4 g^4 \\
\alpha_{(WZ)_0} &= 2\alpha_5 \frac{g^4}{\cos^2\theta_w} \\
\alpha_{(WZ)_1} &= \alpha_4 \frac{g^4}{\cos^2\theta_w} \\
\alpha_{ZZ} &= (2\alpha_4 + 2\alpha_5) \frac{g^4}{\cos^4\theta_w}
\end{align}
\end{subequations} *)
let anomalous_quartic_gauge =
if Flags.quartic_anom then
List.map qgc
[ ((Wm, Wm, Wp, Wp),
Vector4 [(1, C_13_42); (1, C_14_23)], Alpha_WWWW0);
((Wm, Wm, Wp, Wp),
Vector4 [1, C_12_34], Alpha_WWWW2);
((Wm, Wp, Z, Z),
Vector4 [1, C_12_34], Alpha_ZZWW0);
((Wm, Wp, Z, Z),
Vector4 [(1, C_13_42); (1, C_14_23)], Alpha_ZZWW1);
((Z, Z, Z, Z),
Vector4 [(1, C_12_34); (1, C_13_42); (1, C_14_23)], Alpha_ZZZZ) ]
else
[]
(* In any diagonal channel~$\chi$, the scattering amplitude~$a_\chi(s)$ is
unitary iff\footnote{%
Trivial proof:
\begin{equation}
-1 = \textrm{Im}\left(\frac{1}{a_\chi(s)}\right)
= \frac{\textrm{Im}(a_\chi^*(s))}{ |a_\chi(s)|^2 }
= - \frac{\textrm{Im}(a_\chi(s))}{ |a_\chi(s)|^2 }
\end{equation}
i.\,e.~$\textrm{Im}(a_\chi(s)) = |a_\chi(s)|^2$.}
\begin{equation}
\textrm{Im}\left(\frac{1}{a_\chi(s)}\right) = -1
\end{equation}
For a real perturbative scattering amplitude~$r_\chi(s)$ this can be
enforced easily--and arbitrarily--by
\begin{equation}
\frac{1}{a_\chi(s)} = \frac{1}{r_\chi(s)} - \mathrm{i}
\end{equation}
*)
let k_matrix_quartic_gauge =
if Flags.k_matrix then
List.map qgc
[ ((Wm, Wp, Wm, Wp), Vector4_K_Matrix_jr (0,
[(1, C_12_34)]), D_Alpha_WWWW0_S);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_jr (0,
[(1, C_14_23)]), D_Alpha_WWWW0_T);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_jr (0,
[(1, C_13_42)]), D_Alpha_WWWW0_U);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_jr (0,
[(1, C_12_34)]), D_Alpha_WWWW0_S);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_jr (0,
[(1, C_14_23)]), D_Alpha_WWWW0_T);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_jr (0,
[(1, C_13_42)]), D_Alpha_WWWW0_U);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_jr (0,
[(1, C_12_34)]), D_Alpha_WWWW2_S);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_jr (0,
[(1, C_13_42); (1, C_14_23)]), D_Alpha_WWWW2_T);
((Wm, Wp, Z, Z), Vector4_K_Matrix_jr (0,
[(1, C_12_34)]), D_Alpha_ZZWW0_S);
((Wm, Wp, Z, Z), Vector4_K_Matrix_jr (0,
[(1, C_13_42); (1, C_14_23)]), D_Alpha_ZZWW0_T);
((Wm, Z, Wp, Z), Vector4_K_Matrix_jr (0,
[(1, C_12_34)]), D_Alpha_ZZWW1_S);
((Wm, Z, Wp, Z), Vector4_K_Matrix_jr (0,
[(1, C_13_42)]), D_Alpha_ZZWW1_T);
((Wm, Z, Wp, Z), Vector4_K_Matrix_jr (0,
[(1, C_14_23)]), D_Alpha_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_jr (1,
[(1, C_12_34)]), D_Alpha_ZZWW1_S);
((Wp, Z, Z, Wm), Vector4_K_Matrix_jr (1,
[(1, C_13_42)]), D_Alpha_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_jr (1,
[(1, C_14_23)]), D_Alpha_ZZWW1_T);
((Z, Wp, Wm, Z), Vector4_K_Matrix_jr (2,
[(1, C_12_34)]), D_Alpha_ZZWW1_S);
((Z, Wp, Wm, Z), Vector4_K_Matrix_jr (2,
[(1, C_13_42)]), D_Alpha_ZZWW1_U);
((Z, Wp, Wm, Z), Vector4_K_Matrix_jr (2,
[(1, C_14_23)]), D_Alpha_ZZWW1_T);
((Z, Z, Z, Z), Vector4_K_Matrix_jr (0,
[(1, C_12_34)]), D_Alpha_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_jr (0,
[(1, C_13_42); (1, C_14_23)]), D_Alpha_ZZZZ_T);
((Z, Z, Z, Z), Vector4_K_Matrix_jr (3,
[(1, C_14_23)]), D_Alpha_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_jr (3,
[(1, C_13_42); (1, C_12_34)]), D_Alpha_ZZZZ_T)]
else
[]
(*i Thorsten's original implementation of the K matrix, which we keep since
it still might be usefull for the future.
let k_matrix_quartic_gauge =
if Flags.k_matrix then
List.map qgc
[ ((Wm, Wp, Wm, Wp), Vector4_K_Matrix_tho (0, [K_Matrix_Coeff 0,
K_Matrix_Pole 0]), Alpha_WWWW0);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_tho (0, [K_Matrix_Coeff 2,
K_Matrix_Pole 2]), Alpha_WWWW2);
((Wm, Wp, Z, Z), Vector4_K_Matrix_tho (0, [(K_Matrix_Coeff 0,
K_Matrix_Pole 0); (K_Matrix_Coeff 2,
K_Matrix_Pole 2)]), Alpha_ZZWW0);
((Wm, Z, Wp, Z), Vector4_K_Matrix_tho (0, [K_Matrix_Coeff 1,
K_Matrix_Pole 1]), Alpha_ZZWW1);
((Z, Z, Z, Z), Vector4_K_Matrix_tho (0, [K_Matrix_Coeff 0,
K_Matrix_Pole 0]), Alpha_ZZZZ) ]
else
[]
i*)
let quartic_gauge =
standard_quartic_gauge @ anomalous_quartic_gauge @ k_matrix_quartic_gauge
(* WK's couplings (apparently, he still intends to divide by
$\Lambda^2_{\text{EWSB}}=16\pi^2v_{\mathrm{F}}^2$):
\begin{subequations}
\begin{align}
\mathcal{L}^{\tau}_4 &=
\left\lbrack (\partial_{\mu}H)(\partial^{\mu}H)
+ \frac{g^2v_{\mathrm{F}}^2}{4} V_{\mu} V^{\mu} \right\rbrack^2 \\
\mathcal{L}^{\tau}_5 &=
\left\lbrack (\partial_{\mu}H)(\partial_{\nu}H)
+ \frac{g^2v_{\mathrm{F}}^2}{4} V_{\mu} V_{\nu} \right\rbrack^2
\end{align}
\end{subequations}
with
\begin{equation}
V_{\mu} V_{\nu} =
\frac{1}{2} \left( W^+_{\mu} W^-_{\nu} + W^+_{\nu} W^-_{\mu} \right)
+ \frac{1}{2\cos^2\theta_{w}} Z_{\mu} Z_{\nu}
\end{equation}
(note the symmetrization!), i.\,e.
\begin{subequations}
\begin{align}
\mathcal{L}_4 &= \alpha_4 \frac{g^4v_{\mathrm{F}}^4}{16} (V_{\mu} V_{\nu})^2 \\
\mathcal{L}_5 &= \alpha_5 \frac{g^4v_{\mathrm{F}}^4}{16} (V_{\mu} V^{\mu})^2
\end{align}
\end{subequations} *)
let goldstone_vertices =
[ ((O Phi0, G Wm, G Wp), Scalar_Vector_Vector 1, I_G_ZWW);
((O Phip, G Ga, G Wm), Scalar_Vector_Vector 1, I_Q_W);
((O Phip, G Z, G Wm), Scalar_Vector_Vector 1, I_G_ZWW);
((O Phim, G Wp, G Ga), Scalar_Vector_Vector 1, I_Q_W);
((O Phim, G Wp, G Z), Scalar_Vector_Vector 1, I_G_ZWW) ]
(* Anomalous trilinear interactions $f_i f_j V$ :
\begin{equation}
\Delta\mathcal{L}_{tt\gamma} =
- e \frac{\upsilon}{\Lambda^2}
\bar{t} i\sigma^{\mu\nu} k_\nu (d_V(k^2) + i d_A(k^2) \gamma_5) t A_\mu
\end{equation} *)
let anomalous_ttA =
if Flags.top_anom then
[ ((M (U (-3)), G Ga, M (U 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_ttA) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{bb\gamma} =
- e \frac{\upsilon}{\Lambda^2}
\bar{b} i\sigma^{\mu\nu} k_\nu (d_V(k^2) + i d_A(k^2) \gamma_5) b A_\mu
\end{equation} *)
let anomalous_bbA =
if Flags.top_anom then
[ ((M (D (-3)), G Ga, M (D 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_bbA) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{ttg} =
- g_s \frac{\upsilon}{\Lambda^2}
\bar{t}\lambda^a i\sigma^{\mu\nu}k_\nu
(d_V(k^2)+id_A(k^2)\gamma_5)tG^a_\mu
\end{equation} *)
let anomalous_ttG =
if Flags.top_anom then
[ ((M (U (-3)), G Gl, M (U 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_ttG) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{ttZ} =
- \frac{g}{2 c_W} \frac{\upsilon^2}{\Lambda^2}\left\lbrack
\bar{t} \fmslash{Z} (X_L(k^2) P_L + X_R(k^2) P_R) t
+ \bar{t}\frac{i\sigma^{\mu\nu}k_\nu}{m_Z}
(d_V(k^2)+id_A(k^2)\gamma_5)tZ_\mu\right\rbrack
\end{equation} *)
let anomalous_ttZ =
if Flags.top_anom then
[ ((M (U (-3)), G Z, M (U 3)), FBF (1, Psibar, VLRM, Psi), G_VLR_ttZ);
((M (U (-3)), G Z, M (U 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_ttZ) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{bbZ} =
- \frac{g}{2 c_W} \frac{\upsilon^2}{\Lambda^2}
\bar{b}\frac{i\sigma^{\mu\nu}k_\nu}{m_Z}
(d_V(k^2)+id_A(k^2)\gamma_5)bZ_\mu
\end{equation} *)
let anomalous_bbZ =
if Flags.top_anom then
[ ((M (D (-3)), G Z, M (D 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_bbZ) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{tbW} =
- \frac{g}{\sqrt{2}} \frac{\upsilon^2}{\Lambda^2}\left\lbrack
\bar{b}\fmslash{W}^-(V_L(k^2) P_L+V_R(k^2) P_R) t
+ \bar{b}\frac{i\sigma^{\mu\nu}k_\nu}{m_W}
(g_L(k^2)P_L+g_R(k^2)P_R)tW^-_\mu\right\rbrack
+ \textnormal{H.c.}
\end{equation} *)
let anomalous_tbW =
if Flags.top_anom then
[ ((M (D (-3)), G Wm, M (U 3)), FBF (1, Psibar, VLRM, Psi), G_VLR_btW);
((M (U (-3)), G Wp, M (D 3)), FBF (1, Psibar, VLRM, Psi), G_VLR_tbW);
((M (D (-3)), G Wm, M (U 3)), FBF (1, Psibar, TLRM, Psi), G_TLR_btW);
((M (U (-3)), G Wp, M (D 3)), FBF (1, Psibar, TRLM, Psi), G_TRL_tbW) ]
else
[]
(* quartic fermion-gauge interactions $f_i f_j V_1 V_2$ emerging from gauge-invariant
effective operators:
\begin{equation}
\Delta\mathcal{L}_{ttgg} =
- \frac{g_s^2}{2} f_{abc} \frac{\upsilon}{\Lambda^2}
\bar{t} \lambda^a \sigma^{\mu\nu}
(d_V(k^2)+id_A(k^2)\gamma_5)t G^b_\mu G^c_\nu
\end{equation} *)
let anomalous_ttGG =
if Flags.top_anom then
[ ((M (U (-3)), O (Aux_top (2,1,0,true,TTGG)), M (U 3)), FBF (1, Psibar, TVA, Psi), G_TVA_ttGG);
((O (Aux_top (2,1,0,false,TTGG)), G Gl, G Gl), Aux_Gauge_Gauge 1, I_Gs) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{tbWA} =
- i\sin\theta_w \frac{g^2}{2\sqrt{2}} \frac{\upsilon^2}{\Lambda^2}\left\lbrack
\bar{b}\frac{\sigma^{\mu\nu}}{m_W}
(g_L(k^2)P_L+g_R(k^2)P_R)t A_\mu W^-_\nu \right\rbrack
+ \textnormal{H.c.}
\end{equation} *)
let anomalous_tbWA =
if Flags.top_anom then
[ ((M (D (-3)), O (Aux_top (2,0,-1,true,TBWA)), M (U 3)), FBF (1, Psibar, TLR, Psi), G_TLR_btWA);
((O (Aux_top (2,0,1,false,TBWA)), G Ga, G Wm), Aux_Gauge_Gauge 1, I_G_weak);
((M (U (-3)), O (Aux_top (2,0,1,true,TBWA)), M (D 3)), FBF (1, Psibar, TRL, Psi), G_TRL_tbWA);
((O (Aux_top (2,0,-1,false,TBWA)), G Wp, G Ga), Aux_Gauge_Gauge 1, I_G_weak) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{tbWZ} =
- i\cos\theta_w \frac{g^2}{2\sqrt{2}} \frac{\upsilon^2}{\Lambda^2}\left\lbrack
\bar{b}\frac{\sigma^{\mu\nu}}{m_W}
(g_L(k^2)P_L+g_R(k^2)P_R)t Z_\mu W^-_\nu \right\rbrack
+ \textnormal{H.c.}
\end{equation} *)
let anomalous_tbWZ =
if Flags.top_anom then
[ ((M (D (-3)), O (Aux_top (2,0,-1,true,TBWZ)), M (U 3)), FBF (1, Psibar, TLR, Psi), G_TLR_btWZ);
((O (Aux_top (2,0,1,false,TBWZ)), G Z, G Wm), Aux_Gauge_Gauge 1, I_G_weak);
((M (U (-3)), O (Aux_top (2,0,1,true,TBWZ)), M (D 3)), FBF (1, Psibar, TRL, Psi), G_TRL_tbWZ);
((O (Aux_top (2,0,-1,false,TBWZ)), G Wp, G Z), Aux_Gauge_Gauge 1, I_G_weak) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{ttWW} =
- i \frac{g^2}{2} \frac{\upsilon^2}{\Lambda^2}
\bar{t} \frac{\sigma^{\mu\nu}}{m_W}
(d_V(k^2)+id_A(k^2)\gamma_5)t W^-_\mu W^+_\nu
\end{equation} *)
let anomalous_ttWW =
if Flags.top_anom then
[ ((M (U (-3)), O (Aux_top (2,0,0,true,TTWW)), M (U 3)), FBF (1, Psibar, TVA, Psi), G_TVA_ttWW);
((O (Aux_top (2,0,0,false,TTWW)), G Wm, G Wp), Aux_Gauge_Gauge 1, I_G_weak) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{bbWW} =
- i \frac{g^2}{2} \frac{\upsilon^2}{\Lambda^2}
\bar{b} \frac{\sigma^{\mu\nu}}{m_W}
(d_V(k^2)+id_A(k^2)\gamma_5)b W^-_\mu W^+_\nu
\end{equation} *)
let anomalous_bbWW =
if Flags.top_anom then
[ ((M (D (-3)), O (Aux_top (2,0,0,true,BBWW)), M (D 3)), FBF (1, Psibar, TVA, Psi), G_TVA_bbWW);
((O (Aux_top (2,0,0,false,BBWW)), G Wm, G Wp), Aux_Gauge_Gauge 1, I_G_weak) ]
else
[]
(* 4-fermion contact terms emerging from operator rewriting: *)
let anomalous_top_qGuG_tt =
[ ((M (U (-3)), O (Aux_top (1,1,0,true,QGUG)), M (U 3)), FBF (1, Psibar, VLR, Psi), G_VLR_qGuG) ]
let anomalous_top_qGuG_ff n =
List.map mom
[ ((U (-n), Aux_top (1,1,0,false,QGUG), U n), FBF (1, Psibar, V, Psi), Unit);
((D (-n), Aux_top (1,1,0,false,QGUG), D n), FBF (1, Psibar, V, Psi), Unit) ]
let anomalous_top_qGuG =
if Flags.top_anom_4f then
anomalous_top_qGuG_tt @ ThoList.flatmap anomalous_top_qGuG_ff [1;2;3]
else
[]
let anomalous_top_qBuB_tt =
[ ((M (U (-3)), O (Aux_top (1,0,0,true,QBUB)), M (U 3)), FBF (1, Psibar, VLR, Psi), G_VLR_qBuB) ]
let anomalous_top_qBuB_ff n =
List.map mom
[ ((U (-n), Aux_top (1,0,0,false,QBUB), U n), FBF (1, Psibar, VLR, Psi), G_VLR_qBuB_u);
((D (-n), Aux_top (1,0,0,false,QBUB), D n), FBF (1, Psibar, VLR, Psi), G_VLR_qBuB_d);
((L (-n), Aux_top (1,0,0,false,QBUB), L n), FBF (1, Psibar, VLR, Psi), G_VLR_qBuB_e);
((N (-n), Aux_top (1,0,0,false,QBUB), N n), FBF (1, Psibar, VL, Psi), G_VL_qBuB_n) ]
let anomalous_top_qBuB =
if Flags.top_anom_4f then
anomalous_top_qBuB_tt @ ThoList.flatmap anomalous_top_qBuB_ff [1;2;3]
else
[]
let anomalous_top_qW_tq =
[ ((M (U (-3)), O (Aux_top (1,0,0,true,QW)), M (U 3)), FBF (1, Psibar, VL, Psi), G_VL_qW);
((M (D (-3)), O (Aux_top (1,0,-1,true,QW)), M (U 3)), FBF (1, Psibar, VL, Psi), G_VL_qW);
((M (U (-3)), O (Aux_top (1,0,1,true,QW)), M (D 3)), FBF (1, Psibar, VL, Psi), G_VL_qW) ]
let anomalous_top_qW_ff n =
List.map mom
[ ((U (-n), Aux_top (1,0,0,false,QW), U n), FBF (1, Psibar, VL, Psi), G_VL_qW_u);
((D (-n), Aux_top (1,0,0,false,QW), D n), FBF (1, Psibar, VL, Psi), G_VL_qW_d);
((N (-n), Aux_top (1,0,0,false,QW), N n), FBF (1, Psibar, VL, Psi), G_VL_qW_u);
((L (-n), Aux_top (1,0,0,false,QW), L n), FBF (1, Psibar, VL, Psi), G_VL_qW_d);
((D (-n), Aux_top (1,0,-1,false,QW), U n), FBF (1, Psibar, VL, Psi), Half);
((U (-n), Aux_top (1,0,1,false,QW), D n), FBF (1, Psibar, VL, Psi), Half);
((L (-n), Aux_top (1,0,-1,false,QW), N n), FBF (1, Psibar, VL, Psi), Half);
((N (-n), Aux_top (1,0,1,false,QW), L n), FBF (1, Psibar, VL, Psi), Half) ]
let anomalous_top_qW =
if Flags.top_anom_4f then
anomalous_top_qW_tq @ ThoList.flatmap anomalous_top_qW_ff [1;2;3]
else
[]
let anomalous_top_DuDd =
if Flags.top_anom_4f then
[ ((M (U (-3)), O (Aux_top (0,0,0,true,DR)), M (U 3)), FBF (1, Psibar, SR, Psi), Half);
((M (U (-3)), O (Aux_top (0,0,0,false,DR)), M (U 3)), FBF (1, Psibar, SL, Psi), G_SL_DttR);
((M (D (-3)), O (Aux_top (0,0,0,false,DR)), M (D 3)), FBF (1, Psibar, SR, Psi), G_SR_DttR);
((M (U (-3)), O (Aux_top (0,0,0,true,DL)), M (U 3)), FBF (1, Psibar, SL, Psi), Half);
((M (D (-3)), O (Aux_top (0,0,0,false,DL)), M (D 3)), FBF (1, Psibar, SL, Psi), G_SL_DttL);
((M (D (-3)), O (Aux_top (0,0,-1,true,DR)), M (U 3)), FBF (1, Psibar, SR, Psi), Half);
((M (U (-3)), O (Aux_top (0,0,1,false,DR)), M (D 3)), FBF (1, Psibar, SLR, Psi), G_SLR_DbtR);
((M (D (-3)), O (Aux_top (0,0,-1,true,DL)), M (U 3)), FBF (1, Psibar, SL, Psi), Half);
((M (U (-3)), O (Aux_top (0,0,1,false,DL)), M (D 3)), FBF (1, Psibar, SL, Psi), G_SL_DbtL) ]
else
[]
let anomalous_top_quqd1_tq =
[ ((M (D (-3)), O (Aux_top (0,0,-1,true,QUQD1R)), M (U 3)), FBF (1, Psibar, SR, Psi), C_quqd1R_bt);
((M (U (-3)), O (Aux_top (0,0, 1,true,QUQD1R)), M (D 3)), FBF (1, Psibar, SL, Psi), C_quqd1R_tb);
((M (D (-3)), O (Aux_top (0,0,-1,true,QUQD1L)), M (U 3)), FBF (1, Psibar, SL, Psi), C_quqd1L_bt);
((M (U (-3)), O (Aux_top (0,0, 1,true,QUQD1L)), M (D 3)), FBF (1, Psibar, SR, Psi), C_quqd1L_tb) ]
let anomalous_top_quqd1_ff n =
List.map mom
[ ((U (-n), Aux_top (0,0, 1,false,QUQD1R), D n), FBF (1, Psibar, SR, Psi), Half);
((D (-n), Aux_top (0,0,-1,false,QUQD1R), U n), FBF (1, Psibar, SL, Psi), Half);
((U (-n), Aux_top (0,0, 1,false,QUQD1L), D n), FBF (1, Psibar, SL, Psi), Half);
((D (-n), Aux_top (0,0,-1,false,QUQD1L), U n), FBF (1, Psibar, SR, Psi), Half) ]
let anomalous_top_quqd1 =
if Flags.top_anom_4f then
anomalous_top_quqd1_tq @ ThoList.flatmap anomalous_top_quqd1_ff [1;2;3]
else
[]
let anomalous_top_quqd8_tq =
[ ((M (D (-3)), O (Aux_top (0,1,-1,true,QUQD8R)), M (U 3)), FBF (1, Psibar, SR, Psi), C_quqd8R_bt);
((M (U (-3)), O (Aux_top (0,1, 1,true,QUQD8R)), M (D 3)), FBF (1, Psibar, SL, Psi), C_quqd8R_tb);
((M (D (-3)), O (Aux_top (0,1,-1,true,QUQD8L)), M (U 3)), FBF (1, Psibar, SL, Psi), C_quqd8L_bt);
((M (U (-3)), O (Aux_top (0,1, 1,true,QUQD8L)), M (D 3)), FBF (1, Psibar, SR, Psi), C_quqd8L_tb) ]
let anomalous_top_quqd8_ff n =
List.map mom
[ ((U (-n), Aux_top (0,1, 1,false,QUQD8R), D n), FBF (1, Psibar, SR, Psi), Half);
((D (-n), Aux_top (0,1,-1,false,QUQD8R), U n), FBF (1, Psibar, SL, Psi), Half);
((U (-n), Aux_top (0,1, 1,false,QUQD8L), D n), FBF (1, Psibar, SL, Psi), Half);
((D (-n), Aux_top (0,1,-1,false,QUQD8L), U n), FBF (1, Psibar, SR, Psi), Half) ]
let anomalous_top_quqd8 =
if Flags.top_anom_4f then
anomalous_top_quqd8_tq @ ThoList.flatmap anomalous_top_quqd8_ff [1;2;3]
else
[]
let vertices3 =
(ThoList.flatmap electromagnetic_currents [1;2;3] @
ThoList.flatmap color_currents [1;2;3] @
ThoList.flatmap neutral_currents [1;2;3] @
(if Flags.ckm_present then
charged_currents_ckm
else
charged_currents_triv) @
triple_gauge @
goldstone_vertices @
anomalous_ttA @ anomalous_bbA @
anomalous_ttZ @ anomalous_bbZ @
anomalous_tbW @ anomalous_tbWA @ anomalous_tbWZ @
anomalous_ttWW @ anomalous_bbWW @
anomalous_ttG @ anomalous_ttGG @
anomalous_top_qGuG @ anomalous_top_qBuB @
anomalous_top_qW @ anomalous_top_DuDd @
anomalous_top_quqd1 @ anomalous_top_quqd8)
let vertices4 =
quartic_gauge
let vertices () = (vertices3, vertices4, [])
(* For efficiency, make sure that [F.of_vertices vertices] is
evaluated only once. *)
let table = F.of_vertices (vertices ())
let fuse2 = F.fuse2 table
let fuse3 = F.fuse3 table
let fuse = F.fuse table
let max_degree () = 4
let flavor_of_string = function
| "e-" -> M (L 1) | "e+" -> M (L (-1))
| "mu-" -> M (L 2) | "mu+" -> M (L (-2))
| "tau-" -> M (L 3) | "tau+" -> M (L (-3))
| "nue" -> M (N 1) | "nuebar" -> M (N (-1))
| "numu" -> M (N 2) | "numubar" -> M (N (-2))
| "nutau" -> M (N 3) | "nutaubar" -> M (N (-3))
| "u" -> M (U 1) | "ubar" -> M (U (-1))
| "c" -> M (U 2) | "cbar" -> M (U (-2))
| "t" -> M (U 3) | "tbar" -> M (U (-3))
| "d" -> M (D 1) | "dbar" -> M (D (-1))
| "s" -> M (D 2) | "sbar" -> M (D (-2))
| "b" -> M (D 3) | "bbar" -> M (D (-3))
| "g" | "gl" -> G Gl
| "A" -> G Ga | "Z" | "Z0" -> G Z
| "W+" -> G Wp | "W-" -> G Wm
| "Aux_t_ttGG0" -> O (Aux_top (2,1, 0,true,TTGG)) | "Aux_ttGG0" -> O (Aux_top (2,1, 0,false,TTGG))
| "Aux_t_tbWA+" -> O (Aux_top (2,0, 1,true,TBWA)) | "Aux_tbWA+" -> O (Aux_top (2,0, 1,false,TBWA))
| "Aux_t_tbWA-" -> O (Aux_top (2,0,-1,true,TBWA)) | "Aux_tbWA-" -> O (Aux_top (2,0,-1,false,TBWA))
| "Aux_t_tbWZ+" -> O (Aux_top (2,0, 1,true,TBWZ)) | "Aux_tbWZ+" -> O (Aux_top (2,0, 1,false,TBWZ))
| "Aux_t_tbWZ-" -> O (Aux_top (2,0,-1,true,TBWZ)) | "Aux_tbWZ-" -> O (Aux_top (2,0,-1,false,TBWZ))
| "Aux_t_ttWW0" -> O (Aux_top (2,0, 0,true,TTWW)) | "Aux_ttWW0" -> O (Aux_top (2,0, 0,false,TTWW))
| "Aux_t_bbWW0" -> O (Aux_top (2,0, 0,true,BBWW)) | "Aux_bbWW0" -> O (Aux_top (2,0, 0,false,BBWW))
| "Aux_t_qGuG0" -> O (Aux_top (1,1, 0,true,QGUG)) | "Aux_qGuG0" -> O (Aux_top (1,1, 0,false,QGUG))
| "Aux_t_qBuB0" -> O (Aux_top (1,0, 0,true,QBUB)) | "Aux_qBuB0" -> O (Aux_top (1,0, 0,false,QBUB))
| "Aux_t_qW0" -> O (Aux_top (1,0, 0,true,QW)) | "Aux_qW0" -> O (Aux_top (1,0, 0,false,QW))
| "Aux_t_qW+" -> O (Aux_top (1,0, 1,true,QW)) | "Aux_qW+" -> O (Aux_top (1,0, 1,false,QW))
| "Aux_t_qW-" -> O (Aux_top (1,0,-1,true,QW)) | "Aux_qW-" -> O (Aux_top (1,0,-1,false,QW))
| "Aux_t_dL0" -> O (Aux_top (0,0, 0,true,DL)) | "Aux_dL0" -> O (Aux_top (0,0, 0,false,DL))
| "Aux_t_dL+" -> O (Aux_top (0,0, 1,true,DL)) | "Aux_dL+" -> O (Aux_top (0,0, 1,false,DL))
| "Aux_t_dL-" -> O (Aux_top (0,0,-1,true,DL)) | "Aux_dL-" -> O (Aux_top (0,0,-1,false,DL))
| "Aux_t_dR0" -> O (Aux_top (0,0, 0,true,DR)) | "Aux_dR0" -> O (Aux_top (0,0, 0,false,DR))
| "Aux_t_dR+" -> O (Aux_top (0,0, 1,true,DR)) | "Aux_dR+" -> O (Aux_top (0,0, 1,false,DR))
| "Aux_t_dR-" -> O (Aux_top (0,0,-1,true,DR)) | "Aux_dR-" -> O (Aux_top (0,0,-1,false,DR))
| "Aux_t_quqd1L+" -> O (Aux_top (0,0, 1,true,QUQD1L)) | "Aux_quqd1L+" -> O (Aux_top (0,0, 1,false,QUQD1L))
| "Aux_t_quqd1L-" -> O (Aux_top (0,0,-1,true,QUQD1L)) | "Aux_quqd1L-" -> O (Aux_top (0,0,-1,false,QUQD1L))
| "Aux_t_quqd1R+" -> O (Aux_top (0,0, 1,true,QUQD1R)) | "Aux_quqd1R+" -> O (Aux_top (0,0, 1,false,QUQD1R))
| "Aux_t_quqd1R-" -> O (Aux_top (0,0,-1,true,QUQD1R)) | "Aux_quqd1R-" -> O (Aux_top (0,0,-1,false,QUQD1R))
| "Aux_t_quqd8L+" -> O (Aux_top (0,1, 1,true,QUQD8L)) | "Aux_quqd8L+" -> O (Aux_top (0,1, 1,false,QUQD8L))
| "Aux_t_quqd8L-" -> O (Aux_top (0,1,-1,true,QUQD8L)) | "Aux_quqd8L-" -> O (Aux_top (0,1,-1,false,QUQD8L))
| "Aux_t_quqd8R+" -> O (Aux_top (0,1, 1,true,QUQD8R)) | "Aux_quqd8R+" -> O (Aux_top (0,1, 1,false,QUQD8R))
| "Aux_t_quqd8R-" -> O (Aux_top (0,1,-1,true,QUQD8R)) | "Aux_quqd8R-" -> O (Aux_top (0,1,-1,false,QUQD8R))
| _ -> invalid_arg "Modellib.NoH.flavor_of_string"
let flavor_to_string = function
| M f ->
begin match f with
| L 1 -> "e-" | L (-1) -> "e+"
| L 2 -> "mu-" | L (-2) -> "mu+"
| L 3 -> "tau-" | L (-3) -> "tau+"
| L _ -> invalid_arg
"Modellib.NoH.flavor_to_string: invalid lepton"
| N 1 -> "nue" | N (-1) -> "nuebar"
| N 2 -> "numu" | N (-2) -> "numubar"
| N 3 -> "nutau" | N (-3) -> "nutaubar"
| N _ -> invalid_arg
"Modellib.NoH.flavor_to_string: invalid neutrino"
| U 1 -> "u" | U (-1) -> "ubar"
| U 2 -> "c" | U (-2) -> "cbar"
| U 3 -> "t" | U (-3) -> "tbar"
| U _ -> invalid_arg
"Modellib.NoH.flavor_to_string: invalid up type quark"
| D 1 -> "d" | D (-1) -> "dbar"
| D 2 -> "s" | D (-2) -> "sbar"
| D 3 -> "b" | D (-3) -> "bbar"
| D _ -> invalid_arg
"Modellib.NoH.flavor_to_string: invalid down type quark"
end
| G f ->
begin match f with
| Gl -> "gl"
| Ga -> "A" | Z -> "Z"
| Wp -> "W+" | Wm -> "W-"
end
| O f ->
begin match f with
| Phip -> "phi+" | Phim -> "phi-" | Phi0 -> "phi0"
| Aux_top (_,_,ch,n,v) -> "Aux_" ^ (if n then "t_" else "") ^ (
begin match v with
| TTGG -> "ttGG" | TBWA -> "tbWA" | TBWZ -> "tbWZ"
| TTWW -> "ttWW" | BBWW -> "bbWW"
| QGUG -> "qGuG" | QBUB -> "qBuB"
| QW -> "qW" | DL -> "dL" | DR -> "dR"
| QUQD1L -> "quqd1L" | QUQD1R -> "quqd1R"
| QUQD8L -> "quqd8L" | QUQD8R -> "quqd8R"
end ) ^ ( if ch > 0 then "+" else if ch < 0 then "-" else "0" )
end
let flavor_to_TeX = function
| M f ->
begin match f with
| L 1 -> "e^-" | L (-1) -> "e^+"
| L 2 -> "\\mu^-" | L (-2) -> "\\mu^+"
| L 3 -> "\\tau^-" | L (-3) -> "\\tau^+"
| L _ -> invalid_arg
"Modellib.NoH.flavor_to_TeX: invalid lepton"
| N 1 -> "\\nu_e" | N (-1) -> "\\bar{\\nu}_e"
| N 2 -> "\\nu_\\mu" | N (-2) -> "\\bar{\\nu}_\\mu"
| N 3 -> "\\nu_\\tau" | N (-3) -> "\\bar{\\nu}_\\tau"
| N _ -> invalid_arg
"Modellib.NoH.flavor_to_TeX: invalid neutrino"
| U 1 -> "u" | U (-1) -> "\\bar{u}"
| U 2 -> "c" | U (-2) -> "\\bar{c}"
| U 3 -> "t" | U (-3) -> "\\bar{t}"
| U _ -> invalid_arg
"Modellib.NoH.flavor_to_TeX: invalid up type quark"
| D 1 -> "d" | D (-1) -> "\\bar{d}"
| D 2 -> "s" | D (-2) -> "\\bar{s}"
| D 3 -> "b" | D (-3) -> "\\bar{b}"
| D _ -> invalid_arg
"Modellib.NoH.flavor_to_TeX: invalid down type quark"
end
| G f ->
begin match f with
| Gl -> "g"
| Ga -> "\\gamma" | Z -> "Z"
| Wp -> "W^+" | Wm -> "W^-"
end
| O f ->
begin match f with
| Phip -> "\\phi^+" | Phim -> "\\phi^-" | Phi0 -> "\\phi^0"
| Aux_top (_,_,ch,n,v) -> "\\textnormal{Aux_" ^ (if n then "t_" else "") ^ (
begin match v with
| TTGG -> "ttGG" | TBWA -> "tbWA" | TBWZ -> "tbWZ"
| TTWW -> "ttWW" | BBWW -> "bbWW"
| QGUG -> "qGuG" | QBUB -> "qBuB"
| QW -> "qW" | DL -> "dL" | DR -> "dR"
| QUQD1L -> "quqd1L" | QUQD1R -> "quqd1R"
| QUQD8L -> "quqd8L" | QUQD8R -> "quqd8R"
end ) ^ ( if ch > 0 then "^+" else if ch < 0 then "^-" else "^0" ) ^ "}"
end
let flavor_symbol = function
| M f ->
begin match f with
| L n when n > 0 -> "l" ^ string_of_int n
| L n -> "l" ^ string_of_int (abs n) ^ "b"
| N n when n > 0 -> "n" ^ string_of_int n
| N n -> "n" ^ string_of_int (abs n) ^ "b"
| U n when n > 0 -> "u" ^ string_of_int n
| U n -> "u" ^ string_of_int (abs n) ^ "b"
| D n when n > 0 -> "d" ^ string_of_int n
| D n -> "d" ^ string_of_int (abs n) ^ "b"
end
| G f ->
begin match f with
| Gl -> "gl"
| Ga -> "a" | Z -> "z"
| Wp -> "wp" | Wm -> "wm"
end
| O f ->
begin match f with
| Phip -> "pp" | Phim -> "pm" | Phi0 -> "p0"
| Aux_top (_,_,ch,n,v) -> "aux_" ^ (if n then "t_" else "") ^ (
begin match v with
| TTGG -> "ttgg" | TBWA -> "tbwa" | TBWZ -> "tbwz"
| TTWW -> "ttww" | BBWW -> "bbww"
| QGUG -> "qgug" | QBUB -> "qbub"
| QW -> "qw" | DL -> "dl" | DR -> "dr"
| QUQD1L -> "quqd1l" | QUQD1R -> "quqd1r"
| QUQD8L -> "quqd8l" | QUQD8R -> "quqd8r"
end ) ^ "_" ^ ( if ch > 0 then "p" else if ch < 0 then "m" else "0" )
end
let pdg = function
| M f ->
begin match f with
| L n when n > 0 -> 9 + 2*n
| L n -> - 9 + 2*n
| N n when n > 0 -> 10 + 2*n
| N n -> - 10 + 2*n
| U n when n > 0 -> 2*n
| U n -> 2*n
| D n when n > 0 -> - 1 + 2*n
| D n -> 1 + 2*n
end
| G f ->
begin match f with
| Gl -> 21
| Ga -> 22 | Z -> 23
| Wp -> 24 | Wm -> (-24)
end
| O f ->
begin match f with
| Phip | Phim -> 27 | Phi0 -> 26
| Aux_top (_,_,ch,t,f) -> let n =
begin match f with
| QW -> 0
| QUQD1R -> 1 | QUQD1L -> 2
| QUQD8R -> 3 | QUQD8L -> 4
| _ -> 5
end
in (602 + 3*n - ch) * ( if t then (1) else (-1) )
end
let mass_symbol f =
"mass(" ^ string_of_int (abs (pdg f)) ^ ")"
let width_symbol f =
"width(" ^ string_of_int (abs (pdg f)) ^ ")"
let constant_symbol = function
| Unit -> "unit" | Half -> "half" | Pi -> "PI"
| Alpha_QED -> "alpha" | E -> "e" | G_weak -> "g" | Vev -> "vev"
| I_G_weak -> "ig"
| Sin2thw -> "sin2thw" | Sinthw -> "sinthw" | Costhw -> "costhw"
| Q_lepton -> "qlep" | Q_up -> "qup" | Q_down -> "qdwn"
| G_NC_lepton -> "gnclep" | G_NC_neutrino -> "gncneu"
| G_NC_up -> "gncup" | G_NC_down -> "gncdwn"
| G_TVA_ttA -> "gtva_tta" | G_TVA_bbA -> "gtva_bba"
| G_VLR_ttZ -> "gvlr_ttz" | G_TVA_ttZ -> "gtva_ttz" | G_TVA_bbZ -> "gtva_bbz"
| G_VLR_btW -> "gvlr_btw" | G_VLR_tbW -> "gvlr_tbw"
| G_TLR_btW -> "gtlr_btw" | G_TRL_tbW -> "gtrl_tbw"
| G_TLR_btWA -> "gtlr_btwa" | G_TRL_tbWA -> "gtrl_tbwa"
| G_TLR_btWZ -> "gtlr_btwz" | G_TRL_tbWZ -> "gtrl_tbwz"
| G_TVA_ttWW -> "gtva_ttww" | G_TVA_bbWW -> "gtva_bbww"
| G_TVA_ttG -> "gtva_ttg" | G_TVA_ttGG -> "gtva_ttgg"
| G_VLR_qGuG -> "gvlr_qgug"
| G_VLR_qBuB -> "gvlr_qbub"
| G_VLR_qBuB_u -> "gvlr_qbub_u" | G_VLR_qBuB_d -> "gvlr_qbub_d"
| G_VLR_qBuB_e -> "gvlr_qbub_e" | G_VL_qBuB_n -> "gvl_qbub_n"
| G_VL_qW -> "gvl_qw"
| G_VL_qW_u -> "gvl_qw_u" | G_VL_qW_d -> "gvl_qw_d"
| G_SL_DttR -> "gsl_dttr" | G_SR_DttR -> "gsr_dttr" | G_SL_DttL -> "gsl_dttl"
| G_SLR_DbtR -> "gslr_dbtr" | G_SL_DbtL -> "gsl_dbtl"
| C_quqd1R_bt -> "c_quqd1_1" | C_quqd1R_tb -> "conjg(c_quqd1_1)"
| C_quqd1L_bt -> "conjg(c_quqd1_2)" | C_quqd1L_tb -> "c_quqd1_2"
| C_quqd8R_bt -> "c_quqd8_1" | C_quqd8R_tb -> "conjg(c_quqd8_1)"
| C_quqd8L_bt -> "conjg(c_quqd8_2)" | C_quqd8L_tb -> "c_quqd8_2"
| G_CC -> "gcc"
| G_CCQ (n1,n2) -> "gccq" ^ string_of_int n1 ^ string_of_int n2
| I_Q_W -> "iqw" | I_G_ZWW -> "igzww"
| G_WWWW -> "gw4" | G_ZZWW -> "gzzww"
| G_AZWW -> "gazww" | G_AAWW -> "gaaww"
| I_G1_AWW -> "ig1a" | I_G1_ZWW -> "ig1z"
| I_G1_plus_kappa_plus_G4_AWW -> "ig1pkpg4a"
| I_G1_plus_kappa_plus_G4_ZWW -> "ig1pkpg4z"
| I_G1_plus_kappa_minus_G4_AWW -> "ig1pkmg4a"
| I_G1_plus_kappa_minus_G4_ZWW -> "ig1pkmg4z"
| I_G1_minus_kappa_plus_G4_AWW -> "ig1mkpg4a"
| I_G1_minus_kappa_plus_G4_ZWW -> "ig1mkpg4z"
| I_G1_minus_kappa_minus_G4_AWW -> "ig1mkmg4a"
| I_G1_minus_kappa_minus_G4_ZWW -> "ig1mkmg4z"
| I_lambda_AWW -> "ila"
| I_lambda_ZWW -> "ilz"
| G5_AWW -> "rg5a"
| G5_ZWW -> "rg5z"
| I_kappa5_AWW -> "ik5a"
| I_kappa5_ZWW -> "ik5z"
| I_lambda5_AWW -> "il5a" | I_lambda5_ZWW -> "il5z"
| Alpha_WWWW0 -> "alww0" | Alpha_WWWW2 -> "alww2"
| Alpha_ZZWW0 -> "alzw0" | Alpha_ZZWW1 -> "alzw1"
| Alpha_ZZZZ -> "alzz"
| D_Alpha_ZZWW0_S -> "dalzz0_s(gkm,mkm,"
| D_Alpha_ZZWW0_T -> "dalzz0_t(gkm,mkm,"
| D_Alpha_ZZWW1_S -> "dalzz1_s(gkm,mkm,"
| D_Alpha_ZZWW1_T -> "dalzz1_t(gkm,mkm,"
| D_Alpha_ZZWW1_U -> "dalzz1_u(gkm,mkm,"
| D_Alpha_WWWW0_S -> "dalww0_s(gkm,mkm,"
| D_Alpha_WWWW0_T -> "dalww0_t(gkm,mkm,"
| D_Alpha_WWWW0_U -> "dalww0_u(gkm,mkm,"
| D_Alpha_WWWW2_S -> "dalww2_s(gkm,mkm,"
| D_Alpha_WWWW2_T -> "dalww2_t(gkm,mkm,"
| D_Alpha_ZZZZ_S -> "dalz4_s(gkm,mkm,"
| D_Alpha_ZZZZ_T -> "dalz4_t(gkm,mkm,"
| Gs -> "gs" | I_Gs -> "igs" | G2 -> "gs**2"
| Mass f -> "mass" ^ flavor_symbol f
| Width f -> "width" ^ flavor_symbol f
| K_Matrix_Coeff i -> "kc" ^ string_of_int i
| K_Matrix_Pole i -> "kp" ^ string_of_int i
end
(* \thocwmodulesection{Minimal Higgsless Model including additional Resonances} *)
module AltH (Flags : NoH_flags) =
struct
open Coupling
let default_width = ref Timelike
let use_fudged_width = ref false
let options = Options.create
[ "constant_width", Arg.Unit (fun () -> default_width := Constant),
"use constant width (also in t-channel)";
"fudged_width", Arg.Set use_fudged_width,
"use fudge factor for charge particle width";
"custom_width", Arg.String (fun f -> default_width := Custom f),
"use custom width";
"cancel_widths", Arg.Unit (fun () -> default_width := Vanishing),
"use vanishing width";
"cms_width", Arg.Unit (fun () -> default_width := Complex_Mass),
"use complex mass scheme"]
let caveats () = []
type f_aux_top = TTGG | TBWA | TBWZ | TTWW | BBWW | (*i top auxiliary field "flavors" *)
QGUG | QBUB | QW | DL | DR
type matter_field = L of int | N of int | U of int | D of int
type gauge_boson = Ga | Wp | Wm | Z | Gl
type other = Phip | Phim | Phi0
| Rsigma | Rphin | Rphip | Rphim | Rphipp | Rphimm
| Rf | Rtn | Rtp | Rtm | Rtpp | Rtmm
| Aux_top of int*int*int*bool*f_aux_top (*i lorentz*color*charge*top-side*flavor *)
type flavor = M of matter_field | G of gauge_boson | O of other
let matter_field f = M f
let gauge_boson f = G f
let other f = O f
type field =
| Matter of matter_field
| Gauge of gauge_boson
| Other of other
let field = function
| M f -> Matter f
| G f -> Gauge f
| O f -> Other f
type gauge = unit
let gauge_symbol () =
failwith "Modellib_NoH.AltH.gauge_symbol: internal error"
let family n = List.map matter_field [ L n; N n; U n; D n ]
let rec aux_top_flavors (f,l,co,ch) = List.append
( List.map other [ Aux_top(l,co,ch/2,true,f); Aux_top(l,co,ch/2,false,f) ] )
( if ch > 1 then List.append
( List.map other [ Aux_top(l,co,-ch/2,true,f); Aux_top(l,co,-ch/2,false,f) ] )
( aux_top_flavors (f,l,co,(ch-2)) )
else [] )
let external_flavors () =
[ "1st Generation", ThoList.flatmap family [1; -1];
"2nd Generation", ThoList.flatmap family [2; -2];
"3rd Generation", ThoList.flatmap family [3; -3];
"Gauge Bosons", List.map gauge_boson [Ga; Z; Wp; Wm; Gl];
"Scalar Resonances", List.map other [Rsigma; Rphin; Rphip; Rphim; Rphipp; Rphimm];
"Tensor Resonances", List.map other [Rf; Rtn; Rtp; Rtm; Rtpp; Rtmm];
"Goldstone Bosons", List.map other [Phip; Phim; Phi0] ]
let flavors () = List.append
( ThoList.flatmap snd (external_flavors ()) )
( ThoList.flatmap aux_top_flavors
[ (TTGG,2,1,1); (TBWA,2,0,2); (TBWZ,2,0,2); (TTWW,2,0,1); (BBWW,2,0,1);
(QGUG,1,1,1); (QBUB,1,0,1); (QW,1,0,3); (DL,0,0,3); (DR,0,0,3) ] )
let spinor n =
if n >= 0 then
Spinor
else
ConjSpinor
let lorentz_aux = function
| 2 -> Tensor_1
| 1 -> Vector
| 0 -> Scalar
| _ -> invalid_arg ("SM.lorentz_aux: wrong value")
let lorentz = function
| M f ->
begin match f with
| L n -> spinor n | N n -> spinor n
| U n -> spinor n | D n -> spinor n
end
| G f ->
begin match f with
| Ga | Gl -> Vector
| Wp | Wm | Z -> Massive_Vector
end
| O f ->
begin match f with
| Aux_top (l,_,_,_,_) -> lorentz_aux l
| Rf | Rtn | Rtp | Rtm | Rtpp | Rtmm -> Tensor_2
| _ -> Scalar
end
- let color = function
+ let color = function
| M (U n) -> Color.SUN (if n > 0 then 3 else -3)
| M (D n) -> Color.SUN (if n > 0 then 3 else -3)
| G Gl -> Color.AdjSUN 3
| O (Aux_top (_,co,_,_,_)) -> if co == 0 then Color.Singlet else Color.AdjSUN 3
| _ -> Color.Singlet
let nc () = 3
let prop_spinor n =
if n >= 0 then
Prop_Spinor
else
Prop_ConjSpinor
let prop_aux = function
| 2 -> Aux_Tensor_1
| 1 -> Aux_Vector
| 0 -> Aux_Scalar
| _ -> invalid_arg ("SM.prop_aux: wrong value")
let propagator = function
| M f ->
begin match f with
| L n -> prop_spinor n | N n -> prop_spinor n
| U n -> prop_spinor n | D n -> prop_spinor n
end
| G f ->
begin match f with
| Ga | Gl -> Prop_Feynman
| Wp | Wm | Z -> Prop_Unitarity
end
| O f ->
begin match f with
| Phip | Phim | Phi0 -> Only_Insertion
| Rsigma -> Prop_Scalar
| Rphin | Rphip | Rphim | Rphipp | Rphimm -> Prop_Scalar
| Rf -> Prop_Tensor_2
| Rtn | Rtp | Rtm | Rtpp | Rtmm -> Prop_Tensor_2
| Aux_top (l,_,_,_,_) -> prop_aux l
end
(* Optionally, ask for the fudge factor treatment for the widths of
charged particles. Currently, this only applies to $W^\pm$ and top. *)
let width f =
if !use_fudged_width then
match f with
| G Wp | G Wm | M (U 3) | M (U (-3)) -> Fudged
| _ -> !default_width
else
!default_width
let goldstone = function
| G f ->
begin match f with
| Wp -> Some (O Phip, Coupling.Integer 1)
| Wm -> Some (O Phim, Coupling.Integer 1)
| Z -> Some (O Phi0, Coupling.Integer 1)
| _ -> None
end
| _ -> None
let conjugate = function
| M f ->
M (begin match f with
| L n -> L (-n) | N n -> N (-n)
| U n -> U (-n) | D n -> D (-n)
end)
| G f ->
G (begin match f with
| Gl -> Gl | Ga -> Ga | Z -> Z
| Wp -> Wm | Wm -> Wp
end)
| O f ->
O (begin match f with
| Phip -> Phim | Phim -> Phip | Phi0 -> Phi0
| Rsigma -> Rsigma
| Rphin -> Rphin | Rphip -> Rphim | Rphim -> Rphip
| Rphipp -> Rphimm | Rphimm -> Rphipp
| Rf -> Rf
| Rtn -> Rtn | Rtp -> Rtm | Rtm -> Rtp
| Rtpp -> Rtmm | Rtmm -> Rtpp
| Aux_top (l,co,ch,n,f) -> Aux_top (l,co,(-ch),(not n),f)
end)
let fermion = function
| M f ->
begin match f with
| L n -> if n > 0 then 1 else -1
| N n -> if n > 0 then 1 else -1
| U n -> if n > 0 then 1 else -1
| D n -> if n > 0 then 1 else -1
end
| G f ->
begin match f with
| Gl | Ga | Z | Wp | Wm -> 0
end
| O _ -> 0
(* Electrical charge, lepton number, baryon number. We could avoid the
rationals altogether by multiplying the first and last by 3 \ldots *)
module Ch = Charges.QQ
let ( // ) = Algebra.Small_Rational.make
let generation' = function
| 1 -> [ 1//1; 0//1; 0//1]
| 2 -> [ 0//1; 1//1; 0//1]
| 3 -> [ 0//1; 0//1; 1//1]
| -1 -> [-1//1; 0//1; 0//1]
| -2 -> [ 0//1; -1//1; 0//1]
| -3 -> [ 0//1; 0//1; -1//1]
| n -> invalid_arg ("SM.generation': " ^ string_of_int n)
let generation f =
if Flags.ckm_present then
[]
else
match f with
| M (L n | N n | U n | D n) -> generation' n
| G _ | O _ -> [0//1; 0//1; 0//1]
let charge = function
| M f ->
begin match f with
| L n -> if n > 0 then -1//1 else 1//1
| N n -> 0//1
| U n -> if n > 0 then 2//3 else -2//3
| D n -> if n > 0 then -1//3 else 1//3
end
| G f ->
begin match f with
| Gl | Ga | Z -> 0//1
| Wp -> 1//1
| Wm -> -1//1
end
| O f ->
begin match f with
| Rsigma | Phi0 | Rphin | Rf | Rtn -> 0//1
| Phip | Rphip | Rtp -> 1//1
| Phim | Rphim | Rtm -> -1//1
| Rphipp | Rtpp -> 2//1
| Rphimm | Rtmm -> -2//1
| Aux_top (_,_,ch,_,_) -> ch//1
end
let lepton = function
| M f ->
begin match f with
| L n | N n -> if n > 0 then 1//1 else -1//1
| U _ | D _ -> 0//1
end
| G _ | O _ -> 0//1
let baryon = function
| M f ->
begin match f with
| L _ | N _ -> 0//1
| U n | D n -> if n > 0 then 1//1 else -1//1
end
| G _ | O _ -> 0//1
let charges f =
[ charge f; lepton f; baryon f] @ generation f
type constant =
| Unit | Half | Pi | Alpha_QED | Sin2thw
| Sinthw | Costhw | E | G_weak | I_G_weak | Vev
| Q_lepton | Q_up | Q_down | G_CC | G_CCQ of int*int
| G_NC_neutrino | G_NC_lepton | G_NC_up | G_NC_down
| G_TVA_ttA | G_TVA_bbA
| G_VLR_ttZ | G_TVA_ttZ | G_TVA_bbZ
| G_VLR_btW | G_VLR_tbW
| G_TLR_btW | G_TRL_tbW
| G_TLR_btWZ | G_TRL_tbWZ
| G_TLR_btWA | G_TRL_tbWA
| G_TVA_ttWW | G_TVA_bbWW
| G_TVA_ttG | G_TVA_ttGG
| G_VLR_qGuG | G_VLR_qBuB
| G_VLR_qBuB_u | G_VLR_qBuB_d | G_VLR_qBuB_e | G_VL_qBuB_n
| G_VL_qW | G_VL_qW_u | G_VL_qW_d
| G_SL_DttR | G_SR_DttR | G_SL_DttL | G_SLR_DbtR | G_SL_DbtL
| I_Q_W | I_G_ZWW
| G_WWWW | G_ZZWW | G_AZWW | G_AAWW
| I_G1_AWW | I_G1_ZWW
| I_G1_plus_kappa_plus_G4_AWW
| I_G1_plus_kappa_plus_G4_ZWW
| I_G1_plus_kappa_minus_G4_AWW
| I_G1_plus_kappa_minus_G4_ZWW
| I_G1_minus_kappa_plus_G4_AWW
| I_G1_minus_kappa_plus_G4_ZWW
| I_G1_minus_kappa_minus_G4_AWW
| I_G1_minus_kappa_minus_G4_ZWW
| I_lambda_AWW | I_lambda_ZWW
| G5_AWW | G5_ZWW
| I_kappa5_AWW | I_kappa5_ZWW
| I_lambda5_AWW | I_lambda5_ZWW
| Alpha_WWWW0 | Alpha_ZZWW1 | Alpha_WWWW2
| Alpha_ZZWW0 | Alpha_ZZZZ
| D_Alpha_ZZWW0_S | D_Alpha_ZZWW0_T | D_Alpha_ZZWW1_S
| D_Alpha_ZZWW1_T | D_Alpha_ZZWW1_U | D_Alpha_WWWW0_S
| D_Alpha_WWWW0_T | D_Alpha_WWWW0_U | D_Alpha_WWWW2_S
| D_Alpha_WWWW2_T | D_Alpha_ZZZZ_S | D_Alpha_ZZZZ_T
| G_SWW | G_SWW_T | G_SSWW | G_SZZ | G_SZZ_T | G_SSZZ
| G_PNWW | G_PNZZ | G_PWZ | G_PWW
| G_FWW | G_FZZ | G_FWW_T | G_FZZ_T
| G_TNWW | G_TNZZ | G_TWZ | G_TWW
| Gs | I_Gs | G2
| Mass of flavor | Width of flavor
| K_Matrix_Coeff of int | K_Matrix_Pole of int
(* \begin{dubious}
The current abstract syntax for parameter dependencies is admittedly
tedious. Later, there will be a parser for a convenient concrete syntax
as a part of a concrete syntax for models. But as these examples show,
it should include simple functions.
\end{dubious} *)
- type orders = int * int
+ type coupling_order = QCD | EW
+ let all_coupling_orders () = [QCD; EW]
+ let coupling_order_to_string = function
+ | QCD -> "QCD"
+ | EW -> "EW"
- let orders = function
- | _ -> (0,0)
+ let coupling_orders = function
+ | _ -> failwith "Modellib_NoH.AltH.orders: not implemented yet!"
(* \begin{subequations}
\begin{align}
\alpha_{\text{QED}} &= \frac{1}{137.0359895} \\
\sin^2\theta_w &= 0.23124
\end{align}
\end{subequations} *)
let input_parameters =
[ Alpha_QED, 1. /. 137.0359895;
Sin2thw, 0.23124;
Mass (G Z), 91.187;
Mass (M (N 1)), 0.0; Mass (M (L 1)), 0.51099907e-3;
Mass (M (N 2)), 0.0; Mass (M (L 2)), 0.105658389;
Mass (M (N 3)), 0.0; Mass (M (L 3)), 1.77705;
Mass (M (U 1)), 5.0e-3; Mass (M (D 1)), 3.0e-3;
Mass (M (U 2)), 1.2; Mass (M (D 2)), 0.1;
Mass (M (U 3)), 174.0; Mass (M (D 3)), 4.2 ]
(* \begin{subequations}
\begin{align}
e &= \sqrt{4\pi\alpha} \\
\sin\theta_w &= \sqrt{\sin^2\theta_w} \\
\cos\theta_w &= \sqrt{1-\sin^2\theta_w} \\
g &= \frac{e}{\sin\theta_w} \\
m_W &= \cos\theta_w m_Z \\
v &= \frac{2m_W}{g} \\
g_{CC} =
-\frac{g}{2\sqrt2} &= -\frac{e}{2\sqrt2\sin\theta_w} \\
Q_{\text{lepton}} =
-q_{\text{lepton}}e &= e \\
Q_{\text{up}} =
-q_{\text{up}}e &= -\frac{2}{3}e \\
Q_{\text{down}} =
-q_{\text{down}}e &= \frac{1}{3}e \\
\ii q_We =
\ii g_{\gamma WW} &= \ii e \\
\ii g_{ZWW} &= \ii g \cos\theta_w \\
\ii g_{WWW} &= \ii g
\end{align}
\end{subequations} *)
let derived_parameters =
[ Real E, Sqrt (Prod [Integer 4; Atom Pi; Atom Alpha_QED]);
Real Sinthw, Sqrt (Atom Sin2thw);
Real Costhw, Sqrt (Diff (Integer 1, Atom Sin2thw));
Real G_weak, Quot (Atom E, Atom Sinthw);
Real (Mass (G Wp)), Prod [Atom Costhw; Atom (Mass (G Z))];
Real Vev, Quot (Prod [Integer 2; Atom (Mass (G Wp))], Atom G_weak);
Real Q_lepton, Atom E;
Real Q_up, Prod [Quot (Integer (-2), Integer 3); Atom E];
Real Q_down, Prod [Quot (Integer 1, Integer 3); Atom E];
Real G_CC, Neg (Quot (Atom G_weak, Prod [Integer 2; Sqrt (Integer 2)]));
Complex I_Q_W, Prod [I; Atom E];
Complex I_G_weak, Prod [I; Atom G_weak];
Complex I_G_ZWW, Prod [I; Atom G_weak; Atom Costhw] ]
(* \begin{equation}
- \frac{g}{2\cos\theta_w}
\end{equation} *)
let g_over_2_costh =
Quot (Neg (Atom G_weak), Prod [Integer 2; Atom Costhw])
(* \begin{subequations}
\begin{align}
- \frac{g}{2\cos\theta_w} g_V
&= - \frac{g}{2\cos\theta_w} (T_3 - 2 q \sin^2\theta_w) \\
- \frac{g}{2\cos\theta_w} g_A
&= - \frac{g}{2\cos\theta_w} T_3
\end{align}
\end{subequations} *)
let nc_coupling c t3 q =
(Real_Array c,
[Prod [g_over_2_costh; Diff (t3, Prod [Integer 2; q; Atom Sin2thw])];
Prod [g_over_2_costh; t3]])
let half = Quot (Integer 1, Integer 2)
let derived_parameter_arrays =
[ nc_coupling G_NC_neutrino half (Integer 0);
nc_coupling G_NC_lepton (Neg half) (Integer (-1));
nc_coupling G_NC_up half (Quot (Integer 2, Integer 3));
nc_coupling G_NC_down (Neg half) (Quot (Integer (-1), Integer 3)) ]
let parameters () =
{ input = input_parameters;
derived = derived_parameters;
derived_arrays = derived_parameter_arrays }
module F = Modeltools.Fusions (struct
type f = flavor
type c = constant
let compare = compare
let conjugate = conjugate
end)
(* \begin{equation}
\mathcal{L}_{\textrm{EM}} =
- e \sum_i q_i \bar\psi_i\fmslash{A}\psi_i
\end{equation} *)
let mgm ((m1, g, m2), fbf, c) = ((M m1, G g, M m2), fbf, c)
let mom ((m1, o, m2), fbf, c) = ((M m1, O o, M m2), fbf, c)
let electromagnetic_currents n =
List.map mgm
[ ((L (-n), Ga, L n), FBF (1, Psibar, V, Psi), Q_lepton);
((U (-n), Ga, U n), FBF (1, Psibar, V, Psi), Q_up);
((D (-n), Ga, D n), FBF (1, Psibar, V, Psi), Q_down) ]
let color_currents n =
List.map mgm
[ ((U (-n), Gl, U n), FBF ((-1), Psibar, V, Psi), Gs);
((D (-n), Gl, D n), FBF ((-1), Psibar, V, Psi), Gs) ]
(* \begin{equation}
\mathcal{L}_{\textrm{NC}} =
- \frac{g}{2\cos\theta_W}
\sum_i \bar\psi_i\fmslash{Z}(g_V^i-g_A^i\gamma_5)\psi_i
\end{equation} *)
let neutral_currents n =
List.map mgm
[ ((L (-n), Z, L n), FBF (1, Psibar, VA, Psi), G_NC_lepton);
((N (-n), Z, N n), FBF (1, Psibar, VA, Psi), G_NC_neutrino);
((U (-n), Z, U n), FBF (1, Psibar, VA, Psi), G_NC_up);
((D (-n), Z, D n), FBF (1, Psibar, VA, Psi), G_NC_down) ]
(* \begin{equation}
\mathcal{L}_{\textrm{CC}} =
- \frac{g}{2\sqrt2} \sum_i \bar\psi_i
(T^+\fmslash{W}^+ + T^-\fmslash{W}^-)(1-\gamma_5)\psi_i
\end{equation} *)
let charged_currents' n =
List.map mgm
[ ((L (-n), Wm, N n), FBF (1, Psibar, VL, Psi), G_CC);
((N (-n), Wp, L n), FBF (1, Psibar, VL, Psi), G_CC) ]
let charged_currents'' n =
List.map mgm
[ ((D (-n), Wm, U n), FBF (1, Psibar, VL, Psi), G_CC);
((U (-n), Wp, D n), FBF (1, Psibar, VL, Psi), G_CC) ]
let charged_currents_triv =
ThoList.flatmap charged_currents' [1;2;3] @
ThoList.flatmap charged_currents'' [1;2;3]
let charged_currents_ckm =
let charged_currents_2 n1 n2 =
List.map mgm
[ ((D (-n1), Wm, U n2), FBF (1, Psibar, VL, Psi), G_CCQ (n2,n1));
((U (-n1), Wp, D n2), FBF (1, Psibar, VL, Psi), G_CCQ (n1,n2)) ] in
ThoList.flatmap charged_currents' [1;2;3] @
List.flatten (Product.list2 charged_currents_2 [1;2;3] [1;2;3])
(* \begin{equation}
\mathcal{L}_{\textrm{TGC}} =
- e \partial_\mu A_\nu W_+^\mu W_-^\nu + \ldots
- e \cot\theta_w \partial_\mu Z_\nu W_+^\mu W_-^\nu + \ldots
\end{equation} *)
let tgc ((g1, g2, g3), t, c) = ((G g1, G g2, G g3), t, c)
let standard_triple_gauge =
List.map tgc
[ ((Ga, Wm, Wp), Gauge_Gauge_Gauge 1, I_Q_W);
((Z, Wm, Wp), Gauge_Gauge_Gauge 1, I_G_ZWW);
((Gl, Gl, Gl), Gauge_Gauge_Gauge 1, I_Gs)]
(* \begin{multline}
\mathcal{L}_{\textrm{TGC}}(g_1,\kappa)
= g_1 \mathcal{L}_T(V,W^+,W^-) \\
+ \frac{\kappa+g_1}{2} \Bigl(\mathcal{L}_T(W^-,V,W^+)
- \mathcal{L}_T(W^+,V,W^-)\Bigr)\\
+ \frac{\kappa-g_1}{2} \Bigl(\mathcal{L}_L(W^-,V,W^+)
- \mathcal{L}_T(W^+,V,W^-)\Bigr)
\end{multline} *)
(* \begin{dubious}
The whole thing in the LEP2 workshop notation:
\begin{multline}
\ii\mathcal{L}_{\textrm{TGC},V} / g_{WWV} = \\
g_1^V V^\mu (W^-_{\mu\nu}W^{+,\nu}-W^+_{\mu\nu}W^{-,\nu})
+ \kappa_V W^+_\mu W^-_\nu V^{\mu\nu}
+ \frac{\lambda_V}{m_W^2} V_{\mu\nu}
W^-_{\rho\mu} W^{+,\hphantom{\nu}\rho}_{\hphantom{+,}\nu} \\
+ \ii g_5^V \epsilon_{\mu\nu\rho\sigma}
\left( (\partial^\rho W^{-,\mu}) W^{+,\nu}
- W^{-,\mu}(\partial^\rho W^{+,\nu}) \right) V^\sigma \\
+ \ii g_4^V W^-_\mu W^+_\nu (\partial^\mu V^\nu + \partial^\nu V^\mu)
- \frac{\tilde\kappa_V}{2} W^-_\mu W^+_\nu \epsilon^{\mu\nu\rho\sigma}
V_{\rho\sigma}
- \frac{\tilde\lambda_V}{2m_W^2}
W^-_{\rho\mu} W^{+,\mu}_{\hphantom{+,\mu}\nu} \epsilon^{\nu\rho\alpha\beta}
V_{\alpha\beta}
\end{multline}
using the conventions of Itzykson and Zuber with $\epsilon^{0123} = +1$.
\end{dubious} *)
(* \begin{dubious}
This is equivalent to the notation of Hagiwara et al.~\cite{HPZH87}, if we
remember that they have opposite signs for~$g_{WWV}$:
\begin{multline}
\mathcal{L}_{WWV} / (-g_{WWV}) = \\
\ii g_1^V \left( W^\dagger_{\mu\nu} W^\mu
- W^\dagger_\mu W^\mu_{\hphantom{\mu}\nu} \right) V^\nu
+ \ii \kappa_V W^\dagger_\mu W_\nu V^{\mu\nu}
+ \ii \frac{\lambda_V}{m_W^2}
W^\dagger_{\lambda\mu} W^\mu_{\hphantom{\mu}\nu} V^{\nu\lambda} \\
- g_4^V W^\dagger_\mu W_\nu
\left(\partial^\mu V^\nu + \partial^\nu V^\mu \right)
+ g_5^V \epsilon^{\mu\nu\lambda\sigma}
\left( W^\dagger_\mu \stackrel{\leftrightarrow}{\partial_\lambda}
W_\nu \right) V_\sigma\\
+ \ii \tilde\kappa_V W^\dagger_\mu W_\nu \tilde{V}^{\mu\nu}
+ \ii\frac{\tilde\lambda_V}{m_W^2}
W^\dagger_{\lambda\mu} W^\mu_{\hphantom{\mu}\nu} \tilde{V}^{\nu\lambda}
\end{multline}
Here $V^\mu$ stands for either the photon or the~$Z$ field, $W^\mu$ is the
$W^-$ field, $W_{\mu\nu} = \partial_\mu W_\nu - \partial_\nu W_\mu$,
$V_{\mu\nu} = \partial_\mu V_\nu - \partial_\nu V_\mu$, and
$\tilde{V}_{\mu\nu} = \frac{1}{2} \epsilon_{\mu\nu\lambda\sigma}
V^{\lambda\sigma}$.
\end{dubious} *)
let anomalous_triple_gauge =
List.map tgc
[ ((Ga, Wm, Wp), Dim4_Vector_Vector_Vector_T (-1),
I_G1_AWW);
((Z, Wm, Wp), Dim4_Vector_Vector_Vector_T (-1),
I_G1_ZWW);
((Wm, Ga, Wp), Dim4_Vector_Vector_Vector_T 1,
I_G1_plus_kappa_minus_G4_AWW);
((Wm, Z, Wp), Dim4_Vector_Vector_Vector_T 1,
I_G1_plus_kappa_minus_G4_ZWW);
((Wp, Ga, Wm), Dim4_Vector_Vector_Vector_T (-1),
I_G1_plus_kappa_plus_G4_AWW);
((Wp, Z, Wm), Dim4_Vector_Vector_Vector_T (-1),
I_G1_plus_kappa_plus_G4_ZWW);
((Wm, Ga, Wp), Dim4_Vector_Vector_Vector_L (-1),
I_G1_minus_kappa_plus_G4_AWW);
((Wm, Z, Wp), Dim4_Vector_Vector_Vector_L (-1),
I_G1_minus_kappa_plus_G4_ZWW);
((Wp, Ga, Wm), Dim4_Vector_Vector_Vector_L 1,
I_G1_minus_kappa_minus_G4_AWW);
((Wp, Z, Wm), Dim4_Vector_Vector_Vector_L 1,
I_G1_minus_kappa_minus_G4_ZWW);
((Ga, Wm, Wp), Dim4_Vector_Vector_Vector_L5 (-1),
I_kappa5_AWW);
((Z, Wm, Wp), Dim4_Vector_Vector_Vector_L5 (-1),
I_kappa5_ZWW);
((Ga, Wm, Wp), Dim4_Vector_Vector_Vector_T5 (-1),
G5_AWW);
((Z, Wm, Wp), Dim4_Vector_Vector_Vector_T5 (-1),
G5_ZWW);
((Ga, Wp, Wm), Dim6_Gauge_Gauge_Gauge (-1),
I_lambda_AWW);
((Z, Wp, Wm), Dim6_Gauge_Gauge_Gauge (-1),
I_lambda_ZWW);
((Ga, Wp, Wm), Dim6_Gauge_Gauge_Gauge_5 (-1),
I_lambda5_AWW);
((Z, Wp, Wm), Dim6_Gauge_Gauge_Gauge_5 (-1),
I_lambda5_ZWW) ]
let triple_gauge =
if Flags.triple_anom then
anomalous_triple_gauge
else
standard_triple_gauge
(* \begin{equation}
\mathcal{L}_{\textrm{QGC}} =
- g^2 W_{+,\mu} W_{-,\nu} W_+^\mu W_-^\nu + \ldots
\end{equation} *)
(* Actually, quartic gauge couplings are a little bit more straightforward
using auxiliary fields. Here we have to impose the antisymmetry manually:
\begin{subequations}
\begin{multline}
(W^{+,\mu}_1 W^{-,\nu}_2 - W^{+,\nu}_1 W^{-,\mu}_2)
(W^+_{3,\mu} W^-_{4,\nu} - W^+_{3,\nu} W^-_{4,\mu}) \\
= 2(W^+_1W^+_3)(W^-_2W^-_4) - 2(W^+_1W^-_4)(W^-_2W^+_3)
\end{multline}
also ($V$ can be $A$ or $Z$)
\begin{multline}
(W^{+,\mu}_1 V^\nu_2 - W^{+,\nu}_1 V^\mu_2)
(W^-_{3,\mu} V_{4,\nu} - W^-_{3,\nu} V_{4,\mu}) \\
= 2(W^+_1W^-_3)(V_2V_4) - 2(W^+_1V_4)(V_2W^-_3)
\end{multline}
\end{subequations} *)
(* \begin{subequations}
\begin{multline}
W^{+,\mu} W^{-,\nu} W^+_\mu W^-_\nu
\end{multline}
\end{subequations} *)
let qgc ((g1, g2, g3, g4), t, c) = ((G g1, G g2, G g3, G g4), t, c)
let gauge4 = Vector4 [(2, C_13_42); (-1, C_12_34); (-1, C_14_23)]
let minus_gauge4 = Vector4 [(-2, C_13_42); (1, C_12_34); (1, C_14_23)]
let standard_quartic_gauge =
List.map qgc
[ (Wm, Wp, Wm, Wp), gauge4, G_WWWW;
(Wm, Z, Wp, Z), minus_gauge4, G_ZZWW;
(Wm, Z, Wp, Ga), minus_gauge4, G_AZWW;
(Wm, Ga, Wp, Ga), minus_gauge4, G_AAWW;
(Gl, Gl, Gl, Gl), gauge4, G2 ]
(* \begin{subequations}
\begin{align}
\mathcal{L}_4
&= \alpha_4 \left( \frac{g^4}{2}\left( (W^+_\mu W^{-,\mu})^2
+ W^+_\mu W^{+,\mu} W^-_\mu W^{-,\mu}
\right)\right.\notag \\
&\qquad\qquad\qquad \left.
+ \frac{g^4}{\cos^2\theta_w} W^+_\mu Z^\mu W^-_\nu Z^\nu
+ \frac{g^4}{4\cos^4\theta_w} (Z_\mu Z^\mu)^2 \right) \\
\mathcal{L}_5
&= \alpha_5 \left( g^4 (W^+_\mu W^{-,\mu})^2
+ \frac{g^4}{\cos^2\theta_w} W^+_\mu W^{-,\mu} Z_\nu Z^\nu
+ \frac{g^4}{4\cos^4\theta_w} (Z_\mu Z^\mu)^2 \right)
\end{align}
\end{subequations}
or
\begin{multline}
\mathcal{L}_4 + \mathcal{L}_5
= (\alpha_4+2\alpha_5) g^4 \frac{1}{2} (W^+_\mu W^{-,\mu})^2 \\
+ 2\alpha_4 g^4 \frac{1}{4} W^+_\mu W^{+,\mu} W^-_\mu W^{-,\mu}
+ \alpha_4 \frac{g^4}{\cos^2\theta_w} W^+_\mu Z^\mu W^-_\nu Z^\nu \\
+ 2\alpha_5 \frac{g^4}{\cos^2\theta_w} \frac{1}{2} W^+_\mu W^{-,\mu} Z_\nu Z^\nu
+ (2\alpha_4 + 2\alpha_5) \frac{g^4}{\cos^4\theta_w} \frac{1}{8} (Z_\mu Z^\mu)^2
\end{multline}
and therefore
\begin{subequations}
\begin{align}
\alpha_{(WW)_0} &= (\alpha_4+2\alpha_5) g^4 \\
\alpha_{(WW)_2} &= 2\alpha_4 g^4 \\
\alpha_{(WZ)_0} &= 2\alpha_5 \frac{g^4}{\cos^2\theta_w} \\
\alpha_{(WZ)_1} &= \alpha_4 \frac{g^4}{\cos^2\theta_w} \\
\alpha_{ZZ} &= (2\alpha_4 + 2\alpha_5) \frac{g^4}{\cos^4\theta_w}
\end{align}
\end{subequations} *)
let anomalous_quartic_gauge =
if Flags.quartic_anom then
List.map qgc
[ ((Wm, Wm, Wp, Wp),
Vector4 [(1, C_13_42); (1, C_14_23)], Alpha_WWWW0);
((Wm, Wm, Wp, Wp),
Vector4 [1, C_12_34], Alpha_WWWW2);
((Wm, Wp, Z, Z),
Vector4 [1, C_12_34], Alpha_ZZWW0);
((Wm, Wp, Z, Z),
Vector4 [(1, C_13_42); (1, C_14_23)], Alpha_ZZWW1);
((Z, Z, Z, Z),
Vector4 [(1, C_12_34); (1, C_13_42); (1, C_14_23)], Alpha_ZZZZ) ]
else
[]
(* In any diagonal channel~$\chi$, the scattering amplitude~$a_\chi(s)$ is
unitary iff\footnote{%
Trivial proof:
\begin{equation}
-1 = \textrm{Im}\left(\frac{1}{a_\chi(s)}\right)
= \frac{\textrm{Im}(a_\chi^*(s))}{ |a_\chi(s)|^2 }
= - \frac{\textrm{Im}(a_\chi(s))}{ |a_\chi(s)|^2 }
\end{equation}
i.\,e.~$\textrm{Im}(a_\chi(s)) = |a_\chi(s)|^2$.}
\begin{equation}
\textrm{Im}\left(\frac{1}{a_\chi(s)}\right) = -1
\end{equation}
For a real perturbative scattering amplitude~$r_\chi(s)$ this can be
enforced easily--and arbitrarily--by
\begin{equation}
\frac{1}{a_\chi(s)} = \frac{1}{r_\chi(s)} - \mathrm{i}
\end{equation}
*)
let k_matrix_quartic_gauge =
if Flags.k_matrix then
List.map qgc
[ ((Wm, Wp, Wm, Wp), Vector4_K_Matrix_jr (0,
[(1, C_12_34)]), D_Alpha_WWWW0_S);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_jr (0,
[(1, C_14_23)]), D_Alpha_WWWW0_T);
((Wm, Wp, Wm, Wp), Vector4_K_Matrix_jr (0,
[(1, C_13_42)]), D_Alpha_WWWW0_U);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_jr (0,
[(1, C_12_34)]), D_Alpha_WWWW0_S);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_jr (0,
[(1, C_14_23)]), D_Alpha_WWWW0_T);
((Wp, Wm, Wp, Wm), Vector4_K_Matrix_jr (0,
[(1, C_13_42)]), D_Alpha_WWWW0_U);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_jr (0,
[(1, C_12_34)]), D_Alpha_WWWW2_S);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_jr (0,
[(1, C_13_42); (1, C_14_23)]), D_Alpha_WWWW2_T);
((Wm, Wp, Z, Z), Vector4_K_Matrix_jr (0,
[(1, C_12_34)]), D_Alpha_ZZWW0_S);
((Wm, Wp, Z, Z), Vector4_K_Matrix_jr (0,
[(1, C_13_42); (1, C_14_23)]), D_Alpha_ZZWW0_T);
((Wm, Z, Wp, Z), Vector4_K_Matrix_jr (0,
[(1, C_12_34)]), D_Alpha_ZZWW1_S);
((Wm, Z, Wp, Z), Vector4_K_Matrix_jr (0,
[(1, C_13_42)]), D_Alpha_ZZWW1_T);
((Wm, Z, Wp, Z), Vector4_K_Matrix_jr (0,
[(1, C_14_23)]), D_Alpha_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_jr (1,
[(1, C_12_34)]), D_Alpha_ZZWW1_S);
((Wp, Z, Z, Wm), Vector4_K_Matrix_jr (1,
[(1, C_13_42)]), D_Alpha_ZZWW1_U);
((Wp, Z, Z, Wm), Vector4_K_Matrix_jr (1,
[(1, C_14_23)]), D_Alpha_ZZWW1_T);
((Z, Wp, Wm, Z), Vector4_K_Matrix_jr (2,
[(1, C_12_34)]), D_Alpha_ZZWW1_S);
((Z, Wp, Wm, Z), Vector4_K_Matrix_jr (2,
[(1, C_13_42)]), D_Alpha_ZZWW1_U);
((Z, Wp, Wm, Z), Vector4_K_Matrix_jr (2,
[(1, C_14_23)]), D_Alpha_ZZWW1_T);
((Z, Z, Z, Z), Vector4_K_Matrix_jr (0,
[(1, C_12_34)]), D_Alpha_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_jr (0,
[(1, C_13_42); (1, C_14_23)]), D_Alpha_ZZZZ_T);
((Z, Z, Z, Z), Vector4_K_Matrix_jr (3,
[(1, C_14_23)]), D_Alpha_ZZZZ_S);
((Z, Z, Z, Z), Vector4_K_Matrix_jr (3,
[(1, C_13_42); (1, C_12_34)]), D_Alpha_ZZZZ_T)]
else
[]
(*i Thorsten's original implementation of the K matrix, which we keep since
it still might be usefull for the future.
let k_matrix_quartic_gauge =
if Flags.k_matrix then
List.map qgc
[ ((Wm, Wp, Wm, Wp), Vector4_K_Matrix_tho (0, [K_Matrix_Coeff 0,
K_Matrix_Pole 0]), Alpha_WWWW0);
((Wm, Wm, Wp, Wp), Vector4_K_Matrix_tho (0, [K_Matrix_Coeff 2,
K_Matrix_Pole 2]), Alpha_WWWW2);
((Wm, Wp, Z, Z), Vector4_K_Matrix_tho (0, [(K_Matrix_Coeff 0,
K_Matrix_Pole 0); (K_Matrix_Coeff 2,
K_Matrix_Pole 2)]), Alpha_ZZWW0);
((Wm, Z, Wp, Z), Vector4_K_Matrix_tho (0, [K_Matrix_Coeff 1,
K_Matrix_Pole 1]), Alpha_ZZWW1);
((Z, Z, Z, Z), Vector4_K_Matrix_tho (0, [K_Matrix_Coeff 0,
K_Matrix_Pole 0]), Alpha_ZZZZ) ]
else
[]
i*)
let quartic_gauge =
standard_quartic_gauge @ anomalous_quartic_gauge @ k_matrix_quartic_gauge
(* WK's couplings (apparently, he still intends to divide by
$\Lambda^2_{\text{EWSB}}=16\pi^2v_{\mathrm{F}}^2$):
with
\begin{equation}
V_{\mu} V_{\nu} =
\frac{1}{2} \left( W^+_{\mu} W^-_{\nu} + W^+_{\nu} W^-_{\mu} \right)
+ \frac{1}{2\cos^2\theta_{w}} Z_{\mu} Z_{\nu}
\end{equation}
(note the symmetrization!), i.\,e.
\begin{subequations}
\begin{align}
\mathcal{L}_4 &= \alpha_4 \frac{g^4v_{\mathrm{F}}^4}{16} (V_{\mu} V_{\nu})^2 \\
\mathcal{L}_5 &= \alpha_5 \frac{g^4v_{\mathrm{F}}^4}{16} (V_{\mu} V^{\mu})^2
\end{align}
\end{subequations} *)
let goldstone_vertices =
[ ((O Phi0, G Wm, G Wp), Scalar_Vector_Vector 1, I_G_ZWW);
((O Phip, G Ga, G Wm), Scalar_Vector_Vector 1, I_Q_W);
((O Phip, G Z, G Wm), Scalar_Vector_Vector 1, I_G_ZWW);
((O Phim, G Wp, G Ga), Scalar_Vector_Vector 1, I_Q_W);
((O Phim, G Wp, G Z), Scalar_Vector_Vector 1, I_G_ZWW) ]
(* New Resonances *)
(*
\begin{dubious}
There is an extra minus in the Lagrangian to have the same sign as
HWW or HZZ vertex.
Effectivly this doesn't matter for VBS, because $(-1)^2=1$.
This is only for completeness.
\end{dubious}
\begin{subequations}
\begin{align}
\mathbf{V}_\mu &= -\mathrm{i} g\mathbf{W}_\mu+\mathrm{i} g^\prime\mathbf{B}_\mu \\
\mathbf{W}_\mu &= W_\mu^a\frac{\tau^a}{2} \\
\mathbf{B}_\mu &= W_\mu^a\frac{\tau^3}{2} \\
\tau^{++}&= \tau^+ \otimes \tau^+ \\
\tau^+ &= \frac{1}{2} \left (\tau^+ \otimes \tau^3 + \tau^3+\tau^+ \right ) \\
\tau^0 &= \frac{1}{\sqrt{6}} \left (\tau^3\otimes\tau^3 -\tau^+ \otimes \tau^- - \tau^-+\tau^+ \right ) \\
\tau^- &= \frac{1}{2} \left (\tau^- \otimes \tau^3 + \tau^3+\tau^- \right ) \\
\tau^{--}&= \tau^- \otimes \tau^-
\end{align}
\end{subequations}
*)
(* Scalar Isoscalar
\begin{equation}
\mathcal{L}_{\sigma}=
-\frac{g_\sigma v}{2} \text{tr}
\left\lbrack \mathbf{V}_\mu \mathbf{V}^\mu \right\rbrack \sigma
\end{equation}
*)
let rsigma3 =
[ ((O Rsigma, G Wp, G Wm), Scalar_Vector_Vector 1, G_SWW);
((O Rsigma, G Z, G Z), Scalar_Vector_Vector 1, G_SZZ) ]
let rsigma3t =
[ ((O Rsigma, G Wp, G Wm), Scalar_Vector_Vector_t 1, G_SWW_T);
((O Rsigma, G Z, G Z), Scalar_Vector_Vector_t 1, G_SZZ_T) ]
let rsigma4 =
[ (O Rsigma, O Rsigma, G Wp, G Wm), Scalar2_Vector2 1, G_SSWW;
(O Rsigma, O Rsigma, G Z, G Z), Scalar2_Vector2 1, G_SSZZ ]
(* Scalar Isotensor
\begin{subequations}
\begin{align}
\mathcal{L}_{\phi}&=
\frac{g_\phi v}{4} \text{Tr}
\left \lbrack \left ( \mathbf{V}_\mu \otimes \mathbf{V}^\mu - \frac{\tau^{aa}}{6} \text{Tr} \left \lbrack \mathbf{V}_\mu \mathbf{V}^\mu \right \rbrack\right ) {\mathbf{\phi}} \right \rbrack\\
\phi&=\sqrt{2} \left (\phi^{++}\tau^{++}+\phi^+\tau^++\phi^0\tau^0+\phi^-\tau^- + \phi^{--}\tau^{--} \right )
\end{align}
\end{subequations}
*)
let rphi3 =
[ ((O Rphin, G Wp, G Wm), Scalar_Vector_Vector 1, G_PNWW);
((O Rphin, G Z, G Z), Scalar_Vector_Vector 1, G_PNZZ) ;
((O Rphip, G Z, G Wm), Scalar_Vector_Vector 1, G_PWZ) ;
((O Rphipp, G Wm, G Wm), Scalar_Vector_Vector 1, G_PWW) ;
((O Rphim, G Wp, G Z), Scalar_Vector_Vector 1, G_PWZ) ;
((O Rphimm, G Wp, G Wp), Scalar_Vector_Vector 1, G_PWW) ]
(* Tensor IsoScalar
*)
let rf3 =
[ ((O Rf, G Wp, G Wm), Tensor_2_Vector_Vector_1 1, G_FWW);
((O Rf, G Z, G Z), Tensor_2_Vector_Vector_1 1, G_FZZ) ]
let rf3t =
[ ((O Rf, G Wp, G Wm), Tensor_2_Vector_Vector_t 1, G_FWW_T);
((O Rf, G Z, G Z), Tensor_2_Vector_Vector_t 1, G_FZZ_T) ]
(* Tensor Isotensor
\begin{subequations}
\begin{align}
\mathcal{L}_{t}
\end{align}
\end{subequations}
*)
let rt3 =
[ ((O Rtn, G Wp, G Wm), Tensor_2_Vector_Vector_1 1, G_TNWW);
((O Rtn, G Z, G Z), Tensor_2_Vector_Vector_1 1, G_TNZZ) ;
((O Rtp, G Z, G Wm), Tensor_2_Vector_Vector_1 1, G_TWZ) ;
((O Rtpp, G Wm, G Wm), Tensor_2_Vector_Vector_1 1, G_TWW) ;
((O Rtm, G Wp, G Z), Tensor_2_Vector_Vector_1 1, G_TWZ) ;
((O Rtmm, G Wp, G Wp), Tensor_2_Vector_Vector_1 1, G_TWW) ]
(* Anomalous trilinear interactions $f_i f_j V$ :
\begin{equation}
\Delta\mathcal{L}_{tt\gamma} =
- e \frac{\upsilon}{\Lambda^2}
\bar{t} i\sigma^{\mu\nu} k_\nu (d_V(k^2) + i d_A(k^2) \gamma_5) t A_\mu
\end{equation} *)
let anomalous_ttA =
if Flags.top_anom then
[ ((M (U (-3)), G Ga, M (U 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_ttA) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{bb\gamma} =
- e \frac{\upsilon}{\Lambda^2}
\bar{b} i\sigma^{\mu\nu} k_\nu (d_V(k^2) + i d_A(k^2) \gamma_5) b A_\mu
\end{equation} *)
let anomalous_bbA =
if Flags.top_anom then
[ ((M (D (-3)), G Ga, M (D 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_bbA) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{ttg} =
- g_s \frac{\upsilon}{\Lambda^2}
\bar{t}\lambda^a i\sigma^{\mu\nu}k_\nu
(d_V(k^2)+id_A(k^2)\gamma_5)tG^a_\mu
\end{equation} *)
let anomalous_ttG =
if Flags.top_anom then
[ ((M (U (-3)), G Gl, M (U 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_ttG) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{ttZ} =
- \frac{g}{2 c_W} \frac{\upsilon^2}{\Lambda^2}\left\lbrack
\bar{t} \fmslash{Z} (X_L(k^2) P_L + X_R(k^2) P_R) t
+ \bar{t}\frac{i\sigma^{\mu\nu}k_\nu}{m_Z}
(d_V(k^2)+id_A(k^2)\gamma_5)tZ_\mu\right\rbrack
\end{equation} *)
let anomalous_ttZ =
if Flags.top_anom then
[ ((M (U (-3)), G Z, M (U 3)), FBF (1, Psibar, VLRM, Psi), G_VLR_ttZ);
((M (U (-3)), G Z, M (U 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_ttZ) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{bbZ} =
- \frac{g}{2 c_W} \frac{\upsilon^2}{\Lambda^2}
\bar{b}\frac{i\sigma^{\mu\nu}k_\nu}{m_Z}
(d_V(k^2)+id_A(k^2)\gamma_5)bZ_\mu
\end{equation} *)
let anomalous_bbZ =
if Flags.top_anom then
[ ((M (D (-3)), G Z, M (D 3)), FBF (1, Psibar, TVAM, Psi), G_TVA_bbZ) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{tbW} =
- \frac{g}{\sqrt{2}} \frac{\upsilon^2}{\Lambda^2}\left\lbrack
\bar{b}\fmslash{W}^-(V_L(k^2) P_L+V_R(k^2) P_R) t
+ \bar{b}\frac{i\sigma^{\mu\nu}k_\nu}{m_W}
(g_L(k^2)P_L+g_R(k^2)P_R)tW^-_\mu\right\rbrack
+ \textnormal{H.c.}
\end{equation} *)
let anomalous_tbW =
if Flags.top_anom then
[ ((M (D (-3)), G Wm, M (U 3)), FBF (1, Psibar, VLRM, Psi), G_VLR_btW);
((M (U (-3)), G Wp, M (D 3)), FBF (1, Psibar, VLRM, Psi), G_VLR_tbW);
((M (D (-3)), G Wm, M (U 3)), FBF (1, Psibar, TLRM, Psi), G_TLR_btW);
((M (U (-3)), G Wp, M (D 3)), FBF (1, Psibar, TRLM, Psi), G_TRL_tbW) ]
else
[]
(* quartic fermion-gauge interactions $f_i f_j V_1 V_2$ emerging from gauge-invariant
effective operators:
\begin{equation}
\Delta\mathcal{L}_{ttgg} =
- \frac{g_s^2}{2} f_{abc} \frac{\upsilon}{\Lambda^2}
\bar{t} \lambda^a \sigma^{\mu\nu}
(d_V(k^2)+id_A(k^2)\gamma_5)t G^b_\mu G^c_\nu
\end{equation} *)
let anomalous_ttGG =
if Flags.top_anom then
[ ((M (U (-3)), O (Aux_top (2,1,0,true,TTGG)), M (U 3)), FBF (1, Psibar, TVA, Psi), G_TVA_ttGG);
((O (Aux_top (2,1,0,false,TTGG)), G Gl, G Gl), Aux_Gauge_Gauge 1, I_Gs) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{tbWA} =
- i\sin\theta_w \frac{g^2}{2\sqrt{2}} \frac{\upsilon^2}{\Lambda^2}\left\lbrack
\bar{b}\frac{\sigma^{\mu\nu}}{m_W}
(g_L(k^2)P_L+g_R(k^2)P_R)t A_\mu W^-_\nu \right\rbrack
+ \textnormal{H.c.}
\end{equation} *)
let anomalous_tbWA =
if Flags.top_anom then
[ ((M (D (-3)), O (Aux_top (2,0,-1,true,TBWA)), M (U 3)), FBF (1, Psibar, TLR, Psi), G_TLR_btWA);
((O (Aux_top (2,0,1,false,TBWA)), G Ga, G Wm), Aux_Gauge_Gauge 1, I_G_weak);
((M (U (-3)), O (Aux_top (2,0,1,true,TBWA)), M (D 3)), FBF (1, Psibar, TRL, Psi), G_TRL_tbWA);
((O (Aux_top (2,0,-1,false,TBWA)), G Wp, G Ga), Aux_Gauge_Gauge 1, I_G_weak) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{tbWZ} =
- i\cos\theta_w \frac{g^2}{2\sqrt{2}} \frac{\upsilon^2}{\Lambda^2}\left\lbrack
\bar{b}\frac{\sigma^{\mu\nu}}{m_W}
(g_L(k^2)P_L+g_R(k^2)P_R)t Z_\mu W^-_\nu \right\rbrack
+ \textnormal{H.c.}
\end{equation} *)
let anomalous_tbWZ =
if Flags.top_anom then
[ ((M (D (-3)), O (Aux_top (2,0,-1,true,TBWZ)), M (U 3)), FBF (1, Psibar, TLR, Psi), G_TLR_btWZ);
((O (Aux_top (2,0,1,false,TBWZ)), G Z, G Wm), Aux_Gauge_Gauge 1, I_G_weak);
((M (U (-3)), O (Aux_top (2,0,1,true,TBWZ)), M (D 3)), FBF (1, Psibar, TRL, Psi), G_TRL_tbWZ);
((O (Aux_top (2,0,-1,false,TBWZ)), G Wp, G Z), Aux_Gauge_Gauge 1, I_G_weak) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{ttWW} =
- i \frac{g^2}{2} \frac{\upsilon^2}{\Lambda^2}
\bar{t} \frac{\sigma^{\mu\nu}}{m_W}
(d_V(k^2)+id_A(k^2)\gamma_5)t W^-_\mu W^+_\nu
\end{equation} *)
let anomalous_ttWW =
if Flags.top_anom then
[ ((M (U (-3)), O (Aux_top (2,0,0,true,TTWW)), M (U 3)), FBF (1, Psibar, TVA, Psi), G_TVA_ttWW);
((O (Aux_top (2,0,0,false,TTWW)), G Wm, G Wp), Aux_Gauge_Gauge 1, I_G_weak) ]
else
[]
(* \begin{equation}
\Delta\mathcal{L}_{bbWW} =
- i \frac{g^2}{2} \frac{\upsilon^2}{\Lambda^2}
\bar{b} \frac{\sigma^{\mu\nu}}{m_W}
(d_V(k^2)+id_A(k^2)\gamma_5)b W^-_\mu W^+_\nu
\end{equation} *)
let anomalous_bbWW =
if Flags.top_anom then
[ ((M (D (-3)), O (Aux_top (2,0,0,true,BBWW)), M (D 3)), FBF (1, Psibar, TVA, Psi), G_TVA_bbWW);
((O (Aux_top (2,0,0,false,BBWW)), G Wm, G Wp), Aux_Gauge_Gauge 1, I_G_weak) ]
else
[]
(* 4-fermion contact terms emerging from operator rewriting: *)
let anomalous_top_qGuG_tt =
[ ((M (U (-3)), O (Aux_top (1,1,0,true,QGUG)), M (U 3)), FBF (1, Psibar, VLR, Psi), G_VLR_qGuG) ]
let anomalous_top_qGuG_ff n =
List.map mom
[ ((U (-n), Aux_top (1,1,0,false,QGUG), U n), FBF (1, Psibar, V, Psi), Unit);
((D (-n), Aux_top (1,1,0,false,QGUG), D n), FBF (1, Psibar, V, Psi), Unit) ]
let anomalous_top_qGuG =
if Flags.top_anom_4f then
anomalous_top_qGuG_tt @ ThoList.flatmap anomalous_top_qGuG_ff [1;2;3]
else
[]
let anomalous_top_qBuB_tt =
[ ((M (U (-3)), O (Aux_top (1,0,0,true,QBUB)), M (U 3)), FBF (1, Psibar, VLR, Psi), G_VLR_qBuB) ]
let anomalous_top_qBuB_ff n =
List.map mom
[ ((U (-n), Aux_top (1,0,0,false,QBUB), U n), FBF (1, Psibar, VLR, Psi), G_VLR_qBuB_u);
((D (-n), Aux_top (1,0,0,false,QBUB), D n), FBF (1, Psibar, VLR, Psi), G_VLR_qBuB_d);
((L (-n), Aux_top (1,0,0,false,QBUB), L n), FBF (1, Psibar, VLR, Psi), G_VLR_qBuB_e);
((N (-n), Aux_top (1,0,0,false,QBUB), N n), FBF (1, Psibar, VL, Psi), G_VL_qBuB_n) ]
let anomalous_top_qBuB =
if Flags.top_anom_4f then
anomalous_top_qBuB_tt @ ThoList.flatmap anomalous_top_qBuB_ff [1;2;3]
else
[]
let anomalous_top_qW_tq =
[ ((M (U (-3)), O (Aux_top (1,0,0,true,QW)), M (U 3)), FBF (1, Psibar, VL, Psi), G_VL_qW);
((M (D (-3)), O (Aux_top (1,0,-1,true,QW)), M (U 3)), FBF (1, Psibar, VL, Psi), G_VL_qW);
((M (U (-3)), O (Aux_top (1,0,1,true,QW)), M (D 3)), FBF (1, Psibar, VL, Psi), G_VL_qW) ]
let anomalous_top_qW_ff n =
List.map mom
[ ((U (-n), Aux_top (1,0,0,false,QW), U n), FBF (1, Psibar, VL, Psi), G_VL_qW_u);
((D (-n), Aux_top (1,0,0,false,QW), D n), FBF (1, Psibar, VL, Psi), G_VL_qW_d);
((N (-n), Aux_top (1,0,0,false,QW), N n), FBF (1, Psibar, VL, Psi), G_VL_qW_u);
((L (-n), Aux_top (1,0,0,false,QW), L n), FBF (1, Psibar, VL, Psi), G_VL_qW_d);
((D (-n), Aux_top (1,0,-1,false,QW), U n), FBF (1, Psibar, VL, Psi), Half);
((U (-n), Aux_top (1,0,1,false,QW), D n), FBF (1, Psibar, VL, Psi), Half);
((L (-n), Aux_top (1,0,-1,false,QW), N n), FBF (1, Psibar, VL, Psi), Half);
((N (-n), Aux_top (1,0,1,false,QW), L n), FBF (1, Psibar, VL, Psi), Half) ]
let anomalous_top_qW =
if Flags.top_anom_4f then
anomalous_top_qW_tq @ ThoList.flatmap anomalous_top_qW_ff [1;2;3]
else
[]
let anomalous_top_DuDd =
if Flags.top_anom_4f then
[ ((M (U (-3)), O (Aux_top (0,0,0,true,DR)), M (U 3)), FBF (1, Psibar, SR, Psi), Half);
((M (U (-3)), O (Aux_top (0,0,0,false,DR)), M (U 3)), FBF (1, Psibar, SL, Psi), G_SL_DttR);
((M (D (-3)), O (Aux_top (0,0,0,false,DR)), M (D 3)), FBF (1, Psibar, SR, Psi), G_SR_DttR);
((M (U (-3)), O (Aux_top (0,0,0,true,DL)), M (U 3)), FBF (1, Psibar, SL, Psi), Half);
((M (D (-3)), O (Aux_top (0,0,0,false,DL)), M (D 3)), FBF (1, Psibar, SL, Psi), G_SL_DttL);
((M (D (-3)), O (Aux_top (0,0,-1,true,DR)), M (U 3)), FBF (1, Psibar, SR, Psi), Half);
((M (U (-3)), O (Aux_top (0,0,1,false,DR)), M (D 3)), FBF (1, Psibar, SLR, Psi), G_SLR_DbtR);
((M (D (-3)), O (Aux_top (0,0,-1,true,DL)), M (U 3)), FBF (1, Psibar, SL, Psi), Half);
((M (U (-3)), O (Aux_top (0,0,1,false,DL)), M (D 3)), FBF (1, Psibar, SL, Psi), G_SL_DbtL) ]
else
[]
let vertices3 =
(ThoList.flatmap electromagnetic_currents [1;2;3] @
ThoList.flatmap color_currents [1;2;3] @
ThoList.flatmap neutral_currents [1;2;3] @
(if Flags.ckm_present then
charged_currents_ckm
else
charged_currents_triv) @
triple_gauge @
goldstone_vertices @
rsigma3 @ rsigma3t @ rphi3 @ rf3 @ rf3t @ rt3 @
anomalous_ttA @ anomalous_bbA @
anomalous_ttZ @ anomalous_bbZ @
anomalous_tbW @ anomalous_tbWA @ anomalous_tbWZ @
anomalous_ttWW @ anomalous_bbWW @
anomalous_ttG @ anomalous_ttGG @
anomalous_top_qGuG @ anomalous_top_qBuB @
anomalous_top_qW @ anomalous_top_DuDd)
let vertices4 =
quartic_gauge @ rsigma4
let vertices () = (vertices3, vertices4, [])
(* For efficiency, make sure that [F.of_vertices vertices] is
evaluated only once. *)
let table = F.of_vertices (vertices ())
let fuse2 = F.fuse2 table
let fuse3 = F.fuse3 table
let fuse = F.fuse table
let max_degree () = 4
let flavor_of_string = function
| "e-" -> M (L 1) | "e+" -> M (L (-1))
| "mu-" -> M (L 2) | "mu+" -> M (L (-2))
| "tau-" -> M (L 3) | "tau+" -> M (L (-3))
| "nue" -> M (N 1) | "nuebar" -> M (N (-1))
| "numu" -> M (N 2) | "numubar" -> M (N (-2))
| "nutau" -> M (N 3) | "nutaubar" -> M (N (-3))
| "u" -> M (U 1) | "ubar" -> M (U (-1))
| "c" -> M (U 2) | "cbar" -> M (U (-2))
| "t" -> M (U 3) | "tbar" -> M (U (-3))
| "d" -> M (D 1) | "dbar" -> M (D (-1))
| "s" -> M (D 2) | "sbar" -> M (D (-2))
| "b" -> M (D 3) | "bbar" -> M (D (-3))
| "g" | "gl" -> G Gl
| "A" -> G Ga | "Z" | "Z0" -> G Z
| "W+" -> G Wp | "W-" -> G Wm
| "Rsigma" -> O Rsigma
| "Rphi0" -> O Rphin
| "Rphi+" -> O Rphip | "Rphi-" -> O Rphim
| "Rphi++" -> O Rphip | "Rphi--" -> O Rphimm
| "Rf" -> O Rf
| "Rt0" -> O Rtn
| "Rt+" -> O Rtp | "Rt-" -> O Rtm
| "Rt++" -> O Rtp | "Rt--" -> O Rtmm
| "Aux_t_ttGG0" -> O (Aux_top (2,1, 0,true,TTGG)) | "Aux_ttGG0" -> O (Aux_top (2,1, 0,false,TTGG))
| "Aux_t_tbWA+" -> O (Aux_top (2,0, 1,true,TBWA)) | "Aux_tbWA+" -> O (Aux_top (2,0, 1,false,TBWA))
| "Aux_t_tbWA-" -> O (Aux_top (2,0,-1,true,TBWA)) | "Aux_tbWA-" -> O (Aux_top (2,0,-1,false,TBWA))
| "Aux_t_tbWZ+" -> O (Aux_top (2,0, 1,true,TBWZ)) | "Aux_tbWZ+" -> O (Aux_top (2,0, 1,false,TBWZ))
| "Aux_t_tbWZ-" -> O (Aux_top (2,0,-1,true,TBWZ)) | "Aux_tbWZ-" -> O (Aux_top (2,0,-1,false,TBWZ))
| "Aux_t_ttWW0" -> O (Aux_top (2,0, 0,true,TTWW)) | "Aux_ttWW0" -> O (Aux_top (2,0, 0,false,TTWW))
| "Aux_t_bbWW0" -> O (Aux_top (2,0, 0,true,BBWW)) | "Aux_bbWW0" -> O (Aux_top (2,0, 0,false,BBWW))
| "Aux_t_qGuG0" -> O (Aux_top (1,1, 0,true,QGUG)) | "Aux_qGuG0" -> O (Aux_top (1,1, 0,false,QGUG))
| "Aux_t_qBuB0" -> O (Aux_top (1,0, 0,true,QBUB)) | "Aux_qBuB0" -> O (Aux_top (1,0, 0,false,QBUB))
| "Aux_t_qW0" -> O (Aux_top (1,0, 0,true,QW)) | "Aux_qW0" -> O (Aux_top (1,0, 0,false,QW))
| "Aux_t_qW+" -> O (Aux_top (1,0, 1,true,QW)) | "Aux_qW+" -> O (Aux_top (1,0, 1,false,QW))
| "Aux_t_qW-" -> O (Aux_top (1,0,-1,true,QW)) | "Aux_qW-" -> O (Aux_top (1,0,-1,false,QW))
| "Aux_t_dL0" -> O (Aux_top (0,0, 0,true,DL)) | "Aux_dL0" -> O (Aux_top (0,0, 0,false,DL))
| "Aux_t_dL+" -> O (Aux_top (0,0, 1,true,DL)) | "Aux_dL+" -> O (Aux_top (0,0, 1,false,DL))
| "Aux_t_dL-" -> O (Aux_top (0,0,-1,true,DL)) | "Aux_dL-" -> O (Aux_top (0,0,-1,false,DL))
| "Aux_t_dR0" -> O (Aux_top (0,0, 0,true,DR)) | "Aux_dR0" -> O (Aux_top (0,0, 0,false,DR))
| "Aux_t_dR+" -> O (Aux_top (0,0, 1,true,DR)) | "Aux_dR+" -> O (Aux_top (0,0, 1,false,DR))
| "Aux_t_dR-" -> O (Aux_top (0,0,-1,true,DR)) | "Aux_dR-" -> O (Aux_top (0,0,-1,false,DR))
| _ -> invalid_arg "Modellib_NoH.AltH.flavor_of_string"
let flavor_to_string = function
| M f ->
begin match f with
| L 1 -> "e-" | L (-1) -> "e+"
| L 2 -> "mu-" | L (-2) -> "mu+"
| L 3 -> "tau-" | L (-3) -> "tau+"
| L _ -> invalid_arg
"Modellib_NoH.AltH.flavor_to_string: invalid lepton"
| N 1 -> "nue" | N (-1) -> "nuebar"
| N 2 -> "numu" | N (-2) -> "numubar"
| N 3 -> "nutau" | N (-3) -> "nutaubar"
| N _ -> invalid_arg
"Modellib_NoH.AltH.flavor_to_string: invalid neutrino"
| U 1 -> "u" | U (-1) -> "ubar"
| U 2 -> "c" | U (-2) -> "cbar"
| U 3 -> "t" | U (-3) -> "tbar"
| U _ -> invalid_arg
"Modellib_NoH.AltH.flavor_to_string: invalid up type quark"
| D 1 -> "d" | D (-1) -> "dbar"
| D 2 -> "s" | D (-2) -> "sbar"
| D 3 -> "b" | D (-3) -> "bbar"
| D _ -> invalid_arg
"Modellib_NoH.AltH.flavor_to_string: invalid down type quark"
end
| G f ->
begin match f with
| Gl -> "gl"
| Ga -> "A" | Z -> "Z"
| Wp -> "W+" | Wm -> "W-"
end
| O f ->
begin match f with
| Phip -> "phi+" | Phim -> "phi-" | Phi0 -> "phi0"
| Rsigma -> "Rsigma"
| Rphin -> "Rphin" | Rphip -> "Rphi+" | Rphim -> "Rphi-"
| Rphipp -> "Rphi++" | Rphimm -> "Rphi--"
| Rf -> "Rf"
| Rtn -> "Rtn" | Rtp -> "Rt+" | Rtm -> "Rt-"
| Rtpp -> "Rt++" | Rtmm -> "Rt--"
| Aux_top (_,_,ch,n,v) -> "Aux_" ^ (if n then "t_" else "") ^ (
begin match v with
| TTGG -> "ttGG" | TBWA -> "tbWA" | TBWZ -> "tbWZ"
| TTWW -> "ttWW" | BBWW -> "bbWW"
| QGUG -> "qGuG" | QBUB -> "qBuB"
| QW -> "qW" | DL -> "dL" | DR -> "dR"
end ) ^ ( if ch > 0 then "+" else if ch < 0 then "-" else "0" )
end
let flavor_to_TeX = function
| M f ->
begin match f with
| L 1 -> "e^-" | L (-1) -> "e^+"
| L 2 -> "\\mu^-" | L (-2) -> "\\mu^+"
| L 3 -> "\\tau^-" | L (-3) -> "\\tau^+"
| L _ -> invalid_arg
"Modellib_NoH.AltH.flavor_to_TeX: invalid lepton"
| N 1 -> "\\nu_e" | N (-1) -> "\\bar{\\nu}_e"
| N 2 -> "\\nu_\\mu" | N (-2) -> "\\bar{\\nu}_\\mu"
| N 3 -> "\\nu_\\tau" | N (-3) -> "\\bar{\\nu}_\\tau"
| N _ -> invalid_arg
"Modellib_NoH.AltH.flavor_to_TeX: invalid neutrino"
| U 1 -> "u" | U (-1) -> "\\bar{u}"
| U 2 -> "c" | U (-2) -> "\\bar{c}"
| U 3 -> "t" | U (-3) -> "\\bar{t}"
| U _ -> invalid_arg
"Modellib_NoH.AltH.flavor_to_TeX: invalid up type quark"
| D 1 -> "d" | D (-1) -> "\\bar{d}"
| D 2 -> "s" | D (-2) -> "\\bar{s}"
| D 3 -> "b" | D (-3) -> "\\bar{b}"
| D _ -> invalid_arg
"Modellib_NoH.AltH.flavor_to_TeX: invalid down type quark"
end
| G f ->
begin match f with
| Gl -> "g"
| Ga -> "\\gamma" | Z -> "Z"
| Wp -> "W^+" | Wm -> "W^-"
end
| O f ->
begin match f with
| Phip -> "\\phi^+" | Phim -> "\\phi^-" | Phi0 -> "\\phi^0"
| Rsigma -> "\\sigma"
| Rphip -> "\\phi^+" | Rphim -> "\\phi^-" | Rphin -> "\\phi^0"
| Rphipp -> "\\phi^{++}" | Rphimm -> "\\phi^{--}"
| Rf -> "f"
| Rtp -> "t^+" | Rtm -> "t^-" | Rtn -> "t^0"
| Rtpp -> "t^{++}" | Rtmm -> "t^{--}"
| Aux_top (_,_,ch,n,v) -> "\\textnormal{Aux_" ^ (if n then "t_" else "") ^ (
begin match v with
| TTGG -> "ttGG" | TBWA -> "tbWA" | TBWZ -> "tbWZ"
| TTWW -> "ttWW" | BBWW -> "bbWW"
| QGUG -> "qGuG" | QBUB -> "qBuB"
| QW -> "qW" | DL -> "dL" | DR -> "dR"
end ) ^ ( if ch > 0 then "^+" else if ch < 0 then "^-" else "^0" ) ^ "}"
end
let flavor_symbol = function
| M f ->
begin match f with
| L n when n > 0 -> "l" ^ string_of_int n
| L n -> "l" ^ string_of_int (abs n) ^ "b"
| N n when n > 0 -> "n" ^ string_of_int n
| N n -> "n" ^ string_of_int (abs n) ^ "b"
| U n when n > 0 -> "u" ^ string_of_int n
| U n -> "u" ^ string_of_int (abs n) ^ "b"
| D n when n > 0 -> "d" ^ string_of_int n
| D n -> "d" ^ string_of_int (abs n) ^ "b"
end
| G f ->
begin match f with
| Gl -> "gl"
| Ga -> "a" | Z -> "z"
| Wp -> "wp" | Wm -> "wm"
end
| O f ->
begin match f with
| Phip -> "pp" | Phim -> "pm" | Phi0 -> "p0"
| Rsigma -> "rsi"
| Rphip -> "rpp" | Rphim -> "rpm" | Rphin -> "rpn"
| Rphipp -> "rppp" | Rphimm -> "rpmm"
| Rf -> "rf"
| Rtp -> "rtp" | Rtm -> "rtm" | Rtn -> "rtn"
| Rtpp -> "rtpp" | Rtmm -> "rtmm"
| Aux_top (_,_,ch,n,v) -> "aux_" ^ (if n then "t_" else "") ^ (
begin match v with
| TTGG -> "ttgg" | TBWA -> "tbwa" | TBWZ -> "tbwz"
| TTWW -> "ttww" | BBWW -> "bbww"
| QGUG -> "qgug" | QBUB -> "qbub"
| QW -> "qw" | DL -> "dl" | DR -> "dr"
end ) ^ "_" ^ ( if ch > 0 then "p" else if ch < 0 then "m" else "0" )
end
(* Introducing new Resonances from 45, there are no PDG values *)
let pdg = function
| M f ->
begin match f with
| L n when n > 0 -> 9 + 2*n
| L n -> - 9 + 2*n
| N n when n > 0 -> 10 + 2*n
| N n -> - 10 + 2*n
| U n when n > 0 -> 2*n
| U n -> 2*n
| D n when n > 0 -> - 1 + 2*n
| D n -> 1 + 2*n
end
| G f ->
begin match f with
| Gl -> 21
| Ga -> 22 | Z -> 23
| Wp -> 24 | Wm -> (-24)
end
| O f ->
begin match f with
| Phip | Phim -> 27 | Phi0 -> 26
| Rsigma -> 45
| Rphin -> 46 | Rphip | Rphim -> 47
| Rphipp | Rphimm -> 48
| Rf -> 52
| Rtn -> 53 | Rtp | Rtm -> 54
| Rtpp | Rtmm -> 55
| Aux_top (_,_,_,_,_) -> 81
end
let mass_symbol f =
"mass(" ^ string_of_int (abs (pdg f)) ^ ")"
let width_symbol f =
"width(" ^ string_of_int (abs (pdg f)) ^ ")"
let constant_symbol = function
| Unit -> "unit" | Half -> "half" | Pi -> "PI"
| Alpha_QED -> "alpha" | E -> "e" | G_weak -> "g" | Vev -> "vev"
| I_G_weak -> "ig"
| Sin2thw -> "sin2thw" | Sinthw -> "sinthw" | Costhw -> "costhw"
| Q_lepton -> "qlep" | Q_up -> "qup" | Q_down -> "qdwn"
| G_NC_lepton -> "gnclep" | G_NC_neutrino -> "gncneu"
| G_NC_up -> "gncup" | G_NC_down -> "gncdwn"
| G_TVA_ttA -> "gtva_tta" | G_TVA_bbA -> "gtva_bba"
| G_VLR_ttZ -> "gvlr_ttz" | G_TVA_ttZ -> "gtva_ttz" | G_TVA_bbZ -> "gtva_bbz"
| G_VLR_btW -> "gvlr_btw" | G_VLR_tbW -> "gvlr_tbw"
| G_TLR_btW -> "gtlr_btw" | G_TRL_tbW -> "gtrl_tbw"
| G_TLR_btWA -> "gtlr_btwa" | G_TRL_tbWA -> "gtrl_tbwa"
| G_TLR_btWZ -> "gtlr_btwz" | G_TRL_tbWZ -> "gtrl_tbwz"
| G_TVA_ttWW -> "gtva_ttww" | G_TVA_bbWW -> "gtva_bbww"
| G_TVA_ttG -> "gtva_ttg" | G_TVA_ttGG -> "gtva_ttgg"
| G_VLR_qGuG -> "gvlr_qgug"
| G_VLR_qBuB -> "gvlr_qbub"
| G_VLR_qBuB_u -> "gvlr_qbub_u" | G_VLR_qBuB_d -> "gvlr_qbub_d"
| G_VLR_qBuB_e -> "gvlr_qbub_e" | G_VL_qBuB_n -> "gvl_qbub_n"
| G_VL_qW -> "gvl_qw"
| G_VL_qW_u -> "gvl_qw_u" | G_VL_qW_d -> "gvl_qw_d"
| G_SL_DttR -> "gsl_dttr" | G_SR_DttR -> "gsr_dttr" | G_SL_DttL -> "gsl_dttl"
| G_SLR_DbtR -> "gslr_dbtr" | G_SL_DbtL -> "gsl_dbtl"
| G_CC -> "gcc"
| G_CCQ (n1,n2) -> "gccq" ^ string_of_int n1 ^ string_of_int n2
| I_Q_W -> "iqw" | I_G_ZWW -> "igzww"
| G_WWWW -> "gw4" | G_ZZWW -> "gzzww"
| G_AZWW -> "gazww" | G_AAWW -> "gaaww"
| I_G1_AWW -> "ig1a" | I_G1_ZWW -> "ig1z"
| I_G1_plus_kappa_plus_G4_AWW -> "ig1pkpg4a"
| I_G1_plus_kappa_plus_G4_ZWW -> "ig1pkpg4z"
| I_G1_plus_kappa_minus_G4_AWW -> "ig1pkmg4a"
| I_G1_plus_kappa_minus_G4_ZWW -> "ig1pkmg4z"
| I_G1_minus_kappa_plus_G4_AWW -> "ig1mkpg4a"
| I_G1_minus_kappa_plus_G4_ZWW -> "ig1mkpg4z"
| I_G1_minus_kappa_minus_G4_AWW -> "ig1mkmg4a"
| I_G1_minus_kappa_minus_G4_ZWW -> "ig1mkmg4z"
| I_lambda_AWW -> "ila"
| I_lambda_ZWW -> "ilz"
| G5_AWW -> "rg5a"
| G5_ZWW -> "rg5z"
| I_kappa5_AWW -> "ik5a"
| I_kappa5_ZWW -> "ik5z"
| I_lambda5_AWW -> "il5a" | I_lambda5_ZWW -> "il5z"
| Alpha_WWWW0 -> "alww0" | Alpha_WWWW2 -> "alww2"
| Alpha_ZZWW0 -> "alzw0" | Alpha_ZZWW1 -> "alzw1"
| Alpha_ZZZZ -> "alzz"
| D_Alpha_ZZWW0_S -> "dalzz0_s(gkm,mkm,"
| D_Alpha_ZZWW0_T -> "dalzz0_t(gkm,mkm,"
| D_Alpha_ZZWW1_S -> "dalzz1_s(gkm,mkm,"
| D_Alpha_ZZWW1_T -> "dalzz1_t(gkm,mkm,"
| D_Alpha_ZZWW1_U -> "dalzz1_u(gkm,mkm,"
| D_Alpha_WWWW0_S -> "dalww0_s(gkm,mkm,"
| D_Alpha_WWWW0_T -> "dalww0_t(gkm,mkm,"
| D_Alpha_WWWW0_U -> "dalww0_u(gkm,mkm,"
| D_Alpha_WWWW2_S -> "dalww2_s(gkm,mkm,"
| D_Alpha_WWWW2_T -> "dalww2_t(gkm,mkm,"
| D_Alpha_ZZZZ_S -> "dalz4_s(gkm,mkm,"
| D_Alpha_ZZZZ_T -> "dalz4_t(gkm,mkm,"
| G_SWW -> "gsww" | G_SZZ -> "gszz"
| G_SWW_T -> "gswwt" | G_SZZ_T -> "gszzt"
| G_PNWW -> "gpnww" | G_PNZZ -> "gpnzz"
| G_PWZ -> "gpwz" | G_PWW -> "gpww"
| G_FWW -> "gfww" | G_FZZ -> "gfzz"
| G_FWW_T -> "gfwwt" | G_FZZ_T -> "gfzzt"
| G_TNWW -> "gtnww" | G_TNZZ -> "gtnzz"
| G_TWZ -> "gtwz" | G_TWW -> "gtww"
| G_SSWW -> "gssww" | G_SSZZ -> "gsszz"
| Gs -> "gs" | I_Gs -> "igs" | G2 -> "gs**2"
| Mass f -> "mass" ^ flavor_symbol f
| Width f -> "width" ^ flavor_symbol f
| K_Matrix_Coeff i -> "kc" ^ string_of_int i
| K_Matrix_Pole i -> "kp" ^ string_of_int i
end
Index: trunk/omega/src/combinatorics.ml
===================================================================
--- trunk/omega/src/combinatorics.ml (revision 8899)
+++ trunk/omega/src/combinatorics.ml (revision 8900)
@@ -1,594 +1,590 @@
(* combinatorics.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-(* Avoid refering to [Pervasives.compare], because [Pervasives] will
- become [Stdlib.Pervasives] in O'Caml 4.07 and [Stdlib] in O'Caml 4.08. *)
-let pcompare = compare
-
type 'a seq = 'a list
(* \thocwmodulesection{Simple Combinatorial Functions} *)
let rec factorial' fn n =
if n < 1 then
fn
else
factorial' (n * fn) (pred n)
let factorial n =
let result = factorial' 1 n in
if result < 0 then
invalid_arg "Combinatorics.factorial overflow"
else
result
(* \begin{multline}
\binom{n}{k} = \frac{n!}{k!(n-k)!}
= \frac{n(n-1)\cdots(n-k+1)}{k(k-1)\cdots1} \\
= \frac{n(n-1)\cdots(k+1)}{(n-k)(n-k-1)\cdots1} =
\begin{cases}
B_{n-k+1}(n,k) & \text{for $k \le \lfloor n/2 \rfloor$} \\
B_{k+1}(n,n-k) & \text{for $k > \lfloor n/2 \rfloor$}
\end{cases}
\end{multline}
where
\begin{equation}
B_{n_{\min}}(n,k) =
\begin{cases}
n B_{n_{\min}}(n-1,k) & \text{for $n \ge n_{\min}$} \\
\frac{1}{k} B_{n_{\min}}(n,k-1) & \text{for $k > 1$} \\
1 & \text{otherwise}
\end{cases}
\end{equation} *)
let rec binomial' n_min n k acc =
if n >= n_min then
binomial' n_min (pred n) k (n * acc)
else if k > 1 then
binomial' n_min n (pred k) (acc / k)
else
acc
let binomial n k =
if k > n / 2 then
binomial' (k + 1) n (n - k) 1
else
binomial' (n - k + 1) n k 1
(* Overflows later, but takes much more time:
\begin{equation}
\binom{n}{k} = \binom{n-1}{k} + \binom{n-1}{k-1}
\end{equation} *)
let rec slow_binomial n k =
if n < 0 || k < 0 then
invalid_arg "Combinatorics.binomial"
else if k = 0 || k = n then
1
else
slow_binomial (pred n) k + slow_binomial (pred n) (pred k)
let multinomial n_list =
List.fold_left (fun acc n -> acc / (factorial n))
(factorial (List.fold_left (+) 0 n_list)) n_list
let symmetry l =
List.fold_left (fun s (n, _) -> s * factorial n) 1 (ThoList.classify l)
(* \thocwmodulesection{Partitions} *)
(* The inner steps of the recursion (i.\,e.~$n=1$) are expanded as follows
\begin{multline}
\ocwlowerid{split'}(1,\lbrack p_k;p_{k-1};\ldots;p_1\rbrack,
\lbrack x_l;x_{l-1};\ldots;x_1\rbrack,
\lbrack x_{l+1};x_{l+2};\ldots;x_m\rbrack ) = \\
\lbrack (\lbrack p_1;\ldots;p_k;x_{l+1}\rbrack,
\lbrack x_1;\ldots;x_l;x_{l+2};\ldots;x_m\rbrack); \qquad\qquad\qquad\\
(\lbrack p_1;\ldots;p_k;x_{l+2}\rbrack,
\lbrack x_1;\ldots;x_l;x_{l+1};x_{l+3}\ldots;x_m\rbrack);
\ldots; \\
(\lbrack p_1;\ldots;p_k;x_m\rbrack,
\lbrack x_1;\ldots;x_l;x_{l+1};\ldots;x_{m-1}\rbrack) \rbrack
\end{multline}
while the outer steps (i.\,e.~$n>1$) perform the same with one element
moved from the last argument to the first argument. At the $n$th level we have
\begin{multline}
\ocwlowerid{split'}(n,\lbrack p_k;p_{k-1};\ldots;p_1\rbrack,
\lbrack x_l;x_{l-1};\ldots;x_1\rbrack,
\lbrack x_{l+1};x_{l+2};\ldots;x_m\rbrack ) = \\
\lbrack (\lbrack p_1;\ldots;p_k;x_{l+1};x_{l+2};\ldots;x_{l+n}\rbrack,
\lbrack x_1;\ldots;x_l;x_{l+n+1};\ldots;x_m\rbrack); \ldots; \qquad\\
(\lbrack p_1;\ldots;p_k;x_{m-n+1};x_{m-n+2};\ldots;x_{m}\rbrack,
\lbrack x_1;\ldots;x_l;x_{l+1};\ldots;x_{m-n}\rbrack) \rbrack
\end{multline}
where the order of the~$\lbrack x_1;x_2;\ldots;x_m\rbrack$ is maintained in
the partitions. Variations on this multiple recursion idiom are used many
times below. *)
let rec split' n rev_part rev_head = function
| [] -> []
| x :: tail ->
let rev_part' = x :: rev_part
and parts = split' n rev_part (x :: rev_head) tail in
if n < 1 then
failwith "Combinatorics.split': can't happen"
else if n = 1 then
(List.rev rev_part', List.rev_append rev_head tail) :: parts
else
split' (pred n) rev_part' rev_head tail @ parts
(* Kick off the recursion for $0<n<|l|$ and handle the cases $n\in\{0,|l|\}$
explicitely. Use reflection symmetry for a small optimization. *)
let ordered_split_unsafe n abs_l l =
let abs_l = List.length l in
if n = 0 then
[[], l]
else if n = abs_l then
[l, []]
else if n <= abs_l / 2 then
split' n [] [] l
else
List.rev_map (fun (a, b) -> (b, a)) (split' (abs_l - n) [] [] l)
(* Check the arguments and call the workhorse: *)
let ordered_split n l =
let abs_l = List.length l in
if n < 0 || n > abs_l then
invalid_arg "Combinatorics.ordered_split"
else
ordered_split_unsafe n abs_l l
(* Handle equipartitions specially: *)
let split n l =
let abs_l = List.length l in
if n < 0 || n > abs_l then
invalid_arg "Combinatorics.split"
else begin
if 2 * n = abs_l then
match l with
| [] -> failwith "Combinatorics.split: can't happen"
| x :: tail ->
List.map (fun (p1, p2) -> (x :: p1, p2)) (split' (pred n) [] [] tail)
else
ordered_split_unsafe n abs_l l
end
(* If we chop off parts repeatedly, we can either keep permutations or
suppress them. Generically, [attach_to_fst] has type
\begin{quote}
[('a * 'b) list -> 'a list -> ('a list * 'b) list -> ('a list * 'b) list]
\end{quote}
and semantics
\begin{multline}
\ocwlowerid{attach\_to\_fst}
(\lbrack (a_1,b_1),(a_2,b_2),\ldots,(a_m,b_m)\rbrack,
\lbrack a'_1,a'_2,\ldots\rbrack) = \\
\lbrack (\lbrack a_1,a'_1,\ldots\rbrack, b_1),
(\lbrack a_2,a'_1,\ldots\rbrack, b_2),\ldots,
(\lbrack a_m,a'_1,\ldots\rbrack, b_m)\rbrack
\end{multline}
(where some of the result can be filtered out), assumed to be
prepended to the final argument. *)
let rec multi_split' attach_to_fst n size splits =
if n <= 0 then
splits
else
multi_split' attach_to_fst (pred n) size
(List.fold_left (fun acc (parts, tail) ->
attach_to_fst (ordered_split size tail) parts acc) [] splits)
let attach_to_fst_unsorted splits parts acc =
List.fold_left (fun acc' (p, rest) -> (p :: parts, rest) :: acc') acc splits
(* Similarly, if the secod argument is a list of lists: *)
let prepend_to_fst_unsorted splits parts acc =
List.fold_left (fun acc' (p, rest) -> (p @ parts, rest) :: acc') acc splits
let attach_to_fst_sorted splits parts acc =
match parts with
| [] -> List.fold_left (fun acc' (p, rest) -> ([p], rest) :: acc') acc splits
| p :: _ as parts ->
List.fold_left (fun acc' (p', rest) ->
if p' > p then
(p' :: parts, rest) :: acc'
else
acc') acc splits
let multi_split n size l =
multi_split' attach_to_fst_sorted n size [([], l)]
let ordered_multi_split n size l =
multi_split' attach_to_fst_unsorted n size [([], l)]
let rec partitions' splits = function
| [] -> List.map (fun (h, r) -> (List.rev h, r)) splits
| (1, size) :: more ->
partitions'
(List.fold_left (fun acc (parts, rest) ->
attach_to_fst_unsorted (split size rest) parts acc)
[] splits) more
| (n, size) :: more ->
partitions'
(List.fold_left (fun acc (parts, rest) ->
prepend_to_fst_unsorted (multi_split n size rest) parts acc)
[] splits) more
let partitions multiplicities l =
if List.fold_left (+) 0 multiplicities <> List.length l then
invalid_arg "Combinatorics.partitions"
else
List.map fst (partitions' [([], l)]
(ThoList.classify (List.sort compare multiplicities)))
let rec ordered_partitions' splits = function
| [] -> List.map (fun (h, r) -> (List.rev h, r)) splits
| size :: more ->
ordered_partitions'
(List.fold_left (fun acc (parts, rest) ->
attach_to_fst_unsorted (ordered_split size rest) parts acc)
[] splits) more
let ordered_partitions multiplicities l =
if List.fold_left (+) 0 multiplicities <> List.length l then
invalid_arg "Combinatorics.ordered_partitions"
else
List.map fst (ordered_partitions' [([], l)] multiplicities)
let hdtl = function
| [] -> invalid_arg "Combinatorics.hdtl"
| h :: t -> (h, t)
let factorized_partitions multiplicities l =
ThoList.factorize (List.map hdtl (partitions multiplicities l))
(* In order to construct keystones (cf.~chapter~\ref{sec:topology}), we
must eliminate reflectionsc consistently. For this to work, the lengths
of the parts \emph{must not} be reordered arbitrarily. Ordering with
monotonously fallings lengths would be incorrect however, because
then some remainders could fake a reflection symmetry and partitions
would be dropped erroneously. Therefore we put the longest first and
order the remaining with rising lengths: *)
let longest_first l =
match ThoList.classify (List.sort (fun n1 n2 -> compare n2 n1) l) with
| [] -> []
| longest :: rest -> longest :: List.rev rest
let keystones multiplicities l =
if List.fold_left (+) 0 multiplicities <> List.length l then
invalid_arg "Combinatorics.keystones"
else
List.map fst (partitions' [([], l)] (longest_first multiplicities))
let factorized_keystones multiplicities l =
ThoList.factorize (List.map hdtl (keystones multiplicities l))
(* \thocwmodulesection{Choices} *)
(* The implementation is very similar to [split'], but here we don't
have to keep track of the complements of the chosen sets. *)
let rec choose' n rev_choice = function
| [] -> []
| x :: tail ->
let rev_choice' = x :: rev_choice
and choices = choose' n rev_choice tail in
if n < 1 then
failwith "Combinatorics.choose': can't happen"
else if n = 1 then
List.rev rev_choice' :: choices
else
choose' (pred n) rev_choice' tail @ choices
(* [choose n] is equivalent to $(\ocwlowerid{List.map}\,\ocwlowerid{fst})\circ
(\ocwlowerid{split\_ordered}\,\ocwlowerid{n})$, but more efficient. *)
let choose n l =
let abs_l = List.length l in
if n < 0 then
invalid_arg "Combinatorics.choose"
else if n > abs_l then
[]
else if n = 0 then
[[]]
else if n = abs_l then
[l]
else
choose' n [] l
let multi_choose n size l =
List.map fst (multi_split n size l)
let ordered_multi_choose n size l =
List.map fst (ordered_multi_split n size l)
(* \thocwmodulesection{Permutations} *)
let rec insert x = function
| [] -> [[x]]
| h :: t as l ->
(x :: l) :: List.rev_map (fun l' -> h :: l') (insert x t)
let permute l =
List.fold_left (fun acc x -> ThoList.rev_flatmap (insert x) acc) [[]] l
(* \thocwmodulesubsection{Graded Permutations} *)
let rec insert_signed x = function
| (eps, []) -> [(eps, [x])]
| (eps, h :: t) -> (eps, x :: h :: t) ::
(List.map (fun (eps', l') -> (-eps', h :: l')) (insert_signed x (eps, t)))
let rec permute_signed' = function
| (eps, []) -> [(eps, [])]
| (eps, h :: t) -> ThoList.flatmap (insert_signed h) (permute_signed' (eps, t))
let permute_signed l =
permute_signed' (1, l)
(* The following are wasting at most a factor of two and there's probably
no point in improving on this \ldots *)
let filter_sign s l =
List.map snd (List.filter (fun (eps, _) -> eps = s) l)
let permute_even l =
filter_sign 1 (permute_signed l)
let permute_odd l =
filter_sign (-1) (permute_signed l)
(* \begin{dubious}
We have a slight inconsistency here:
[permute [] = [[]]], while
[permute_cyclic [] = []].
I don't know if it is worth fixing.
\end{dubious} *)
let permute_cyclic l =
let rec permute_cyclic' acc before = function
| [] -> List.rev acc
| x :: rest as after ->
permute_cyclic' ((after @ List.rev before) :: acc) (x :: before) rest
in
permute_cyclic' [] [] l
(* Algorithm: toggle the signs and at the end map all signs to $+1$,
iff the last sign is positive, i.\,e.~there's an odd number of elements. *)
let permute_cyclic_signed l =
let rec permute_cyclic_signed' eps acc before = function
| [] ->
if eps > 0 then
List.rev_map (fun (_, p) -> (1, p)) acc
else
List.rev acc
| x :: rest as after ->
let eps' = - eps in
permute_cyclic_signed' eps' ((eps', after @ List.rev before) :: acc) (x :: before) rest
in
permute_cyclic_signed' (-1) [] [] l
(* \thocwmodulesubsection{Tensor Products of Permutations} *)
let permute_tensor ll =
Product.list (fun l -> l) (List.map permute ll)
let join_signs l =
let el, pl = List.split l in
(List.fold_left (fun acc x -> x * acc) 1 el, pl)
let permute_tensor_signed ll =
Product.list join_signs (List.map permute_signed ll)
let permute_tensor_even l =
filter_sign 1 (permute_tensor_signed l)
let permute_tensor_odd l =
filter_sign (-1) (permute_tensor_signed l)
(* \thocwmodulesubsection{Sorting} *)
let insert_inorder_signed order x (eps, l) =
let rec insert eps' accu = function
| [] -> (eps * eps', List.rev_append accu [x])
| h :: t ->
if order x h = 0 then
invalid_arg
"Combinatorics.insert_inorder_signed: identical elements"
else if order x h < 0 then
(eps * eps', List.rev_append accu (x :: h :: t))
else
insert (-eps') (h::accu) t
in
insert 1 [] l
-let sort_signed ?(cmp=pcompare) l =
+let sort_signed ?(cmp=Stdlib.compare) l =
List.fold_right (insert_inorder_signed cmp) l (1, [])
-let sign ?(cmp=pcompare) l =
+let sign ?(cmp=Stdlib.compare) l =
let eps, _ = sort_signed ~cmp l in
eps
-let sign2 ?(cmp=pcompare) l =
+let sign2 ?(cmp=Stdlib.compare) l =
let a = Array.of_list l in
let eps = ref 1 in
for j = 0 to Array.length a - 1 do
for i = 0 to j - 1 do
if cmp a.(i) a.(j) > 0 then
eps := - !eps
done
done;
!eps
module Test =
struct
open OUnit
let to_string =
ThoList.to_string (ThoList.to_string string_of_int)
let assert_equal_perms =
assert_equal ~printer:to_string
let count_permutations n =
let factorial_n = factorial n
and range = ThoList.range 1 n in
let sorted = List.sort compare (permute range) in
(* Verify the count \ldots *)
assert_equal factorial_n (List.length sorted);
(* \ldots{} check that they're all different \ldots *)
assert_equal factorial_n (List.length (ThoList.uniq sorted));
(* \ldots{} make sure that they a all permutations. *)
assert_equal_perms
[range] (ThoList.uniq (List.map (List.sort compare) sorted))
let suite_permute =
"permute" >:::
[ "permute []" >::
(fun () ->
assert_equal_perms [[]] (permute []));
"permute [1]" >::
(fun () ->
assert_equal_perms [[1]] (permute [1]));
"permute [1;2;3]" >::
(fun () ->
assert_equal_perms
[ [2; 3; 1]; [2; 1; 3]; [3; 2; 1];
[1; 3; 2]; [1; 2; 3]; [3; 1; 2] ]
(permute [1; 2; 3]));
"permute [1;2;3;4]" >::
(fun () ->
assert_equal_perms
[ [3; 4; 1; 2]; [3; 1; 2; 4]; [3; 1; 4; 2];
[4; 3; 1; 2]; [1; 4; 2; 3]; [1; 2; 3; 4];
[1; 2; 4; 3]; [4; 1; 2; 3]; [1; 4; 3; 2];
[1; 3; 2; 4]; [1; 3; 4; 2]; [4; 1; 3; 2];
[3; 4; 2; 1]; [3; 2; 1; 4]; [3; 2; 4; 1];
[4; 3; 2; 1]; [2; 4; 1; 3]; [2; 1; 3; 4];
[2; 1; 4; 3]; [4; 2; 1; 3]; [2; 4; 3; 1];
[2; 3; 1; 4]; [2; 3; 4; 1]; [4; 2; 3; 1] ]
(permute [1; 2; 3; 4]));
"count permute 5" >::
(fun () -> count_permutations 5);
"count permute 6" >::
(fun () -> count_permutations 6);
"count permute 7" >::
(fun () -> count_permutations 7);
"count permute 8" >::
(fun () -> count_permutations 8);
"cyclic []" >::
(fun () ->
assert_equal_perms [] (permute_cyclic []));
"cyclic [1]" >::
(fun () ->
assert_equal_perms [[1]] (permute_cyclic [1]));
"cyclic [1;2;3]" >::
(fun () ->
assert_equal_perms
[[1;2;3]; [2;3;1]; [3;1;2]]
(permute_cyclic [1;2;3]));
"cyclic [1;2;3;4]" >::
(fun () ->
assert_equal_perms
[[1;2;3;4]; [2;3;4;1]; [3;4;1;2]; [4;1;2;3]]
(permute_cyclic [1;2;3;4]));
"cyclic [1;2;3] signed" >::
(fun () ->
assert_equal
[(1,[1;2;3]); (1,[2;3;1]); (1,[3;1;2])]
(permute_cyclic_signed [1;2;3]));
"cyclic [1;2;3;4] signed" >::
(fun () ->
assert_equal
[(1,[1;2;3;4]); (-1,[2;3;4;1]); (1,[3;4;1;2]); (-1,[4;1;2;3])]
(permute_cyclic_signed [1;2;3;4]))]
let sort_signed_not_unique =
"not unique" >::
(fun () ->
assert_raises
(Invalid_argument
"Combinatorics.insert_inorder_signed: identical elements")
(fun () -> sort_signed [1;2;3;4;2]))
let sort_signed_even =
"even" >::
(fun () ->
assert_equal (1, [1;2;3;4;5;6])
(sort_signed [1;2;4;3;6;5]))
let sort_signed_odd =
"odd" >::
(fun () ->
assert_equal (-1, [1;2;3;4;5;6])
(sort_signed [2;3;1;5;4;6]))
let sort_signed_all =
"all" >::
(fun () ->
let l = ThoList.range 1 8 in
assert_bool "all signed permutations"
(List.for_all
(fun (eps, p) ->
let eps', p' = sort_signed p in
eps' = eps && p' = l)
(permute_signed l)))
let sign_sign2 =
"sign/sign2" >::
(fun () ->
let l = ThoList.range 1 8 in
assert_bool "all permutations"
(List.for_all
(fun p -> sign p = sign2 p)
(permute l)))
let suite_sort_signed =
"sort_signed" >:::
[sort_signed_not_unique;
sort_signed_even;
sort_signed_odd;
sort_signed_all;
sign_sign2]
let suite =
"Combinatorics" >:::
[suite_permute;
suite_sort_signed]
end
(*i
* Local Variables:
* indent-tabs-mode:nil
* page-delimiter:"^(\\* .*\n"
* End:
i*)
Index: trunk/omega/src/UFO_syntax.ml
===================================================================
--- trunk/omega/src/UFO_syntax.ml (revision 8899)
+++ trunk/omega/src/UFO_syntax.ml (revision 8900)
@@ -1,67 +1,68 @@
(* vertex_syntax.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
(* \thocwmodulesection{Abstract Syntax} *)
exception Syntax_Error of string * Lexing.position * Lexing.position
type name = string list
type string_atom =
| Macro of name
| Literal of string
type value =
| Name of name
| Integer of int
| Float of float
| Fraction of int * int
| String of string
| String_Expr of string_atom list
| Empty_List
| Name_List of name list
| Integer_List of int list
| String_List of string list
+ | Young_Tableau of int Young.tableau
| Order_Dictionary of (string * int) list
| Coupling_Dictionary of (int * int * name) list
| Decay_Dictionary of (name list * string) list
type attrib =
{ a_name : string;
a_value : value }
type declaration =
{ name : string;
kind : name;
attribs : attrib list }
type t = declaration list
let macro name expansion =
{ name;
kind = ["$"];
attribs = [ { a_name = name; a_value = expansion } ] }
let to_strings declarations =
[]
Index: trunk/omega/src/omega_SM_dim6.ml
===================================================================
--- trunk/omega/src/omega_SM_dim6.ml (revision 8899)
+++ trunk/omega/src/omega_SM_dim6.ml (revision 8900)
@@ -1,36 +1,27 @@
(* omega_SM_dim6.ml --
Copyright (C) 1999-2015 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
So-young Shim (only this file) <soyoung.shim@desy.de>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.Fortran)
- (Modellib_SM.SM(Modellib_SM.SM_dim6))
+module O = Omega.Mixed23(Target_Fortran.Make)(Modellib_SM.SM(Modellib_SM.SM_dim6))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/feynmp.mli
===================================================================
--- trunk/omega/src/feynmp.mli (revision 0)
+++ trunk/omega/src/feynmp.mli (revision 8900)
@@ -0,0 +1,44 @@
+(* feynmp.mli --
+
+ Copyright (C) 1999-2023 by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+
+ WHIZARD is free software; you can redistribute it and/or modify it
+ under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ WHIZARD is distributed in the hope that it will be useful, but
+ WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
+
+module type T =
+ sig
+ type amplitudes
+
+ val amplitudes_to_channel : bool -> amplitudes -> out_channel -> unit
+ val amplitudes_sans_color_to_channel : bool -> amplitudes -> out_channel -> unit
+ val amplitudes_color_only_to_channel : bool -> amplitudes -> out_channel -> unit
+
+ (* Backward compatibility:
+ \begin{dubious}
+ These can only be retired, if Whizard can deal with
+ ["\\jobname-fmf.mp"] as metapost files!
+ \end{dubious} *)
+ val amplitudes : bool -> string -> amplitudes -> unit
+ val amplitudes_sans_color : bool -> string -> amplitudes -> unit
+ val amplitudes_color_only : bool -> string -> amplitudes -> unit
+
+ end
+
+module Make (FM : Fusion.Maker) (P : Momentum.T) (M : Model.T) : T
+ with type amplitudes = Fusion.Multi(FM)(P)(M).amplitudes
+
Index: trunk/omega/src/omega.tex
===================================================================
--- trunk/omega/src/omega.tex (revision 8899)
+++ trunk/omega/src/omega.tex (revision 8900)
@@ -1,1188 +1,1369 @@
% omega.tex --
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\NeedsTeXFormat{LaTeX2e}
\RequirePackage{ifpdf}
\ifpdf
\documentclass[a4paper,notitlepage,chapters]{flex}
+ \usepackage[T1]{fontenc}
\usepackage{type1cm}
\usepackage[pdftex,colorlinks]{hyperref}
\usepackage[pdftex]{graphicx,feynmp,emp}
\DeclareGraphicsRule{*}{mps}{*}{}
\else
\documentclass[a4paper,notitlepage,chapters]{flex}
\usepackage[T1]{fontenc}
% \usepackage[hypertex]{hyperref}
\usepackage{graphicx,feynmp,emp}
\fi
\usepackage{verbatim,array,amsmath,amssymb}
\usepackage{url,thophys,thohacks}
+\usepackage{alphalph} %%% too many appendices ...
\usepackage{pgf}
\usepackage{ytableau}
\setlength{\unitlength}{1mm}
\empaddtoTeX{\usepackage{amsmath,amssymb}}
\empaddtoTeX{\usepackage{thophys,thohacks}}
\empaddtoprelude{input graph;}
\empaddtoprelude{input boxes;}
\IfFileExists{geometry.sty}%
{\usepackage{geometry}%
\geometry{a4paper,margin=2cm}}%
{\relax}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% This should be part of flex.cls and/or thopp.sty
\makeatletter
\@ifundefined{frontmatter}%
{\def\frontmatter{\pagenumbering{roman}}%
\def\mainmatter{\cleardoublepage\pagenumbering{arabic}}}
{}
\makeatother
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% \makeatletter
%%% %%% Italic figure captions to separate them visually from the text
%%% %%% (this should be supported by flex.cls):
%%% \makeatletter
%%% \@secpenalty=-1000
%%% \def\fps@figure{t}
%%% \def\fps@table{b}
%%% \long\def\@makecaption#1#2{%
%%% \vskip\abovecaptionskip
%%% \sbox\@tempboxa{#1: \textit{#2}}%
%%% \ifdim\wd\@tempboxa>\hsize
%%% #1: \textit{#2}\par
%%% \else
%%% \global\@minipagefalse
%%% \hb@xt@\hsize{\hfil\box\@tempboxa\hfil}%
%%% \fi
%%% \vskip\belowcaptionskip}
%%% \makeatother
\widowpenalty=4000
\clubpenalty=4000
\displaywidowpenalty=4000
%%% \pagestyle{headings}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\allowdisplaybreaks
\renewcommand{\topfraction}{0.8}
\renewcommand{\bottomfraction}{0.8}
\renewcommand{\textfraction}{0.2}
\setlength{\abovecaptionskip}{.5\baselineskip}
\setlength{\belowcaptionskip}{\baselineskip}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% allow VERY overfull hboxes
\setlength{\hfuzz}{5cm}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\usepackage{noweb}
%%% \usepackage{nocondmac}
\setlength{\nwmarginglue}{1em}
\noweboptions{smallcode,noidentxref}%%%{webnumbering}
%%% Saving paper:
\def\nwendcode{\endtrivlist\endgroup}
\nwcodepenalty=0
\let\nwdocspar\relax
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\newcommand{\ttfilename}[1]{\texttt{\detokenize{#1}}}
\usepackage[noweb,bypages]{ocamlweb}
\empaddtoTeX{\usepackage[noweb,bypages]{ocamlweb}}
\renewcommand{\ocwinterface}[1]{\section{Interface of \ocwupperid{#1}}}
\renewcommand{\ocwmodule}[1]{\section{Implementation of \ocwupperid{#1}}}
\renewcommand{\ocwinterfacepart}{\relax}
\renewcommand{\ocwcodepart}{\relax}
\renewcommand{\ocwbeginindex}{\begin{theindex}}
\newcommand{\thocwmodulesection}[1]{\subsection{#1}}
\newcommand{\thocwmodulesubsection}[1]{\subsubsection{#1}}
\newcommand{\thocwmoduleparagraph}[1]{\paragraph{#1}}
\renewcommand{\ocwindent}[1]{\noindent\ignorespaces}
\renewcommand{\ocwbegincode}{\renewcommand{\ocwindent}[1]{\noindent\kern##1}}
\renewcommand{\ocwendcode}{\renewcommand{\ocwindent}[1]{\noindent\ignorespaces}}
\renewcommand{\ocweol}{\setlength\parskip{0pt}\par}
\makeatletter
\renewcommand{\@oddfoot}{\reset@font\hfil\thepage\hfil}
\let\@evenfoot\@oddfoot
\def\@evenhead{\leftmark{} \hrulefill}%
\def\@oddhead{\hrulefill{} \rightmark}%
\let\@mkboth\markboth
\renewcommand{\chaptermark}[1]{\markboth{\hfil}{\hfil}}%
\renewcommand{\sectionmark}[1]{\markboth{#1}{#1}}
\renewcommand{\chapter}{%
\clearpage\global\@topnum\z@\@afterindentfalse
\secdef\@chapter\@schapter}
\makeatother
\newcommand{\signature}[1]{%
\InputIfFileExists{#1.interface}{}%
{\begin{dubious}\textit{Interface \ttfilename{#1.mli} unavailable!}\end{dubious}}}
+\newcommand{\interface}[1]{%
+ \label{mod:#1}%
+ \InputIfFileExists{#1.implementation}{}%
+ {\begin{dubious}\textit{Interface \ttfilename{#1.ml} unavailable!}\end{dubious}}}
\newcommand{\application}[1]{%
\InputIfFileExists{#1.implementation}{}%
{\begin{dubious}\textit{Application \ttfilename{#1.ml} unavailable!}\end{dubious}}}
\newcommand{\module}[1]{%
\label{mod:#1}%
\InputIfFileExists{#1.interface}{}%
{\begin{dubious}\textit{Interface \ttfilename{#1.mli} unavailable!}\end{dubious}}%
\InputIfFileExists{#1.implementation}{}%
{\begin{dubious}\textit{Implementation \ttfilename{#1.ml} unavailable!}\end{dubious}}}
\newcommand{\lexer}[1]{\application{#1_lexer}}
\renewcommand{\ocwlexmodule}[1]{\relax}
\newcommand{\parser}[1]{\application{#1_parser}}
\renewcommand{\ocwyaccmodule}[1]{\relax}
\newcommand{\thocwincludegraphics}[2]{\includegraphics[#1]{#2}}
\ifpdf
\newcommand{\thocwdefref}[1]{\textbf{\pageref{#1}}}%
\newcommand{\thocwuseref}[1]{\textrm{\pageref{#1}}}%
\renewcommand{\ocwrefindexentry}[5]%
{\item #1,\quad\let\ref\thocwdefref{#4}, used: \let\ref\thocwuseref{#5}}
\fi
\newcommand{\thocwmakebox}[4]{\makebox(#1,#2)[#3]{#4}}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\newenvironment{modules}[1]%
{\begin{list}{}%
{\setlength{\leftmargin}{3em}%
\setlength{\rightmargin}{2em}%
\setlength{\itemindent}{-1em}%
\setlength{\listparindent}{0pt}%
%%%\setlength{\itemsep}{0pt}%
\settowidth{\labelwidth}{\textbf{\ocwupperid{#1}:}}%
\renewcommand{\makelabel}[1]{\ocwupperid{##1:}}}}%
{\end{list}}
\newenvironment{JR}%
{\begin{dubious}\textit{JR sez' (regarding the Majorana Feynman rules):}}
{\textit{(JR's probably right, but I need to check myself \ldots)}
\end{dubious}}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\DeclareMathOperator{\tr}{tr}
\newcommand{\dd}{\mathrm{d}}
\newcommand{\ii}{\mathrm{i}}
\newcommand{\ee}{\mathrm{e}}
\renewcommand{\Re}{\text{Re}}
\renewcommand{\Im}{\text{Im}}
\newcommand{\ketbra}[2]{\ket{#1}\!\bra{#2}}
\newcommand{\Ketbra}[2]{\Ket{#1}\!\Bra{#2}}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\makeindex
\begin{document}
\begin{fmffile}{\jobname pics}
\fmfset{arrow_ang}{10}
\fmfset{curly_len}{2mm}
\fmfset{wiggly_len}{3mm}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\fmfcmd{%
numeric joindiameter;
joindiameter := 7thick;}
\fmfcmd{%
vardef sideways_at (expr d, p, frac) =
save len; len = length p;
(point frac*len of p) shifted ((d,0) rotated (90 + angle direction frac*len of p))
enddef;
secondarydef p sideways d =
for frac = 0 step 0.01 until 0.99:
sideways_at (d, p, frac) ..
endfor
sideways_at (d, p, 1)
enddef;
secondarydef p choptail d =
subpath (ypart (fullcircle scaled d shifted (point 0 of p) intersectiontimes p), infinity) of p
enddef;
secondarydef p choptip d =
reverse ((reverse p) choptail d)
enddef;
secondarydef p pointtail d =
fullcircle scaled d shifted (point 0 of p) intersectionpoint p
enddef;
secondarydef p pointtip d =
(reverse p) pointtail d
enddef;
secondarydef pa join pb =
pa choptip joindiameter .. pb choptail joindiameter
enddef;
vardef cyclejoin (expr p) =
subpath (0.5*length p, infinity) of p join subpath (0, 0.5*length p) of p .. cycle
enddef;}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\fmfcmd{%
style_def double_line_arrow expr p =
save pi, po;
path pi, po;
pi = reverse (p sideways thick);
po = p sideways -thick;
cdraw pi;
cdraw po;
cfill (arrow pi);
cfill (arrow po);
enddef;}
\fmfcmd{%
style_def double_line_arrow_beg expr p =
save pi, po, pc;
path pi, po, pc;
pc = p choptail 7thick;
pi = reverse (pc sideways thick);
po = pc sideways -thick;
cdraw pi .. p pointtail 5thick .. po;
cfill (arrow pi);
cfill (arrow po);
enddef;}
\fmfcmd{%
style_def double_line_arrow_end expr p =
save pi, po, pc;
path pi, po, pc;
pc = p choptip 7thick;
pi = reverse (pc sideways thick);
po = pc sideways -thick;
cdraw po .. p pointtip 5thick .. pi;
cfill (arrow pi);
cfill (arrow po);
enddef;}
\fmfcmd{%
style_def double_line_arrow_both expr p =
save pi, po, pc;
path pi, po, pc;
pc = p choptip 7thick choptail 7thick;
pi = reverse (pc sideways thick);
po = pc sideways -thick;
cdraw po .. p pointtip 5thick .. pi .. p pointtail 5thick .. cycle;
cfill (arrow pi);
cfill (arrow po);
enddef;}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\fmfcmd{vardef middir (expr p, ang) =
dir (angle direction length(p)/2 of p + ang)
enddef;}
\fmfcmd{style_def arrow_left expr p =
shrink (.7);
cfill (arrow p shifted (4thick * middir (p, 90)));
endshrink
enddef;}
\fmfcmd{style_def arrow_right expr p =
shrink (.7);
cfill (arrow p shifted (4thick * middir (p, -90)));
endshrink
enddef;}
\fmfcmd{style_def warrow_left expr p =
shrink (.7);
cfill (arrow p shifted (8thick * middir (p, 90)));
endshrink
enddef;}
\fmfcmd{style_def warrow_right expr p =
shrink (.7);
cfill (arrow p shifted (8thick * middir (p, -90)));
endshrink
enddef;}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\newcommand{\threeexternal}[3]{%
\fmfsurround{d1,e1,d2,e2,d3,e3}%
\fmfv{label=$#1$,label.ang=0}{e1}%
\fmfv{label=$#2$,label.ang=180}{e2}%
\fmfv{label=$#3$,label.ang=0}{e3}}
\newcommand{\Threeexternal}[3]{%
\fmfsurround{d1,e1,d3,e3,d2,e2}%
\fmfv{label=$#1$,label.ang=0}{e1}%
\fmfv{label=$#2$,label.ang=0}{e2}%
\fmfv{label=$#3$,label.ang=180}{e3}}
\newcommand{\Fourexternal}[4]{%
\fmfsurround{d2,e2,d1,e1,d4,e4,d3,e3}%
\fmfv{label=$#1$,label.ang=180}{e1}%
\fmfv{label=$#2$,label.ang=0}{e2}%
\fmfv{label=$#3$,label.ang=0}{e3}%
\fmfv{label=$#4$,label.ang=180}{e4}}
\newcommand{\Fiveexternal}[5]{%
\fmfsurround{d2,e2,d1,e1,d5,e5,d4,e4,d3,e3}%
\fmfv{label=$#1$,label.ang=180}{e1}%
\fmfv{label=$#2$,label.ang=0}{e2}%
\fmfv{label=$#3$,label.ang=0}{e3}%
\fmfv{label=$#4$,label.ang=0}{e4}%
\fmfv{label=$#5$,label.ang=180}{e5}}
\newcommand{\twoincoming}{%
\fmfdot{v}%
\fmffreeze%
\fmf{warrow_right}{e1,v}%
\fmf{warrow_right}{e2,v}%
\fmf{warrow_right}{v,e3}}
\newcommand{\threeincoming}{%
\fmfdot{v}%
\fmffreeze%
\fmf{warrow_right}{e1,v}%
\fmf{warrow_right}{e2,v}%
\fmf{warrow_right}{e3,v}}
\newcommand{\threeoutgoing}{%
\fmfdot{v}%
\fmffreeze%
\fmf{warrow_right}{v,e1}%
\fmf{warrow_right}{v,e2}%
\fmf{warrow_right}{v,e3}}
\newcommand{\fouroutgoing}{%
\threeoutgoing%
\fmf{warrow_right}{v,e4}}
\newcommand{\fiveoutgoing}{%
\fouroutgoing%
\fmf{warrow_right}{v,e5}}
\newcommand{\setupthreegluons}{%
\fmftop{g3}
\fmfbottom{g1,g2}
\fmf{phantom}{v,g1}
\fmf{phantom}{v,g2}
\fmf{phantom}{v,g3}
\fmffreeze
\fmfipair{v,g[],a[],b[]}
\fmfiset{g1}{vloc (__g1)}
\fmfiset{g2}{vloc (__g2)}
\fmfiset{g3}{vloc (__g3)}
\fmfiset{v}{vloc (__v)}
\fmfiset{a1}{g1 shifted (-3thin,0)}
\fmfiset{b1}{g1 shifted (+1thin,-2thin)}
\fmfiset{a2}{g2 shifted (0,-3thin)}
\fmfiset{b2}{g2 shifted (0,+3thin)}
\fmfiset{a3}{g3 shifted (+1thin,+2thin)}
\fmfiset{b3}{g3 shifted (-3thin,0)}}
\begin{empfile}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\frontmatter
\title{
O'Mega:\\
Optimal~Monte-Carlo\\
Event~Generation~Amplitudes}
\author{%
Thorsten Ohl\thanks{%
\texttt{ohl@physik.uni-wuerzburg.de},
\texttt{http://physik.uni-wuerzburg.de/ohl}}\\
\hfil\\
Institut f\"ur Theoretische~Physik und Astrophysik\\
Julius-Maximilians-Universit\"at~W\"urzburg\\
Emil-Hilb-Weg 22, 97074~W\"urzburg, Germany\\
\hfil\\
J\"urgen Reuter\thanks{\texttt{juergen.reuter@desy.de}}\\
\hfil\\
DESY Theory Group,
Notkestr. 85, 22603 Hamburg, Germany\\
\hfil\\
Wolfgang Kilian${}^{c,}$\thanks{\texttt{kilian@physik.uni-siegen.de}}\\
\hfil\\
Theoretische Physik 1\\
Universit\"at Siegen\\
Walter-Flex-Str.~3, 57068 Siegen, Germany\\
\hfil\\
with contributions from
Christian
Speckner${}^{d,}$\thanks{\texttt{cnspeckn@googlemail.com}}\\
as well as
Christian Schwinn et al.}
\date{\textbf{unpublished draft, printed \timestamp}}
\maketitle
\begin{abstract}
\ldots
\end{abstract}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\newpage
\begin{quote}
- Copyright \textcopyright~1999-2017 by
+ Copyright \textcopyright~1999-2023 by
\begin{itemize}
\item Wolfgang~Kilian ~\texttt{<kilian@hep.physik.uni-siegen.de>}
\item Thorsten~Ohl~\texttt{<ohl@physik.uni-wuerzburg.de>}
\item J\"urgen~Reuter~\texttt{<juergen.reuter@desy.de>}
\end{itemize}
\end{quote}
\begin{quote}
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.
\end{quote}
\begin{quote}
WHIZARD is distributed in the hope that it will be useful, but
\emph{without any warranty}; without even the implied warranty of
\emph{merchantability} or \emph{fitness for a particular purpose}.
See the GNU General Public License for more details.
\end{quote}
\begin{quote}
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.
\end{quote}
\setcounter{tocdepth}{2}
\tableofcontents
\mainmatter
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Introduction}
\label{sec:intro}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Complexity}
\label{sec:complexity}
\begin{table}
\begin{center}
\begin{tabular}{r|r|r}
$n$ & $P(n)$& $F(n)$ \\\hline
4 & 3 & 3 \\
5 & 10 & 15 \\
6 & 25 & 105 \\
7 & 56 & 945 \\
8 & 119 & 10395 \\
9 & 246 & 135135 \\
10 & 501 & 2027025 \\
11 & 1012 & 34459425 \\
12 & 2035 & 654729075 \\
13 & 4082 & 13749310575 \\
14 & 8177 & 316234143225 \\
15 & 16368 & 7905853580625 \\
16 & 32751 & 213458046676875
\end{tabular}
\end{center}
\caption{\label{tab:P(n),F(n)}
The number of $\phi^3$ Feynman diagrams~$F(n)$ and independent
poles~$P(n)$.}
\end{table}
There are
\begin{equation}
P(n) = \frac{2^n-2}{2} - n = 2^{n-1} - n - 1
\end{equation}
independent internal momenta in a $n$-particle scattering
amplitude~\cite{ALPHA:1997}. This grows much slower than the
number
\begin{equation}
F(n) = (2n-5)!! = (2n-5)\cdot(2n-7)\cdot\ldots\cdot3\cdot1
\end{equation}
of tree Feynman diagrams in vanilla $\phi^3$ (see
table~\ref{tab:P(n),F(n)}). There are no known corresponding
expressions for theories with more than one particle type. However,
empirical evidence from numerical studies~\cite{ALPHA:1997,HELAC:2000}
as well as explicit counting results from O'Mega suggest
\begin{equation}
P^*(n) \propto 10^{n/2}
\end{equation}
while he factorial growth of the number of Feynman diagrams remains
unchecked, of course.
The number of independent momenta in an amplitude is a better measure
for the complexity of the amplitude than the number of Feynman
diagrams, since there can be substantial cancellations among the
latter. Therefore it should be possible to express the scattering
amplitude more compactly than by a sum over Feynman diagrams.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Ancestors}
\label{sec:ancestors}
Some of the ideas that O'Mega is based on can be traced back to
HELAS~\cite{HELAS}. HELAS builts Feynman amplitudes by recursively
forming off-shell `wave functions' from joining external lines with
other external lines or off-shell `wave functions'.
The program Madgraph~\cite{MADGRAPH:1994} automatically generates
Feynman diagrams and writes a Fortran program corresponding to their
sum. The amplitudes are calculated by calls to HELAS~\cite{HELAS}.
Madgraph uses one straightforward optimization: no statement is
written more than once. Since each statement corresponds to a
collection of trees, this optimization is very effective for up to
four particles in the final state. However, since the amplitudes are
given as a sum of Feynman diagrams, this optimization can, by design,
\emph{not} remove the factorial growth and is substantially weaker
than the algorithms of~\cite{ALPHA:1997,HELAC:2000} and the algorithm
of O'Mega for more particles in the final state.
Then ALPHA~\cite{ALPHA:1997} (see also the slightly modified
variant~\cite{HELAC:2000}) provided a numerical algorithm for
calculating scattering amplitudes and it could be shown empirically,
that the calculational costs are rising with a power instead of
factorially.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{Architecture}
\label{sec:architecture}
\begin{figure}
\begin{center}
\includegraphics[width=\textwidth]{modules}
%includegraphics[height=.8\textheight]{modules}
\end{center}
\caption{\label{fig:modules}%
Module dependencies in O'Mega.}
%% The diamond shaped nodes are abstract signatures defininng functor
%% domains and co-domains. The rectangular boxes are modules and
%% functors and oval boxes are examples for applications.
\end{figure}
\subsection{General purpose libraries}
Functions that are not specific to O'Mega and could be part of the
O'Caml standard library
\begin{modules}{}
\item[ThoList] (mostly) simple convenience functions for lists that
are missing from the standard library module \ocwupperid{List}
(section~\ref{sec:tholist}, p.~\pageref{sec:tholist})
\item[Product] effcient tensor products for lists and sets
(section~\ref{sec:product}, p.~\pageref{sec:product})
\item[Combinatorics] combinatorical formulae, sets of subsets, etc.
(section~\ref{sec:combinatorics}, p.~\pageref{sec:combinatorics})
\end{modules}
\subsection{O'Mega}
The non-trivial algorithms that constitute O'Mega:
\begin{modules}{}
\item[DAG] Directed Acyclical Graphs
(section~\ref{sec:DAG}, p.~\pageref{sec:DAG})
\item[Topology] unusual enumerations of unflavored tree diagrams
(section~\ref{sec:topology}, p.~\pageref{sec:topology})
\item[Momentum] finite sums of external momenta
(section~\ref{sec:momentum}, p.~\pageref{sec:momentum})
\item[Fusion] off shell wave functions
(section~\ref{sec:fusion}, p.~\pageref{sec:fusion})
\item[Omega] functor constructing an application from a model and a
target
(section~\ref{sec:omega}, p.~\pageref{sec:omega})
\end{modules}
\subsection{Abstract interfaces}
The domains and co-domains of functors
(section~\ref{sec:coupling}, p.~\pageref{sec:coupling})
\begin{modules}{}
\item[Coupling] all possible couplings (not comprensive yet)
\item[Model] physical models
\item[Target] target programming languages
\end{modules}
\subsection{Models}
(section~\ref{sec:models}, p.~\pageref{sec:models})
\begin{modules}{}
\item[Modellib_SM.QED] Quantum Electrodynamics
\item[Modellib_SM.QCD] Quantum Chromodynamics (not complete yet)
\item[Modellib_SM.SM] Minimal Standard Model (not complete yet)
\end{modules}
etc.
\subsection{Targets}
Any programming language that supports arithmetic and a textual
representation of programs can be targeted by O'Caml. The
implementations translate the abstract expressions derived by
\ocwupperid{Fusion} to expressions in the target
(section~\ref{sec:targets}, p.~\pageref{sec:targets}).
\begin{modules}{}
- \item[Targets.Fortran] Fortran95 language implementation, calling
+ \item[Target_Fortran] Fortran95 language implementation, calling
subroutines
\end{modules}
Other targets could come in the future: \texttt{C}, \texttt{C++},
O'Caml itself, symbolic manipulation languages, etc.
\subsection{Applications}
(section~\ref{sec:omega}, p.~\pageref{sec:omega})
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\section{The Big To Do Lists}
\label{sec:TODO}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\subsection{Required}
All features required for leading order physics applications are in place.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\subsection{Useful}
\begin{enumerate}
\item select allowed helicity combinations for massless fermions
\item Weyl-Van der Waerden spinors
\item speed up helicity sums by using discrete symmetries
\item general triple and quartic vector couplings
\item diagnostics: count corresponding Feynman diagrams
more efficiently for more than ten external lines
\item recognize potential cascade decays ($\tau$, $b$, etc.)
\begin{itemize}
\item warn the user to add additional
\item kill fusions (at runtime), that contribute to a cascade
\end{itemize}
\item complete standard model in $R_\xi$-gauge
\item groves (the simple method of cloned generations works)
\end{enumerate}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\subsection{Future Features}
\begin{enumerate}
\item investigate if unpolarized squared matrix elements can be
calculated faster as traces of densitiy matrices. Unfortunately,
the answer apears to be \emph{no} for fermions and \emph{up to a
constant factor} for massive vectors. Since the number of fusions
in the amplitude grows like~$10^{n/2}$, the number of fusions in
the squared matrix element grows like~$10^n$. On the other hand,
there are $2^{\#\text{fermions}+\#\text{massless vectors}}
\cdot3^{\#\text{massive vectors}}$ terms in the helicity sum, which
grows \emph{slower} than~$10^{n/2}$. The constant factor is
probably also not favorable.
However, there will certainly be asymptotic gains for sums over
gauge (and other) multiplets, like color sums.
\item compile Feynman rules from Lagrangians
\item evaluate amplitues in O'Caml by compiling it to three address
code for a virtual machine
\begin{flushleft}
\ocwkw{type}~$\ocwlowerid{mem}~=~\ocwlowerid{scalar}~$\ocwbt{array}~$%
\times{}~\ocwlowerid{spinor}~$\ocwbt{array}~$%
\times{}~\ocwlowerid{spinor}~$\ocwbt{array}~$%
\times{}~\ocwlowerid{vector}~$\ocwbt{array}\\
\ocwkw{type}~$\ocwlowerid{instr}~=$\\
\qquad|~$\ocwupperid{VSS}~$\ocwkw{of}~\ocwbt{int}~$%
\times{}~$\ocwbt{int}~$\times{}~$\ocwbt{int}\\
\qquad|~$\ocwupperid{SVS}~$\ocwkw{of}~\ocwbt{int}~$%
\times{}~$\ocwbt{int}~$\times{}~$\ocwbt{int}\\
\qquad|~$\ocwupperid{AVA}~$\ocwkw{of}~\ocwbt{int}~$%
\times{}~$\ocwbt{int}~$\times{}~$\ocwbt{int}\\
\qquad\ldots
\end{flushleft}
this could be as fast as~\cite{ALPHA:1997} or~\cite{HELAC:2000}.
\item a virtual machine will be useful for for other target as
well, because native code appears to become to large for most
compilers for more than ten external particles. Bytecode might
even be faster due to improved cache locality.
\item use the virtual machine in O'Giga
\end{enumerate}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\subsection{Science Fiction}
\begin{enumerate}
\item numerical and symbolical loop calculations with
\textsc{O'Tera: O'Mega Tool for Evaluating Renormalized Amplitudes}
\end{enumerate}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Tuples and Polytuples}
\label{sec:tuple}
\module{tuple}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Topologies}
\label{sec:topology}
\module{topology}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Directed Acyclical Graphs}
\label{sec:DAG}
\module{DAG}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Momenta}
\label{sec:momentum}
\module{momentum}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Cascades}
\label{sec:cascades}
\module{cascade_syntax}
\section{Lexer}
\lexer{cascade}
\section{Parser}
\parser{cascade}
\module{cascade}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\chapter{Arrows and Epsilon Tensors}
+\label{sec:arrow}
+\module{arrow}
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\chapter{Birdtracks}
+\label{sec:birdtracks}
+\module{birdtracks}
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\chapter{$\mathrm{SU}(3)$}
+\label{sec:su3}
+Using the normalization~$\tr(T_{a}T_{b}) = \delta_{ab}$, we can
+check the selfconsistency of the completeness relation
+\begin{equation}
+ T_{a}^{i_1j_1} T_{a}^{i_2j_2} =
+ \left( \delta^{i_1j_2} \delta^{i_2j_1}
+ - \frac{1}{N_C} \delta^{i_1j_1} \delta^{j_1j_2}\right)
+\end{equation}
+as
+\begin{multline}
+ T_{a}^{i_1j_1} T_{a}^{i_2j_2}
+ = \tr\left(T_{a_1}T_{a_2}\right) T_{a_1}^{i_1j_1} T_{a_2}^{i_2j_2}
+ = T_{a_1}^{l_1l_2} T_{a_2}^{l_2l_1}
+ T_{a_1}^{i_1j_1} T_{a_2}^{i_2j_2} \\
+ = \left( \delta^{l_1j_1} \delta^{i_1l_2}
+ - \frac{1}{N_C} \delta^{l_1l_2} \delta^{i_1j_1}\right)
+ \left( \delta^{l_2j_2} \delta^{i_2l_1}
+ - \frac{1}{N_C} \delta^{l_2l_1} \delta^{i_2j_2}\right)
+ = \left( \delta^{i_1j_2} \delta^{i_2j_1}
+ - \frac{1}{N_C} \delta^{i_1i_2} \delta^{j_2j_1}\right)
+\end{multline}
+With
+\begin{equation}
+\label{eq:f=tr(TTT)'}
+ \ii f_{a_1a_2a_3}
+ = \tr\left(T_{a_1}\left\lbrack T_{a_2},T_{a_3}\right\rbrack\right)
+ = \tr\left(T_{a_1}T_{a_2}T_{a_3}\right)
+ - \tr\left(T_{a_1}T_{a_3}T_{a_2}\right)
+\end{equation}
+and
+\begin{multline}
+ \tr\left(T_{a_1}T_{a_2}T_{a_3}\right)
+ T_{a_1}^{i_1j_1} T_{a_2}^{i_2j_2} T_{a_3}^{i_3j_3}
+ = T_{a_1}^{l_1l_2} T_{a_2}^{l_2l_3} T_{a_3}^{l_3l_1}
+ T_{a_1}^{i_1j_1} T_{a_2}^{i_2j_2} T_{a_3}^{i_3j_3} = \\
+ \left( \delta^{l_1j_1} \delta^{i_1l_2}
+ - \frac{1}{N_C} \delta^{l_1l_2} \delta^{i_1j_1}\right)
+ \left( \delta^{l_2j_2} \delta^{i_2l_3}
+ - \frac{1}{N_C} \delta^{l_2l_3} \delta^{i_2j_2}\right)
+ \left( \delta^{l_3j_3} \delta^{i_3l_1}
+ - \frac{1}{N_C} \delta^{l_3l_1} \delta^{i_3j_3}\right)
+\end{multline}
+we find the decomposition
+\begin{equation}
+\label{eq:fTTT'}
+ \ii f_{a_1a_2a_3} T_{a_1}^{i_1j_1}T_{a_2}^{i_2j_2}T_{a_3}^{i_3j_3}
+ = \delta^{i_1j_2}\delta^{i_2j_3}\delta^{i_3j_1}
+ - \delta^{i_1j_3}\delta^{i_3j_2}\delta^{i_2j_1}\,.
+\end{equation}
+
+Indeed,
+\begin{verbatim}
+symbol nc;
+Dimension nc;
+vector i1, i2, i3, j1, j2, j3;
+index l1, l2, l3;
+
+local [TT] =
+ ( j1(l1) * i1(l2) - d_(l1,l2) * i1.j1 / nc )
+ * ( j2(l2) * i2(l1) - d_(l2,l1) * i2.j2 / nc );
+
+#procedure TTT(sign)
+local [TTT`sign'] =
+ ( j1(l1) * i1(l2) - d_(l1,l2) * i1.j1 / nc )
+ * ( j2(l2) * i2(l3) - d_(l2,l3) * i2.j2 / nc )
+ * ( j3(l3) * i3(l1) - d_(l3,l1) * i3.j3 / nc )
+ `sign' ( j1(l1) * i1(l2) - d_(l1,l2) * i1.j1 / nc )
+ * ( j3(l2) * i3(l3) - d_(l2,l3) * i3.j3 / nc )
+ * ( j2(l3) * i2(l1) - d_(l3,l1) * i2.j2 / nc );
+#endprocedure
+
+#call TTT(-)
+#call TTT(+)
+
+bracket nc;
+print;
+.sort
+.end
+\end{verbatim}
+gives
+\begin{verbatim}
+ [TT] =
+ + nc^-1 * ( - i1.j1*i2.j2 )
+ + i1.j2*i2.j1;
+
+ [TTT-] =
+ + i1.j2*i2.j3*i3.j1 - i1.j3*i2.j1*i3.j2;
+
+ [TTT+] =
+ + nc^-2 * ( 4*i1.j1*i2.j2*i3.j3 )
+ + nc^-1 * ( - 2*i1.j1*i2.j3*i3.j2
+ - 2*i1.j2*i2.j1*i3.j3
+ - 2*i1.j3*i2.j2*i3.j1 )
+ + i1.j2*i2.j3*i3.j1 + i1.j3*i2.j1*i3.j2;
+\end{verbatim}
+\module{SU3}
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\chapter{Color Propagators}
+\label{sec:color_propagator}
+\module{color_Propagator}
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\chapter{Color Fusions}
+\label{sec:color_fusion}
+\module{color_fusion}
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Color}
\label{sec:color}
\module{color}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\chapter{Colorization}
+\label{sec:colorize}
+\module{colorize}
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\chapter{Count Coupling Constants}
+\label{sec:orders}
+\module{orders}
+\module{orders_syntax}
+\section{Lexer}
+\lexer{orders}
+\section{Parser}
+\parser{orders}
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Fusions}
\label{sec:fusion}
\module{fusion}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Lorentz Representations, Couplings, Models and Targets}
\label{sec:coupling}
\signature{coupling}
\signature{model}
\module{dirac}
-\module{vertex}
+%%% \module{vertex}
\signature{target}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Conserved Quantum Numbers}
\label{sec:charges}
\module{charges}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-\chapter{Colorization}
-\label{sec:colorize}
-\module{colorize}
-
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Processes}
\label{sec:process}
\module{process}
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-\chapter{Model Files}
-\label{sec:model-files}
-\module{vertex_syntax}
-\section{Lexer}
-\lexer{vertex}
-\section{Parser}
-\parser{vertex}
-\module{vertex}
+%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%%% \chapter{Model Files}
+%%% \label{sec:model-files}
+%%% \module{vertex_syntax}
+%%% \section{Lexer}
+%%% \lexer{vertex}
+%%% \section{Parser}
+%%% \parser{vertex}
+%%% \module{vertex}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{UFO Models}
\label{sec:ufo}
\module{UFOx_syntax}
\section{Expression Lexer}
\lexer{UFOx}
\section{Expression Parser}
\parser{UFOx}
\module{UFOx}
\module{UFO_syntax}
\section{Lexer}
\lexer{UFO}
\section{Parser}
\parser{UFO}
\module{UFO_Lorentz}
\module{UFO}
\section{Targets}
\module{UFO_targets}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Hardcoded Targets}
\label{sec:targets}
+The following modules used to be submodules of [Targets], but this
+as become unwieldy over time.
\module{format_Fortran}
-\module{targets}
+\module{target_Fortran_Names}
+\module{target_Fortran}
+\module{targets_vintage}
\module{targets_Kmatrix}
+\module{targets_Kmatrix_2}
+\module{target_VM}
+%module{targets}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Phase Space}
\label{sec:phasespace}
\module{phasespace}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Whizard}
\label{sec:whizard}
Talk to~\cite{Kilian:WHIZARD}.
\module{whizard}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\chapter{FeynMP, n\'ee FeynMF}
+\label{sec:feynmp}
+Talk to~\cite{Ohl:1995kr}.
+\module{feynmp}
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Applications}
\label{sec:omega}
-\section{Sample}
-{\small\verbatiminput{sample.prc}}
\module{omega}
+\module{omega_cli}
+\application{omega3}
%application{omega_Phi3}
%application{omega_Phi3h}
%application{omega_Phi4}
%application{omega_Phi4h}
\application{omega_QED}
%application{omega_QCD}
%application{omega_SM3}
%application{omega_SM3_ac}
\application{omega_SM}
\application{omega_SYM}
%application{omega_SM_ac}
%application{f90Maj_SM}
%application{f90Maj_SM4}
%application{omega_MSSM}
%application{omega_MSSM_g}
%application{omega_SM_Rxi}
%application{omega_SM_clones}
%application{omega_THDM}
%application{omega_SMh}
%application{omega_SM4h}
%application{helas_QED}
%application{helas_QCD}
%application{helas_SM}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter*{Acknowledgements}
We thank Mauro Moretti for fruitful discussions of the ALPHA
algorithm~\cite{ALPHA:1997}, that inspired our solution of the double
counting problem.
We thank Wolfgang Kilian for providing the WHIZARD environment that
turns our numbers into real events with unit weight. Thanks to the
ECFA/DESY workshops and their participants for providing a showcase.
Thanks to Edward Boos for discussions in Kaluza-Klein gravitons.
This research is supported by Bundesministerium f\"ur Bildung und
Forschung, Germany, (05\,HT9RDA) and Deutsche Forschungsgemeinschaft
(MA\,676/6-1).
Thanks to the Caml and Objective Caml teams from INRIA for the
development and the lean and mean implementation of a programming
language that does not insult the programmer's intelligence.
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\begin{thebibliography}{10}
\bibitem{ALPHA:1997}
F. Caravaglios, M. Moretti, Z.{} Phys.{} \textbf{C74} (1997) 291.
\bibitem{HELAC:2000}
A. Kanaki, C. Papadopoulos, DEMO-HEP-2000/01, hep-ph/0002082,
February 2000.
\bibitem{Ler97}
Xavier Leroy,
\textit{The Objective Caml system, documentation and user's guide},
Technical Report, INRIA, 1997.
\bibitem{Okasaki:1998:book}
Chris Okasaki, \textit{Purely Functional Data Structures},
Cambridge University Press, 1998.
\bibitem{HELAS}
H. Murayama, I. Watanabe, K. Hagiwara, KEK Report 91-11,
January 1992.
\bibitem{MADGRAPH:1994}
T. Stelzer, W.F. Long,
Comput.{} Phys.{} Commun.{} \textbf{81} (1994) 357.
\bibitem{Denner:Majorana}
A. Denner, H. Eck, O. Hahn and J. K\"ublbeck,
Phys.{} Lett.{} \textbf{B291} (1992) 278;
Nucl.{} Phys.{} \textbf{B387} (1992) 467.
\bibitem{Barger/etal:1992:color}
V.~Barger, A.~L.~Stange, R.~J.~N.~Phillips,
Phys.~Rev.~\textbf{D45}, (1992) 1751.
\bibitem{Ohl:LOTR}
T. Ohl, \textit{Lord of the Rings},
(Computer algebra library for O'Caml, unpublished).
\bibitem{Ohl:bocages}
T. Ohl, \textit{Bocages},
(Feynman diagram library for O'Caml, unpublished).
\bibitem{Kilian:WHIZARD}
W. Kilian, \textit{\texttt{WHIZARD}}, University of Karlsruhe, 2000.
+ %\cite{Ohl:1995kr}
+ \bibitem{Ohl:1995kr}
+ T.~Ohl,
+ %``Drawing Feynman diagrams with Latex and Metafont,''
+ Comput. Phys. Commun. \textbf{90} (1995), 340-354
+ doi:10.1016/0010-4655(95)90137-S
+ [arXiv:hep-ph/9505351 [hep-ph]].
+ %51 citations counted in INSPIRE as of 13 Jun 2023
\bibitem{Boos/Ohl:groves}
E.\,E. Boos, T. Ohl,
Phys.\ Rev.\ Lett.\ \textbf{83} (1999) 480.
\bibitem{Han/Lykken/Zhang:1999:Kaluza-Klein}
T.~Han, J.~D.~Lykken and R.~Zhang,
%``On Kaluza-Klein states from large extra dimensions,''
Phys.{} Rev.{} \textbf{D59} (1999) 105006
[hep-ph/9811350].
%%CITATION = HEP-PH 9811350;%%
\bibitem{PTVF92}
William H. Press, Saul A. Teukolsky, William T. Vetterling,
Brian P. Flannery,
\textit{Numerical Recipes: The Art of Scientific Computing},
Second Edition, Cambridge University Press, 1992.
\bibitem{Cvi76}
P.~Cvitanovi\'c,
% author={Predrag Cvitanovi\'c},
% title={Group Theory for {Feynman} Diagrams in Non-{Abelian}
% Gauge Theories},
Phys.{} Rev.{} \textbf{D14} (1976) 1536.
%%%\bibitem{Kleiss/etal:Color-Monte-Carlo}
%%% \begin{dubious}
%%% ``\texttt{Kleiss/etal:Color-Monte-Carlo}''
%%% \end{dubious}
%\cite{Kilian:2012pz}
\bibitem{Kilian:2012pz}
W.~Kilian, T.~Ohl, J.~Reuter and C.~Speckner,
%``QCD in the Color-Flow Representation,''
JHEP \textbf{1210} (2012) 022
[arXiv:1206.3700 [hep-ph]].
%%CITATION = doi:10.1007/JHEP10(2012)022;%%
%37 citations counted in INSPIRE as of 23 Apr 2019
%\cite{Degrande:2011ua}
\bibitem{Degrande:2011ua}
C.~Degrande, C.~Duhr, B.~Fuks, D.~Grellscheid, O.~Mattelaer and T.~Reiter,
%``UFO - The Universal FeynRules Output,''
Comput.{} Phys.{} Commun.{} \textbf{183} (2012), 1201-1214
doi:10.1016/j.cpc.2012.01.022
[arXiv:1108.2040 [hep-ph]].
+\bibitem{TAOCP2}
+Donald E.~Knuth,
+\textit{The Art of Computer Programming. 2: Seminumerical algorithms}
\end{thebibliography}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\appendix
+%%% we've started to have too many appendices \ldots
+\renewcommand{\thechapter}{\AlphAlph{\value{chapter}}}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Autotools}
\label{sec:autotools}
\module{config}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Textual Options}
\label{sec:options}
\module{options}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Progress Reports}
\label{sec:progress}
\module{progress}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{More on Filenames}
\label{sec:thoFilename}
\module{thoFilename}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Cache Files}
\label{sec:cache}
\module{cache}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{More On Lists}
\label{sec:tholist}
\module{thoList}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\chapter{Non-Empty Lists}
+\label{sec:nelist}
+\module{NEList}
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\chapter{Lists with Typed Length}
+\label{sec:nlist}
+\module{NList}
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{More On Arrays}
\label{sec:thoarray}
\module{thoArray}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\chapter{Persistent Arrays}
+\label{sec:parray}
+\module{PArray}
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{More On Strings}
\label{sec:thostring}
\module{thoString}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+\chapter{Structured Maps}
+\label{sec:thomap}
+\module{thoMap}
+
+%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Polymorphic Maps}
\label{sec:pmap}
From~\cite{Ohl:LOTR}.
\module{pmap}
\module{partial}
-%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
-\chapter{Tries}
-\label{sec:trie}
-From~\cite{Okasaki:1998:book}, extended for~\cite{Ohl:LOTR}.
-\module{trie}
+%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
+%%% \chapter{Tries}
+%%% \label{sec:trie}
+%%% From~\cite{Okasaki:1998:book}, extended for~\cite{Ohl:LOTR}.
+%%% \module{trie}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Tensor Products}
\label{sec:product}
From~\cite{Ohl:LOTR}.
\module{product}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{(Fiber) Bundles}
\label{sec:bundle}
\module{bundle}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Power Sets}
\label{sec:powSet}
\module{powSet}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Combinatorics}
\label{sec:combinatorics}
\module{combinatorics}
\module{permutation}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Partitions}
\label{sec:partition}
\module{partition}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Young Diagrams and Tableaux}
\label{sec:young}
\module{young}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Trees}
\label{sec:tree}
From~\cite{Ohl:bocages}:
Trees with one root admit a straightforward recursive definition
\begin{equation}
\label{eq:trees}
T(N,L) = L \cup N\times T(N,L)\times T(N,L)
\end{equation}
that is very well adapted to mathematical reasoning. Such
recursive definitions are useful because they
allow us to prove properties of elements by induction
\begin{multline}
\label{eq:tree-induction}
\forall l\in L: p(l) \land
(\forall n\in N: \forall t_1,t_2\in T(N,L): p(t_1) \land p(t_2)
\Rightarrow p(n\times t_1\times t_2)) \\
\Longrightarrow \forall t\in T(N,L): p(t)
\end{multline}
i.\,e.~establishing a property for all leaves and showing that a node
automatically satisfies the property if it is true for all children
proves the property for \emph{all} trees. This induction is of course
modelled after standard mathematical induction
\begin{equation}
p(1) \land (\forall n\in \mathbf{N}: p(n) \Rightarrow p(n+1))
\Longrightarrow \forall n\in \mathbf{N}: p(n)
\end{equation}
The recursive definition~(\ref{eq:trees}) is mirrored by the two tree
construction functions\footnote{To make the introduction more
accessible to non-experts, I avoid the `curried' notation for
functions with multiple arguments and use tuples instead. The actual
implementation takes advantage of curried functions, however. Experts
can read $\alpha\to\beta\to\gamma$ for $\alpha\times\beta\to\gamma$.}
\begin{subequations}
\begin{align}
\ocwlowerid{leaf}:\;& \nu\times\lambda \to(\nu,\lambda) T \\
\ocwlowerid{node}:\;& \nu\times(\nu,\lambda)T \times(\nu,\lambda)T
\to(\nu,\lambda)T
\end{align}
\end{subequations}
Renaming leaves and nodes leaves the structure of the tree invariant.
Therefore, morphisms~$L\to L'$ and~$N\to N'$ of the sets of leaves
and nodes induce natural homomorphisms~$T(N,L)\to T(N',L')$ of trees
\begin{equation}
\ocwlowerid{map}:\; (\nu\to\nu')\times(\lambda\to\lambda')
\times(\nu,\lambda)T \to(\nu',\lambda') T
\end{equation}
The homomorphisms constructed by \ocwlowerid{map} are trivial, but
ubiquitous. More interesting are the morphisms
\begin{equation}
\begin{aligned}
\ocwlowerid{fold}:\;& (\nu\times\lambda\to\alpha)
\times(\nu\times\alpha\times\alpha\to\alpha)
\times(\nu,\lambda)T \to\alpha \\
& (f_1,f_2,l\in L) \mapsto f_1(l) \\
& (f_1,f_2,(n,t_1,t_2)) \mapsto
f_2(n,\ocwlowerid{fold}(f_1,f_2,t_1),
\ocwlowerid{fold}(f_1,f_2,t_2))
\end{aligned}
\end{equation}
and
\begin{equation}
\begin{aligned}
\ocwlowerid{fan}:\;& (\nu\times\lambda\to\{\alpha\})
\times(\nu\times\alpha\times\alpha\to\{\alpha\})
\times(\nu,\lambda)T \to\{\alpha\} \\
& (f_1,f_2,l\in L) \mapsto f_1(l) \\
& (f_1,f_2,(n,t_1,t_2)) \mapsto
f_2(n, \ocwlowerid{fold}(f_1,f_2,t_1)
\otimes\ocwlowerid{fold}(f_1,f_2,t_2))
\end{aligned}
\end{equation}
where the tensor product notation means that~$f_2$ is applied to all
combinations of list members in the argument:
\begin{equation}
\phi(\{x\}\otimes \{y\})
= \left\{ \phi(x,y) | x\in\{x\} \land y\in\{y\} \right\}
\end{equation}
But note that due to the recursive nature of trees, \ocwlowerid{fan} is
\emph{not} a morphism from $T(N,L)$ to $T(N\otimes N,L)$.\par
If we identify singleton sets with their members, \ocwlowerid{fold} could be
viewed as a special case of \ocwlowerid{fan}, but that is probably more
confusing than helpful. Also, using the special
case~$\alpha=(\nu',\lambda')T$, the homomorphism \ocwlowerid{map} can be
expressed in terms of \ocwlowerid{fold} and the constructors
\begin{equation}
\begin{aligned}
\ocwlowerid{map}:\;& (\nu\to\nu')\times(\lambda\to\lambda')
\times(\nu,\lambda)T \to(\nu',\lambda')T \\
&(f,g,t) \mapsto
\ocwlowerid{fold} (\ocwlowerid{leaf}\circ (f\times g),
\ocwlowerid{node}\circ (f\times\ocwlowerid{id}
\times\ocwlowerid{id}), t)
\end{aligned}
\end{equation}
\ocwlowerid{fold} is much more versatile than \ocwlowerid{map}, because it can be used
with constructors for other tree representations to translate among
different representations. The target type can also be a mathematical
expression. This is used extensively below for evaluating Feynman
diagrams.\par
Using \ocwlowerid{fan} with~$\alpha=(\nu',\lambda')T$ can be used to construct
a multitude of homomorphic trees. In fact, below it will be used
extensively to construct all Feynman
diagrams~$\{(\nu,\{p_1,\ldots,p_n\})T\}$ of a given
topology~$t\in (\emptyset,\{1,\ldots,n\})T$.
\begin{dubious}
The physicist in me guesses that there is another morphism of trees
that is related to \ocwlowerid{fan} like a Lie-algebra is related to the
it's Lie-group. I have not been able to pin it down, but I guess that it
is a generalization of \ocwlowerid{grow} below.
\end{dubious}
\module{tree}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Dependency Trees}
\label{sec:tree2}
\module{tree2}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Consistency Checks}
\label{sec:count}
\application{count}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Complex Numbers}
\label{sec:complex}
\module{complex}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Algebra}
\label{sec:algebra}
\module{algebra}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Simple Linear Algebra}
\label{sec:linalg}
\module{linalg}
%application{test_linalg}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Partial Maps}
\label{sec:partial}
\module{partial}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{Talk To The WHiZard \ldots}
\label{sec:whizard_tool}
Talk to~\cite{Kilian:WHIZARD}.
\begin{dubious}
Temporarily disabled, until, we implement some conditional weaving\ldots
\end{dubious}
%application{whizard_tool}
%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% \chapter{Widget Library and Class Hierarchy for O'Giga}
%%% \label{sec:thogtk}
%%% {\itshape NB: The code in this chapter \emph{must} be compiled with
%%% \verb+-labels+, since \verb+lablgtk+ doesn't appear to work in classic mode.}
%%% \begin{dubious}
%%% Keep in mind that \texttt{ocamlweb} doesn't work properly with
%%% O'Caml~3 yet. The colons in label declarations are typeset with
%%% erroneous white space.
%%% \end{dubious}
%%%
%%% \section{Architecture}
%%% In \texttt{lablgtk}, O'Caml objects are typically constructed in
%%% parallel to constructors for \texttt{GTK+} widgets. The objects
%%% provide inheritance and all that, while the constructors implement the
%%% semantics.
%%%
%%% \subsection{Inheritance vs.~Aggregation}
%%% We have two mechanisms for creating new widgets: inheritance and
%%% aggregation. Inheritance makes it easy to extend a given widget with
%%% new methods or to combine orthogonal widgets (\emph{multiple
%%% inheritance}). Aggregation is more suitable for combining
%%% non-orthogonal widgets (e.\,g.~multiple instances of the same widget).
%%%
%%% The problem with inheritance in \texttt{lablgtk} is, that it is a
%%% \emph{bad} idea to implement the semantics in the objects. In a
%%% multi-level inheritance hierarchy, O'Caml can evaluate class functions
%%% more than once. Since functions accessing \texttt{GTK+} change the
%%% state of \texttt{GTK+}, we could accidentally violate invariants.
%%% Therefore inheritance forces us to use the two-tiered approach of
%%% \texttt{lablgtk} ourselves. It is not really complicated, but tedious
%%% and it appears to be a good idea to use aggregation whenever in doubt.
%%%
%%% Nevertheless, there are examples (like
%%% \ocwupperid{ThoGButton.mutable\_button} below, where just one new
%%% method is added), that cry out for inheritance for the benefit of the
%%% application developer.
%%%
%%% \module{thoGWindow}
%%% \module{thoGButton}
%%% \module{thoGMenu}
%%% \module{thoGDraw}
%%%
%%% %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
%%% \chapter{O'Mega Virtual Machine}
%%% \label{sec:ovm}
%%% \module{OVM}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\chapter{\texttt{Fortran} Libraries}
\label{sec:fortran}
\input{omegalib}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\begin{raggedright}
\ifpdf
\chapter{Index}
\let\origtwocolumn\twocolumn
\def\twocolumn[#1]{\origtwocolumn}%
This index has been generated automatically and might not be
100\%ly accurate. In particular, hyperlinks have been observed to
be off by one page.
\fi
\input{index.tex}
\end{raggedright}
%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
\end{empfile}
\end{fmffile}
\end{document}
\endinput
Local Variables:
mode:latex
indent-tabs-mode:nil
page-delimiter:"^%%%%%.*\n"
End:
Index: trunk/omega/src/omega_QED_VM.ml
===================================================================
--- trunk/omega/src/omega_QED_VM.ml (revision 8899)
+++ trunk/omega/src/omega_QED_VM.ml (revision 8900)
@@ -1,26 +1,26 @@
(* omega_QED_VM.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
cf. main AUTHORS file
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Binary(Targets.VM)(Modellib_SM.QED)
+module O = Omega.Binary(Target_VM.Make)(Modellib_SM.QED)
let _ = O.main ()
Index: trunk/omega/src/thoList.ml
===================================================================
--- trunk/omega/src/thoList.ml (revision 8899)
+++ trunk/omega/src/thoList.ml (revision 8900)
@@ -1,619 +1,742 @@
(* thoList.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-(* Avoid refering to [Pervasives.compare], because [Pervasives] will
- become [Stdlib.Pervasives] in O'Caml 4.07 and [Stdlib] in O'Caml 4.08. *)
-let pcompare = compare
-
let rec hdn n l =
if n <= 0 then
[]
else
match l with
| x :: rest -> x :: hdn (pred n) rest
| [] -> invalid_arg "ThoList.hdn"
let rec tln n l =
if n <= 0 then
l
else
match l with
| _ :: rest -> tln (pred n) rest
| [] -> invalid_arg "ThoList.tln"
let rec splitn' n l1_rev l2 =
if n <= 0 then
(List.rev l1_rev, l2)
else
match l2 with
| x :: l2' -> splitn' (pred n) (x :: l1_rev) l2'
| [] -> invalid_arg "ThoList.splitn n > len"
let splitn n l =
if n < 0 then
invalid_arg "ThoList.splitn n < 0"
else
splitn' n [] l
let split_last l =
match List.rev l with
| [] -> invalid_arg "ThoList.split_last []"
| ln :: l12_rev -> (List.rev l12_rev, ln)
(* This is [splitn'] all over again, but without the exception. *)
let rec chopn'' n l1_rev l2 =
if n <= 0 then
(List.rev l1_rev, l2)
else
match l2 with
| x :: l2' -> chopn'' (pred n) (x :: l1_rev) l2'
| [] -> (List.rev l1_rev, [])
let rec chopn' n ll_rev = function
| [] -> List.rev ll_rev
| l ->
begin match chopn'' n [] l with
| [], [] -> List.rev ll_rev
| l1, [] -> List.rev (l1 :: ll_rev)
| l1, l2 -> chopn' n (l1 :: ll_rev) l2
end
let chopn n l =
if n <= 0 then
invalid_arg "ThoList.chopn n <= 0"
else
chopn' n [] l
(* Find a member [a] in the list [l] and return the
cyclically permuted list with [a] as head. *)
let cycle_until a l =
let rec cycle_until' acc = function
| [] -> raise Not_found
| a' :: l' as al' ->
if a' = a then
al' @ List.rev acc
else
cycle_until' (a' :: acc) l' in
cycle_until' [] l
let rec cycle' i acc l =
if i <= 0 then
l @ List.rev acc
else
match l with
| [] -> invalid_arg "ThoList.cycle"
| a' :: l' ->
cycle' (pred i) (a' :: acc) l'
let cycle n l =
if n < 0 then
invalid_arg "ThoList.cycle"
else
cycle' n [] l
let of_subarray n1 n2 a =
let rec of_subarray' n1 n2 =
if n1 > n2 then
[]
else
a.(n1) :: of_subarray' (succ n1) n2 in
of_subarray' (max 0 n1) (min n2 (pred (Array.length a)))
let range ?(stride=1) n1 n2 =
if stride <= 0 then
invalid_arg "ThoList.range: stride <= 0"
else
let rec range' n =
if n > n2 then
[]
else
n :: range' (n + stride) in
range' n1
(* Tail recursive: *)
let enumerate ?(stride=1) n l =
let _, l_rev =
List.fold_left
(fun (i, acc) a -> (i + stride, (i, a) :: acc))
(n, []) l in
List.rev l_rev
(* Take the elements of [list] that satisfy [predicate] and
form a list of pairs of an offset into the original list
and the element with the offsets
starting from [offset]. NB: the order of the returned alist
is not specified! *)
let alist_of_list ?(predicate=(fun _ -> true)) ?(offset=0) list =
let _, alist =
List.fold_left
(fun (n, acc) x ->
(succ n, if predicate x then (n, x) :: acc else acc))
(offset, []) list in
alist
(* This is \emph{not} tail recursive! *)
let rec flatmap f = function
| [] -> []
| x :: rest -> f x @ flatmap f rest
(* This is! *)
let rev_flatmap f l =
let rec rev_flatmap' acc f = function
| [] -> acc
| x :: rest -> rev_flatmap' (List.rev_append (f x) acc) f rest in
rev_flatmap' [] f l
let rec power = function
| [] -> [[]]
| a :: a_list ->
let power_a_list = power a_list in
power_a_list @ List.map (fun a_list -> a :: a_list) power_a_list
let rec fold_left_opt f acc = function
| [] -> Some acc
| a :: rest ->
begin match f acc a with
| None -> None
| Some acc -> fold_left_opt f acc rest
end
let fold_left2 f acc lists =
List.fold_left (List.fold_left f) acc lists
let fold_right2 f lists acc =
List.fold_right (List.fold_right f) lists acc
let iteri f start list =
ignore (List.fold_left (fun i a -> f i a; succ i) start list)
let iteri2 f start_outer star_inner lists =
iteri (fun j -> iteri (f j) star_inner) start_outer lists
let mapi f start list =
let next, list' =
List.fold_left (fun (i, acc) a -> (succ i, f i a :: acc)) (start, []) list in
List.rev list'
let rec map3 f l1 l2 l3 =
match l1, l2, l3 with
| [], [], [] -> []
| a1 :: l1, a2 :: l2, a3 :: l3 ->
let fa123 = f a1 a2 a3 in
fa123 :: map3 f l1 l2 l3
| _, _, _ -> invalid_arg "ThoList.map3"
(* Is there a more efficient implementation? *)
let transpose lists =
let rec transpose' rest =
if List.for_all ((=) []) rest then
[]
else
List.map List.hd rest :: transpose' (List.map List.tl rest) in
try
transpose' lists
with
| Failure s ->
if s = "tl" then
invalid_arg "ThoList.transpose: not rectangular"
else
failwith ("ThoList.transpose: unexpected Failure(" ^ s ^ ")")
-let compare ?(cmp=pcompare) l1 l2 =
+let compare ?(cmp=Stdlib.compare) l1 l2 =
let rec compare' l1' l2' =
match l1', l2' with
| [], [] -> 0
| [], _ -> -1
| _, [] -> 1
| n1 :: r1, n2 :: r2 ->
let c = cmp n1 n2 in
if c <> 0 then
c
else
compare' r1 r2
in
compare' l1 l2
let rec uniq' x = function
| [] -> []
| x' :: rest ->
if x' = x then
uniq' x rest
else
x' :: uniq' x' rest
let uniq = function
| [] -> []
| x :: rest -> x :: uniq' x rest
let rec homogeneous = function
| [] | [_] -> true
| a1 :: (a2 :: _ as rest) ->
if a1 <> a2 then
false
else
homogeneous rest
let rec pairs' acc = function
| [] -> acc
| [x] -> invalid_arg "pairs: odd number of elements"
| x :: y :: indices ->
if x <> y then
invalid_arg "pairs: not in pairs"
else
begin match acc with
| [] -> pairs' [x] indices
| x' :: _ ->
if x = x' then
invalid_arg "pairs: more than twice"
else
pairs' (x :: acc) indices
end
let pairs l =
- pairs' [] (List.sort pcompare l)
+ pairs' [] (List.sort Stdlib.compare l)
(* If we needed it, we could use a polymorphic version of [Set] to
speed things up from~$O(n^2)$ to~$O(n\ln n)$. But not before it
matters somewhere \ldots *)
let classify l =
let rec add_to_class a = function
| [] -> [1, a]
| (n, a') :: rest ->
if a = a' then
(succ n, a) :: rest
else
(n, a') :: add_to_class a rest
in
let rec classify' cl = function
| [] -> cl
| a :: rest -> classify' (add_to_class a cl) rest
in
classify' [] l
let rec factorize l =
let rec add_to_class x y = function
| [] -> [(x, [y])]
| (x', ys) :: rest ->
if x = x' then
(x, y :: ys) :: rest
else
(x', ys) :: add_to_class x y rest
in
let rec factorize' fl = function
| [] -> fl
| (x, y) :: rest -> factorize' (add_to_class x y fl) rest
in
List.map (fun (x, ys) -> (x, List.rev ys)) (factorize' [] l)
+let factorize_fold f acc l =
+ List.map
+ (fun (key, values) -> (key, List.fold_left f acc values))
+ (factorize l)
+
let rec clone x n =
if n < 0 then
invalid_arg "ThoList.clone"
else if n = 0 then
[]
else
x :: clone x (pred n)
let interleave f list =
let rec interleave' rev_head tail =
let rev_head' = List.rev_append (f rev_head tail) rev_head in
match tail with
| [] -> List.rev rev_head'
| x :: tail' -> interleave' (x :: rev_head') tail'
in
interleave' [] list
let interleave_nearest f list =
interleave
(fun head tail ->
match head, tail with
| h :: _, t :: _ -> f h t
| _ -> [])
list
let rec rev_multiply n rl l =
if n < 0 then
invalid_arg "ThoList.multiply"
else if n = 0 then
[]
else
List.rev_append rl (rev_multiply (pred n) rl l)
let multiply n l = rev_multiply n (List.rev l) l
let filtermap f l =
let rec rev_filtermap acc = function
| [] -> List.rev acc
| a :: a_list ->
match f a with
| None -> rev_filtermap acc a_list
| Some fa -> rev_filtermap (fa :: acc) a_list
in
rev_filtermap [] l
exception Overlapping_indices
exception Out_of_bounds
let iset_list_union list =
List.fold_right Sets.Int.union list Sets.Int.empty
let complement_index_sets n index_set_lists =
let index_sets = List.map Sets.Int.of_list index_set_lists in
let index_set = iset_list_union index_sets in
let size_index_sets =
List.fold_left (fun acc s -> Sets.Int.cardinal s + acc) 0 index_sets in
if size_index_sets <> Sets.Int.cardinal index_set then
raise Overlapping_indices
else if Sets.Int.exists (fun i -> i < 0 || i >= n) index_set then
raise Overlapping_indices
else
match Sets.Int.elements
(Sets.Int.diff (Sets.Int.of_list (range 0 (pred n))) index_set) with
| [] -> index_set_lists
| complement -> complement :: index_set_lists
let sort_section cmp array index_set =
List.iter2
(Array.set array)
index_set (List.sort cmp (List.map (Array.get array) index_set))
let partitioned_sort cmp index_sets list =
let array = Array.of_list list in
List.fold_left
(fun () -> sort_section cmp array)
() (complement_index_sets (List.length list) index_sets);
Array.to_list array
-let ariadne_sort ?(cmp=pcompare) list =
+let ariadne_sort ?(cmp=Stdlib.compare) list =
let sorted =
List.sort (fun (n1, a1) (n2, a2) -> cmp a1 a2) (enumerate 0 list) in
(List.map snd sorted, List.map fst sorted)
let ariadne_unsort (sorted, indices) =
List.map snd
(List.sort
- (fun (n1, a1) (n2, a2) -> pcompare n1 n2)
+ (fun (n1, a1) (n2, a2) -> Stdlib.compare n1 n2)
(List.map2 (fun n a -> (n, a)) indices sorted))
-let lexicographic ?(cmp=pcompare) l1 l2 =
+let lexicographic ?(cmp=Stdlib.compare) l1 l2 =
let rec lexicographic' = function
| [], [] -> 0
| [], _ -> -1
| _, [] -> 1
| x1 :: rest1, x2 :: rest2 ->
let res = cmp x1 x2 in
if res <> 0 then
res
else
lexicographic' (rest1, rest2) in
lexicographic' (l1, l2)
(* If there was a polymorphic [Set], we could also say
[Set.elements (Set.union (Set.of_list l1) (Set.of_list l2))]. *)
let common l1 l2 =
List.fold_left
(fun acc x1 ->
if List.mem x1 l2 then
x1 :: acc
else
acc)
[] l1
let complement l1 = function
| [] -> l1
| l2 ->
if List.for_all (fun x -> List.mem x l1) l2 then
List.filter (fun x -> not (List.mem x l2)) l1
else
invalid_arg "ThoList.complement"
+let split_first_opt predicate list =
+ let rec split_first_opt' rev_head = function
+ | [] -> None
+ | a :: tail ->
+ if predicate a then
+ Some (List.rev rev_head, a, tail)
+ else
+ split_first_opt' (a :: rev_head) tail in
+ split_first_opt' [] list
+
+let take_first_even_opt predicate list =
+ match split_first_opt predicate list with
+ | None -> None
+ | Some ([], i, []) -> Some (i, [])
+ | Some ([_], _, []) -> invalid_arg "ThoList.take_first_even_opt: pair"
+ | Some ([], i, tail) -> Some (i, tail)
+ | Some (i1 :: i2 :: head, i, []) -> (* [ [i; i1; i2] ] is an even permutaion of [ [i1; i2; i] ] *)
+ Some (i, i1 :: head @ [i2])
+ | Some (i1 :: head, i, i2 :: tail) -> (* [ [i; i2; i1] ] is an even permutaion of [ [i1; i; i2] ] *)
+ Some (i, head @ (i2 :: i1 :: tail))
let to_string a2s alist =
"[" ^ String.concat "; " (List.map a2s alist) ^ "]"
+let merge_sorted_alist op f1 f2 l1 l2 =
+ let rec merge_sorted_alist' acc l1 l2 =
+ match l1, l2 with
+ | [], [] -> List.rev acc
+ | tl1, [] -> List.rev_append acc (List.map (fun (k, v) -> (k, f1 v)) tl1)
+ | [], tl2 -> List.rev_append acc (List.map (fun (k, v) -> (k, f2 v)) tl2)
+ | (k1, v1) :: tl1, (k2, v2) :: tl2 ->
+ let c = Stdlib.compare k1 k2 in
+ if c = 0 then
+ merge_sorted_alist' ((k1, op v1 v2) :: acc) tl1 tl2
+ else if c < 0 then
+ merge_sorted_alist' ((k1, f1 v1) :: acc) tl1 l2
+ else
+ merge_sorted_alist' ((k2, f2 v2) :: acc) l1 tl2 in
+ merge_sorted_alist' [] l1 l2
+
+let merge_alist op f1 f2 l1 l2 =
+ merge_sorted_alist op f1 f2
+ (List.sort (fun (k1, _) (k2, _) -> Stdlib.compare k1 k2) l1)
+ (List.sort (fun (k1, _) (k2, _) -> Stdlib.compare k1 k2) l2)
+
let random_int_list imax n =
let imax_plus = succ imax in
Array.to_list (Array.init n (fun _ -> Random.int imax_plus))
module Test =
struct
+ let id x = x
+
let int_list2_to_string l2 =
to_string (to_string string_of_int) l2
(* Inefficient, must only be used for unit tests. *)
let compare_lists_by_size l1 l2 =
- let lengths = pcompare (List.length l1) (List.length l2) in
+ let lengths = Stdlib.compare (List.length l1) (List.length l2) in
if lengths = 0 then
- pcompare l1 l2
+ Stdlib.compare l1 l2
else
lengths
open OUnit
let suite_filtermap =
"filtermap" >:::
[ "filtermap Some []" >::
(fun () ->
assert_equal ~printer:(to_string string_of_int)
[] (filtermap (fun x -> Some x) []));
"filtermap None []" >::
(fun () ->
assert_equal ~printer:(to_string string_of_int)
[] (filtermap (fun x -> None) []));
"filtermap even_neg []" >::
(fun () ->
assert_equal ~printer:(to_string string_of_int)
[0; -2; -4]
(filtermap
(fun n -> if n mod 2 = 0 then Some (-n) else None)
(range 0 5)));
"filtermap odd_neg []" >::
(fun () ->
assert_equal ~printer:(to_string string_of_int)
[-1; -3; -5]
(filtermap
(fun n -> if n mod 2 <> 0 then Some (-n) else None)
(range 0 5))) ]
let assert_power power_a_list a_list =
assert_equal ~printer:int_list2_to_string
power_a_list
(List.sort compare_lists_by_size (power a_list))
let suite_power =
"power" >:::
[ "power []" >::
(fun () ->
assert_power [[]] []);
"power [1]" >::
(fun () ->
assert_power [[]; [1]] [1]);
"power [1;2]" >::
(fun () ->
assert_power [[]; [1]; [2]; [1;2]] [1;2]);
"power [1;2;3]" >::
(fun () ->
assert_power
[[];
[1]; [2]; [3];
[1;2]; [1;3]; [2;3];
[1;2;3]]
[1;2;3]);
"power [1;2;3;4]" >::
(fun () ->
assert_power
[[];
[1]; [2]; [3]; [4];
[1;2]; [1;3]; [1;4]; [2;3]; [2;4]; [3;4];
[1;2;3]; [1;2;4]; [1;3;4]; [2;3;4];
[1;2;3;4]]
[1;2;3;4]) ]
let suite_split =
"split*" >:::
[ "split_last []" >::
(fun () ->
assert_raises
(Invalid_argument "ThoList.split_last []")
(fun () -> split_last []));
"split_last [1]" >::
(fun () ->
assert_equal
([], 1)
(split_last [1]));
"split_last [2;3;1;4]" >::
(fun () ->
assert_equal
([2;3;1], 4)
(split_last [2;3;1;4])) ]
let test_list = random_int_list 1000 100
let assert_equal_int_list =
assert_equal ~printer:(to_string string_of_int)
let suite_cycle =
"cycle_until" >:::
[ "cycle (-1) [1;2;3]" >::
(fun () ->
assert_raises
(Invalid_argument "ThoList.cycle")
(fun () -> cycle 4 [1;2;3]));
"cycle 4 [1;2;3]" >::
(fun () ->
assert_raises
(Invalid_argument "ThoList.cycle")
(fun () -> cycle 4 [1;2;3]));
"cycle 42 [...]" >::
(fun () ->
let n = 42 in
assert_equal_int_list
(tln n test_list @ hdn n test_list)
(cycle n test_list));
"cycle_until 1 []" >::
(fun () ->
assert_raises
(Not_found)
(fun () -> cycle_until 1 []));
"cycle_until 1 [2;3;4]" >::
(fun () ->
assert_raises
(Not_found)
(fun () -> cycle_until 1 [2;3;4]));
"cycle_until 1 [1;2;3;4]" >::
(fun () ->
assert_equal
[1;2;3;4]
(cycle_until 1 [1;2;3;4]));
"cycle_until 3 [1;2;3;4]" >::
(fun () ->
assert_equal
[3;4;1;2]
(cycle_until 3 [3;4;1;2]));
"cycle_until 4 [1;2;3;4]" >::
(fun () ->
assert_equal
[4;1;2;3]
(cycle_until 4 [4;1;2;3])) ]
let suite_alist_of_list =
"alist_of_list" >:::
[ "simple" >::
(fun () ->
assert_equal
[(46, 4); (44, 2); (42, 0)]
(alist_of_list
~predicate:(fun n -> n mod 2 = 0) ~offset:42 [0;1;2;3;4;5])) ]
+ let suite_factorize_fold =
+ "factorize_fold" >:::
+ [ "simple" >::
+ (fun () ->
+ assert_equal
+ [(1, 21); (2, 41)]
+ (factorize_fold (+) 0 [(1, 10); (2, 20); (2, 21); (1, 11)])) ]
+
let suite_complement =
"complement" >:::
[ "simple" >::
(fun () ->
assert_equal [2;4] (complement [1;2;3;4] [1; 3]));
"empty" >::
(fun () ->
assert_equal [1;2;3;4] (complement [1;2;3;4] []));
"failure" >::
(fun () ->
assert_raises
(Invalid_argument ("ThoList.complement"))
(fun () -> complement (complement [1;2;3;4] [5]))) ]
+ let suite_merge_alist =
+ "merge_alist" >:::
+ [ "[] []" >::
+ (fun () ->
+ assert_equal [] (merge_alist (+) id id [] []));
+
+ "[] [(a, 1); (b, 2)]" >::
+ (fun () ->
+ assert_equal
+ [("a", 1); ("b", 2)]
+ (merge_alist (+) id id [] [("a", 1); ("b", 2)]));
+
+ "[(a, 1); (b, 2)] []" >::
+ (fun () ->
+ assert_equal
+ [("a", 1); ("b", 2)]
+ (merge_alist (+) id id [("a", 1); ("b", 2)] []));
+
+ "[(a, 1); (b, 2)] [(c, 3); (b, 2)]" >::
+ (fun () ->
+ assert_equal
+ [("a", 1); ("b", 4); ("c", 3)]
+ (merge_alist (+) id id [("a", 1); ("b", 2)] [("c", 3); ("b", 2)])) ]
+
+ let suite_take_first_even_opt =
+ "take_first_even_opt" >:::
+ [ "empty" >::
+ (fun () ->
+ assert_equal None (take_first_even_opt ((=) 1) []));
+
+ "not found" >::
+ (fun () ->
+ assert_equal None (take_first_even_opt ((=) 0) [1;2;3]));
+
+ "1 [1;2;3]" >::
+ (fun () ->
+ assert_equal (Some (1, [2;3])) (take_first_even_opt ((=) 1) [1;2;3]));
+
+ "2 [1;2;3]" >::
+ (fun () ->
+ assert_equal (Some (2, [3;1])) (take_first_even_opt ((=) 2) [1;2;3]));
+
+ "3 [1;2;3]" >::
+ (fun () ->
+ assert_equal (Some (3, [1;2])) (take_first_even_opt ((=) 3) [1;2;3]));
+
+ "1 [1;2;3;4]" >::
+ (fun () ->
+ assert_equal (Some (1, [2;3;4])) (take_first_even_opt ((=) 1) [1;2;3;4]));
+
+ "2 [1;2;3;4]" >::
+ (fun () ->
+ assert_equal (Some (2, [3;1;4])) (take_first_even_opt ((=) 2) [1;2;3;4]));
+
+ "3 [1;2;3;4]" >::
+ (fun () ->
+ assert_equal (Some (3, [2;4;1])) (take_first_even_opt ((=) 3) [1;2;3;4]));
+
+ "4 [1;2;3;4]" >::
+ (fun () ->
+ assert_equal (Some (4, [1;3;2])) (take_first_even_opt ((=) 4) [1;2;3;4]));
+
+ "pair" >::
+ (fun () ->
+ assert_raises
+ (Invalid_argument ("ThoList.take_first_even_opt: pair"))
+ (fun () -> take_first_even_opt ((=) 2) [1;2])) ]
+
let suite =
"ThoList" >:::
[suite_filtermap;
suite_power;
suite_split;
suite_cycle;
suite_alist_of_list;
- suite_complement]
+ suite_factorize_fold;
+ suite_complement;
+ suite_merge_alist;
+ suite_take_first_even_opt]
end
Index: trunk/omega/src/thoMap.ml
===================================================================
--- trunk/omega/src/thoMap.ml (revision 0)
+++ trunk/omega/src/thoMap.ml (revision 8900)
@@ -0,0 +1,162 @@
+(* thoMap.ml --
+
+ Copyright (C) 2023- by
+
+ Wolfgang Kilian <kilian@physik.uni-siegen.de>
+ Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
+ Juergen Reuter <juergen.reuter@desy.de>
+
+ WHIZARD is free software; you can redistribute it and/or modify it
+ under the terms of the GNU General Public License as published by
+ the Free Software Foundation; either version 2, or (at your option)
+ any later version.
+
+ WHIZARD is distributed in the hope that it will be useful, but
+ WITHOUT ANY WARRANTY; without even the implied warranty of
+ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+ GNU General Public License for more details.
+
+ You should have received a copy of the GNU General Public License
+ along with this program; if not, write to the Free Software
+ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
+
+(* \thocwmodulesection{Maps to Sets} *)
+
+module type Buckets =
+ sig
+
+ type t
+ type key
+ type element
+
+ val empty : t
+ val add : key -> element -> t -> t
+ val to_lists : t -> (key * element list) list
+ val factorize : (key * element) list -> (key * element list) list
+ val factorize_batches : (key * element) list list -> (key * element list) list
+
+ end
+
+module Buckets (Key : Map.OrderedType) (Element : Set.OrderedType) : Buckets
+ with type key = Key.t and type element = Element.t =
+ struct
+
+ module Keys = Map.Make(Key)
+ module Elements = Set.Make(Element)
+ type t = Elements.t Keys.t
+ type key = Key.t
+ type element = Element.t
+
+ let empty = Keys.empty
+
+ let lookup key map =
+ match Keys.find_opt key map with
+ | None -> Elements.empty
+ | Some set -> set
+
+ let add key element map =
+ Keys.add key (Elements.add element (lookup key map)) map
+
+ let to_lists map =
+ List.map (fun (key, set) -> (key, Elements.elements set)) (Keys.bindings map)
+
+ let add_pairs initial pairs =
+ List.fold_left (fun acc (key, elt) -> add key elt acc) initial pairs
+
+ let of_pairs = add_pairs empty
+
+ let factorize pairs =
+ to_lists (of_pairs pairs)
+
+ let factorize_batches pairs_list =
+ to_lists (List.fold_left add_pairs empty pairs_list)
+
+ end
+
+let random_int_list imax n =
+ let imax = succ imax in
+ let rec random_int_list' acc i =
+ if i = 0 then
+ List.rev acc
+ else
+ random_int_list' (Random.int imax :: acc) (pred i) in
+ random_int_list' [] n
+
+let shuffle l =
+ let a = Array.of_list l in
+ ThoArray.shuffle a;
+ Array.to_list a
+
+module Test =
+ struct
+
+ open OUnit
+
+ module Integers = struct type t = int let compare = compare end
+ module II = Buckets(Integers)(Integers)
+
+ let compare_pair (a1, b1) (a2, b2) =
+ let c = compare a1 a2 in
+ if c <> 0 then
+ c
+ else
+ compare b1 b2
+
+ let ilist = ThoList.range 1 42
+ let mod7 i = (i mod 7, i)
+ let mod7_ilist = List.map mod7 ilist
+ let mod7_ilist_batched = ThoList.chopn 10 mod7_ilist
+ let mod7_factorized = List.sort compare_pair (ThoList.factorize mod7_ilist)
+
+ let factorized_to_string l =
+ ThoList.to_string
+ (fun (i, ilist) -> "(" ^ string_of_int i ^ ", " ^ ThoList.to_string string_of_int ilist ^ ")" )
+ l
+
+ let suite_factorize =
+ "factorize" >:::
+
+ [ "int list" >::
+ (fun () ->
+ assert_equal ~printer:factorized_to_string
+ mod7_factorized (II.factorize mod7_ilist));
+
+ "reversed int list" >::
+ (fun () ->
+ assert_equal ~printer:factorized_to_string
+ mod7_factorized (II.factorize (List.rev mod7_ilist)));
+
+ "shuffled int list" >::
+ (fun () ->
+ assert_equal ~printer:factorized_to_string
+ mod7_factorized (II.factorize (shuffle mod7_ilist))) ]
+
+ let suite_factorize_batches =
+ "factorize_batches" >:::
+
+ [ "int list" >::
+ (fun () ->
+ assert_equal ~printer:factorized_to_string
+ mod7_factorized (II.factorize_batches mod7_ilist_batched));
+
+ "reversed int list" >::
+ (fun () ->
+ assert_equal ~printer:factorized_to_string
+ mod7_factorized (II.factorize_batches (List.rev mod7_ilist_batched)));
+
+ "shuffled int list" >::
+ (fun () ->
+ assert_equal ~printer:factorized_to_string
+ mod7_factorized (II.factorize_batches (shuffle mod7_ilist_batched))) ]
+
+ let suite_buckets =
+ "Buckets" >:::
+
+ [ suite_factorize;
+ suite_factorize ]
+
+ let suite =
+ "ThoMap" >:::
+ [ suite_buckets ]
+
+ end
Index: trunk/omega/src/UFO.ml
===================================================================
--- trunk/omega/src/UFO.ml (revision 8899)
+++ trunk/omega/src/UFO.ml (revision 8900)
@@ -1,2970 +1,3032 @@
(* UFO.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
(* Unfortunately, \texttt{ocamlweb} will not typeset all multi character
operators nicely. E.\,g.~\verb+f @< g+ comes out as [f @< g]. *)
let (<*>) f g x =
f (g x)
let (<**>) f g x y =
f (g x y)
-module SMap = Map.Make (struct type t = string let compare = compare end)
+module SMap = Map.Make(String)
module SSet = Sets.String
module CMap =
Map.Make
(struct
type t = string
let compare = ThoString.compare_caseless
end)
module CSet = Sets.String_Caseless
let error_in_string text start_pos end_pos =
let i = start_pos.Lexing.pos_cnum
and j = end_pos.Lexing.pos_cnum in
String.sub text i (j - i)
let error_in_file name start_pos end_pos =
Printf.sprintf
"%s:%d.%d-%d.%d"
name
start_pos.Lexing.pos_lnum
(start_pos.Lexing.pos_cnum - start_pos.Lexing.pos_bol)
end_pos.Lexing.pos_lnum
(end_pos.Lexing.pos_cnum - end_pos.Lexing.pos_bol)
let parse_string text =
try
UFO_parser.file
UFO_lexer.token
(UFO_lexer.init_position "" (Lexing.from_string text))
with
| UFO_tools.Lexical_Error (msg, start_pos, end_pos) ->
invalid_arg (Printf.sprintf "lexical error (%s) at: `%s'"
msg (error_in_string text start_pos end_pos))
| UFO_syntax.Syntax_Error (msg, start_pos, end_pos) ->
invalid_arg (Printf.sprintf "syntax error (%s) at: `%s'"
msg (error_in_string text start_pos end_pos))
| Parsing.Parse_error ->
invalid_arg ("parse error: " ^ text)
exception File_missing of string
let parse_file name =
let ic =
try open_in name with
| Sys_error msg as exc ->
if msg = name ^ ": No such file or directory" then
raise (File_missing name)
else
raise exc in
let result =
begin
try
UFO_parser.file
UFO_lexer.token
(UFO_lexer.init_position name (Lexing.from_channel ic))
with
| UFO_tools.Lexical_Error (msg, start_pos, end_pos) ->
begin
close_in ic;
invalid_arg (Printf.sprintf
"%s: lexical error (%s)"
(error_in_file name start_pos end_pos) msg)
end
| UFO_syntax.Syntax_Error (msg, start_pos, end_pos) ->
begin
close_in ic;
invalid_arg (Printf.sprintf
"%s: syntax error (%s)"
(error_in_file name start_pos end_pos) msg)
end
| Parsing.Parse_error ->
begin
close_in ic;
invalid_arg ("parse error: " ^ name)
end
end in
close_in ic;
result
(* These are the contents of the Python files after lexical
analysis as context-free variable declarations, before
any semantic interpretation. *)
module type Files =
sig
type t = private
{ particles : UFO_syntax.t;
couplings : UFO_syntax.t;
coupling_orders : UFO_syntax.t;
vertices : UFO_syntax.t;
lorentz : UFO_syntax.t;
parameters : UFO_syntax.t;
propagators : UFO_syntax.t;
decays : UFO_syntax.t }
val parse_directory : string -> t
end
module Files : Files =
struct
type t =
{ particles : UFO_syntax.t;
couplings : UFO_syntax.t;
coupling_orders : UFO_syntax.t;
vertices : UFO_syntax.t;
lorentz : UFO_syntax.t;
parameters : UFO_syntax.t;
propagators : UFO_syntax.t;
decays : UFO_syntax.t }
let parse_directory dir =
let filename stem = Filename.concat dir (stem ^ ".py") in
let parse stem = parse_file (filename stem) in
let parse_optional stem =
try parse stem with File_missing _ -> [] in
{ particles = parse "particles";
couplings = parse "couplings";
coupling_orders = parse_optional "coupling_orders";
vertices = parse "vertices";
lorentz = parse "lorentz";
parameters = parse "parameters";
propagators = parse_optional "propagators";
decays = parse_optional "decays" }
end
let dump_file pfx f =
List.iter
(fun s -> print_endline (pfx ^ ": " ^ s))
(UFO_syntax.to_strings f)
type charge =
| Q_Integer of int
| Q_Fraction of int * int
let charge_to_string = function
| Q_Integer i -> Printf.sprintf "%d" i
| Q_Fraction (n, d) -> Printf.sprintf "%d/%d" n d
module S = UFO_syntax
let find_attrib name attribs =
try
(List.find (fun a -> name = a.S.a_name) attribs).S.a_value
with
| Not_found -> failwith ("UFO.find_attrib: \"" ^ name ^ "\" not found")
let find_attrib name attribs =
(List.find (fun a -> name = a.S.a_name) attribs).S.a_value
let name_to_string ?strip name =
let stripped =
begin match strip, List.rev name with
| Some pfx, head :: tail ->
if pfx = head then
tail
else
failwith ("UFO.name_to_string: expected prefix '" ^ pfx ^
"', got '" ^ head ^ "'")
| _, name -> name
end in
String.concat "." stripped
let name_attrib ?strip name attribs =
match find_attrib name attribs with
| S.Name n -> name_to_string ?strip n
| _ -> invalid_arg ("UFO.name_attrib: " ^ name)
let integer_attrib name attribs =
match find_attrib name attribs with
| S.Integer i -> i
| _ -> invalid_arg ("UFO.integer_attrib: " ^ name)
let charge_attrib name attribs =
match find_attrib name attribs with
| S.Integer i -> Q_Integer i
| S.Fraction (n, d) -> Q_Fraction (n, d)
| _ -> invalid_arg ("UFO.charge_attrib: " ^ name)
let string_attrib name attribs =
match find_attrib name attribs with
| S.String s -> s
| _ -> invalid_arg ("UFO.string_attrib: " ^ name)
let string_expr_attrib name attribs =
match find_attrib name attribs with
| S.Name n -> [S.Macro n]
| S.String s -> [S.Literal s]
| S.String_Expr e -> e
| _ -> invalid_arg ("UFO.string_expr_attrib: " ^ name)
+let young_tableau_attrib name attribs =
+ match find_attrib name attribs with
+ | S.Young_Tableau y -> y
+ | _ -> invalid_arg ("UFO.young_tableau_attrib: " ^ name)
+
let boolean_attrib name attribs =
try
match ThoString.lowercase (name_attrib name attribs) with
| "true" -> true
| "false" -> false
| _ -> invalid_arg ("UFO.boolean_attrib: " ^ name)
with
| Not_found -> false
type value =
| Integer of int
| Fraction of int * int
| Float of float
| Expr of UFOx.Expr.t
| Name of string list
let map_expr f default = function
| Integer _ | Fraction (_, _) | Float _ | Name _ -> default
| Expr e -> f e
let variables = map_expr UFOx.Expr.variables CSet.empty
let functions = map_expr UFOx.Expr.functions CSet.empty
let add_to_set_in_map key element map =
let set = try CMap.find key map with Not_found -> CSet.empty in
CMap.add key (CSet.add element set) map
(* Add all variables in [value] to the [map] from variables
to the names in which they appear, indicating
that [name] depends on these variables. *)
let dependency name value map =
CSet.fold
(fun variable acc -> add_to_set_in_map variable name acc)
(variables value)
map
let dependencies name_value_list =
List.fold_left
(fun acc (name, value) -> dependency name value acc)
CMap.empty
name_value_list
let dependency_to_string (variable, appearences) =
Printf.sprintf
"%s -> {%s}"
variable (String.concat ", " (CSet.elements appearences))
let dependencies_to_strings map =
List.map dependency_to_string (CMap.bindings map)
let expr_to_string =
UFOx.Value.to_string <*> UFOx.Value.of_expr
let value_to_string = function
| Integer i -> Printf.sprintf "%d" i
| Fraction (n, d) -> Printf.sprintf "%d/%d" n d
| Float x -> string_of_float x
| Expr e -> "'" ^ expr_to_string e ^ "'"
| Name n -> name_to_string n
let value_to_expr substitutions = function
| Integer i -> Printf.sprintf "%d" i
| Fraction (n, d) -> Printf.sprintf "%d/%d" n d
| Float x -> string_of_float x
| Expr e -> expr_to_string (substitutions e)
| Name n -> name_to_string n
let value_to_coupling substitutions atom = function
| Integer i -> Coupling.Integer i
| Fraction (n, d) -> Coupling.Quot (Coupling.Integer n, Coupling.Integer d)
| Float x -> Coupling.Float x
| Expr e ->
UFOx.Value.to_coupling atom (UFOx.Value.of_expr (substitutions e))
| Name n -> failwith "UFO.value_to_coupling: Name not supported yet!"
let value_to_numeric = function
| Integer i -> Printf.sprintf "%d" i
| Fraction (n, d) -> Printf.sprintf "%g" (float n /. float d)
| Float x -> Printf.sprintf "%g" x
| Expr e -> invalid_arg ("UFO.value_to_numeric: expr = " ^ (expr_to_string e))
| Name n -> invalid_arg ("UFO.value_to_numeric: name = " ^ name_to_string n)
let value_to_float = function
| Integer i -> float i
| Fraction (n, d) -> float n /. float d
| Float x -> x
| Expr e -> invalid_arg ("UFO.value_to_float: string = " ^ (expr_to_string e))
| Name n -> invalid_arg ("UFO.value_to_float: name = " ^ name_to_string n)
let value_attrib name attribs =
match find_attrib name attribs with
| S.Integer i -> Integer i
| S.Fraction (n, d) -> Fraction (n, d)
| S.Float x -> Float x
| S.String s -> Expr (UFOx.Expr.of_string s)
| S.Name n -> Name n
| _ -> invalid_arg ("UFO.value_attrib: " ^ name)
let string_list_attrib name attribs =
match find_attrib name attribs with
| S.String_List l -> l
| _ -> invalid_arg ("UFO.string_list_attrib: " ^ name)
let name_list_attrib ~strip name attribs =
match find_attrib name attribs with
| S.Name_List l -> List.map (name_to_string ~strip) l
| _ -> invalid_arg ("UFO.name_list_attrib: " ^ name)
let integer_list_attrib name attribs =
match find_attrib name attribs with
| S.Integer_List l -> l
| _ -> invalid_arg ("UFO.integer_list_attrib: " ^ name)
let order_dictionary_attrib name attribs =
match find_attrib name attribs with
| S.Order_Dictionary d -> d
| _ -> invalid_arg ("UFO.order_dictionary_attrib: " ^ name)
let coupling_dictionary_attrib ~strip name attribs =
match find_attrib name attribs with
| S.Coupling_Dictionary d ->
List.map (fun (i, j, c) -> (i, j, name_to_string ~strip c)) d
| _ -> invalid_arg ("UFO.coupling_dictionary_attrib: " ^ name)
let decay_dictionary_attrib name attribs =
match find_attrib name attribs with
| S.Decay_Dictionary d ->
List.map (fun (p, w) -> (List.map List.hd p, w)) d
| _ -> invalid_arg ("UFO.decay_dictionary_attrib: " ^ name)
(*i The following doesn't typecheck in applications, even with
type annotations ...
let attrib_handlers : type attribs value.
string -> string -> attribs ->
((string -> attribs -> value) -> string -> value) *
((string -> attribs -> value) -> string -> value -> value) =
fun kind symbol attribs ->
let required query name =
try
query name attribs
with
| Not_found ->
invalid_arg
(Printf.sprintf
"fatal UFO error: mandatory attribute `%s' missing for %s `%s'!"
name kind symbol)
and optional query name default =
try
query name attribs
with
| Not_found -> default in
(required, optional) i*)
let required_handler kind symbol attribs query name =
try
query name attribs
with
| Not_found ->
invalid_arg
(Printf.sprintf
"fatal UFO error: mandatory attribute `%s' missing for %s `%s'!"
name kind symbol)
let optional_handler attribs query name default =
try
query name attribs
with
| Not_found -> default
(* The UFO paper~\cite{Degrande:2011ua} is not clear on the question
whether the \texttt{name} attribute of an instance
must match its Python name.
While the examples appear to imply this, there are examples of
UFO files in the wild that violate this constraint. *)
let warn_symbol_name file symbol name =
if name <> symbol then
Printf.eprintf
"UFO: warning: symbol '%s' <> name '%s' in %s.py: \
while legal in UFO, it is unusual and can cause problems!\n"
symbol name file
let valid_fortran_id kind name =
if not (ThoString.valid_fortran_id name) then
invalid_arg
(Printf.sprintf
"fatal UFO error: the %s `%s' is not a valid fortran id!"
kind name)
let map_to_alist map =
SMap.fold (fun key value acc -> (key, value) :: acc) map []
let keys map =
SMap.fold (fun key _ acc -> key :: acc) map []
let keys_caseless map =
CMap.fold (fun key _ acc -> key :: acc) map []
let values map =
SMap.fold (fun _ value acc -> value :: acc) map []
module SKey =
struct
type t = string
let hash = Hashtbl.hash
let equal = (=)
end
module SHash = Hashtbl.Make (SKey)
module type Particle =
sig
type t = private
{ pdg_code : int;
name : string;
antiname : string;
spin : UFOx.Lorentz.r;
color : UFOx.Color.r;
mass : string;
width : string;
propagator : string option;
texname : string;
antitexname : string;
charge : charge;
ghost_number : int;
lepton_number : int;
y : charge;
goldstone : bool;
propagating : bool; (* NOT HANDLED YET! *)
line : string option; (* NOT HANDLED YET! *)
is_anti : bool }
val of_file : S.t -> t SMap.t
val to_string : string -> t -> string
val conjugate : t -> t
val map_mass_and_width : (string -> string) -> t -> t
val force_spinor : t -> t
val force_conjspinor : t -> t
val force_majorana : t -> t
val is_majorana : t -> bool
val is_ghost : t -> bool
val is_goldstone : t -> bool
val is_physical : t -> bool
val filter : (t -> bool) -> t SMap.t -> t SMap.t
end
module Particle : Particle =
struct
type t =
{ pdg_code : int;
name : string;
antiname : string;
spin : UFOx.Lorentz.r;
color : UFOx.Color.r;
mass : string;
width : string;
propagator : string option;
texname : string;
antitexname : string;
charge : charge;
ghost_number : int;
lepton_number : int;
y : charge;
goldstone : bool;
propagating : bool; (* NOT HANDLED YET! *)
line : string option; (* NOT HANDLED YET! *)
is_anti : bool }
let to_string symbol p =
Printf.sprintf
"particle: %s => [pdg = %d, name = '%s'/'%s', \
spin = %s, color = %s, \
mass = %s, width = %s,%s \
Q = %s, G = %d, L = %d, Y = %s, \
TeX = '%s'/'%s'%s]"
symbol p.pdg_code p.name p.antiname
(UFOx.Lorentz.rep_to_string p.spin)
(UFOx.Color.rep_to_string p.color)
p.mass p.width
(match p.propagator with
| None -> ""
| Some p -> " propagator = " ^ p ^ ",")
(charge_to_string p.charge)
p.ghost_number p.lepton_number
(charge_to_string p.y)
p.texname p.antitexname
(if p.goldstone then ", GB" else "")
let conjugate_charge = function
| Q_Integer i -> Q_Integer (-i)
| Q_Fraction (n, d) -> Q_Fraction (-n, d)
let is_neutral p =
(p.name = p.antiname)
(* We \emph{must not} mess with [pdg_code] and [color] if
the particle is neutral! *)
let conjugate p =
if is_neutral p then
p
else
{ pdg_code = - p.pdg_code;
name = p.antiname;
antiname = p.name;
spin = UFOx.Lorentz.rep_conjugate p.spin;
color = UFOx.Color.rep_conjugate p.color;
mass = p.mass;
width = p.width;
propagator = p.propagator;
texname = p.antitexname;
antitexname = p.texname;
charge = conjugate_charge p.charge;
ghost_number = - p.ghost_number;
lepton_number = - p.lepton_number;
y = conjugate_charge p.y;
goldstone = p.goldstone;
propagating = p.propagating;
line = p.line;
is_anti = not p.is_anti }
let map_mass_and_width f p =
{ p with mass = f p.mass; width = f p.width }
let of_file1 map d =
let symbol = d.S.name in
match d.S.kind, d.S.attribs with
| [ "Particle" ], attribs ->
let required query name =
required_handler "particle" symbol attribs query name
and optional query name default =
optional_handler attribs query name default in
let name = required string_attrib "name"
and antiname = required string_attrib "antiname" in
let neutral = (name = antiname) in
let pdg_code = required integer_attrib "pdg_code" in
SMap.add symbol
{ (* The required attributes per UFO docs. *)
pdg_code;
name; antiname;
spin =
UFOx.Lorentz.rep_of_int neutral (required integer_attrib "spin");
color =
- UFOx.Color.rep_of_int neutral (required integer_attrib "color");
+ UFOx.Color.rep_of_int_or_young_tableau neutral
+ (try Some (integer_attrib "color" attribs) with _ -> None)
+ (try Some (young_tableau_attrib "color_young" attribs) with _ -> None);
mass = required (name_attrib ~strip:"Param") "mass";
width = required (name_attrib ~strip:"Param") "width";
texname = required string_attrib "texname";
antitexname = required string_attrib "antitexname";
charge = required charge_attrib "charge";
(* The optional attributes per UFO docs. *)
ghost_number = optional integer_attrib "GhostNumber" 0;
lepton_number = optional integer_attrib "LeptonNumber" 0;
y = optional charge_attrib "Y" (Q_Integer 0);
goldstone = optional boolean_attrib "goldstone" false;
propagating = optional boolean_attrib "propagating" true;
line =
(try Some (name_attrib "line" attribs) with _ -> None);
(* Undocumented extensions. *)
propagator =
(try Some (name_attrib ~strip:"Prop" "propagator" attribs) with _ -> None);
(* O'Mega extensions. *)
(* Instead of ``first come is particle'' rely on
a negative PDG code to identify antiparticles. *)
is_anti = pdg_code < 0 } map
| [ "anti"; p ], [] ->
begin
try
SMap.add symbol (conjugate (SMap.find p map)) map
with
| Not_found ->
invalid_arg
("Particle.of_file: " ^ p ^ ".anti() not yet defined!")
end
| _ -> invalid_arg ("Particle.of_file: " ^ name_to_string d.S.kind)
let of_file particles =
List.fold_left of_file1 SMap.empty particles
let is_spinor p =
match UFOx.Lorentz.omega p.spin with
| Coupling.Spinor | Coupling.ConjSpinor | Coupling.Majorana -> true
| _ -> false
(* \begin{dubious}
TODO: this is a bit of a hack: try to expose the type
[UFOx.Lorentz_Atom'.r] instead.
\end{dubious} *)
let force_spinor p =
if is_spinor p then
{ p with spin = UFOx.Lorentz.rep_of_int false 2 }
else
p
let force_conjspinor p =
if is_spinor p then
{ p with spin = UFOx.Lorentz.rep_of_int false (-2) }
else
p
let force_majorana p =
if is_spinor p then
{ p with spin = UFOx.Lorentz.rep_of_int true 2 }
else
p
let is_majorana p =
match UFOx.Lorentz.omega p.spin with
| Coupling.Majorana | Coupling.Vectorspinor | Coupling.Maj_Ghost -> true
| _ -> false
let is_ghost p =
p.ghost_number <> 0
let is_goldstone p =
p.goldstone
let is_physical p =
not (is_ghost p || is_goldstone p)
let filter predicate map =
SMap.filter (fun symbol p -> predicate p) map
end
module type UFO_Coupling =
sig
type t = private
{ name : string;
value : UFOx.Expr.t;
order : (string * int) list }
val of_file : S.t -> t SMap.t
val to_string : string -> t -> string
end
module UFO_Coupling : UFO_Coupling =
struct
type t =
{ name : string;
value : UFOx.Expr.t;
order : (string * int) list }
let order_to_string orders =
String.concat ", "
(List.map (fun (s, i) -> Printf.sprintf "'%s':%d" s i) orders)
let to_string symbol c =
Printf.sprintf
"coupling: %s => [name = '%s', value = '%s', order = [%s]]"
symbol c.name (expr_to_string c.value) (order_to_string c.order)
let of_file1 map d =
let symbol = d.S.name in
match d.S.kind, d.S.attribs with
| [ "Coupling" ], attribs ->
let required query name =
required_handler "coupling" symbol attribs query name in
let name = required string_attrib "name" in
warn_symbol_name "couplings" symbol name;
valid_fortran_id "coupling" name;
SMap.add symbol
{ name;
value = UFOx.Expr.of_string (required string_attrib "value");
order = required order_dictionary_attrib "order" } map
| _ -> invalid_arg ("UFO_Coupling.of_file: " ^ name_to_string d.S.kind)
let of_file couplings =
List.fold_left of_file1 SMap.empty couplings
end
module type Coupling_Order =
sig
type t = private
{ name : string;
expansion_order : int;
hierarchy : int }
val of_file : S.t -> t SMap.t
val to_string : string -> t -> string
end
module Coupling_Order : Coupling_Order =
struct
type t =
{ name : string;
expansion_order : int;
hierarchy : int }
let to_string symbol c =
Printf.sprintf
"coupling_order: %s => [name = '%s', \
expansion_order = '%d', \
hierarchy = %d]"
symbol c.name c.expansion_order c.hierarchy
let of_file1 map d =
let symbol = d.S.name in
match d.S.kind, d.S.attribs with
| [ "CouplingOrder" ], attribs ->
let required query name =
required_handler "coupling order" symbol attribs query name in
let name = required string_attrib "name" in
warn_symbol_name "coupling_orders" symbol name;
SMap.add symbol
{ name;
expansion_order = required integer_attrib "expansion_order";
hierarchy = required integer_attrib "hierarchy" } map
| _ -> invalid_arg ("Coupling_order.of_file: " ^ name_to_string d.S.kind)
let of_file coupling_orders =
List.fold_left of_file1 SMap.empty coupling_orders
end
module type Lorentz_UFO =
sig
(* If the \texttt{name} attribute of a \texttt{Lorentz} object
does \emph{not} match the the name of the object, we need the
latter for weeding out unused Lorentz structures (see
[Vertex.contains] below). Therefore, we keep it around. *)
type t = private
{ name : string;
symbol : string;
spins : int list;
structure : UFOx.Lorentz.t }
val of_file : S.t -> t SMap.t
val to_string : string -> t -> string
end
module Lorentz_UFO : Lorentz_UFO =
struct
type t =
{ name : string;
symbol : string;
spins : int list;
structure : UFOx.Lorentz.t }
let to_string symbol l =
Printf.sprintf
"lorentz: %s => [name = '%s', spins = [%s], \
structure = %s]"
symbol l.name
(String.concat ", " (List.map string_of_int l.spins))
(UFOx.Lorentz.to_string l.structure)
let of_file1 map d =
let symbol = d.S.name in
match d.S.kind, d.S.attribs with
| [ "Lorentz" ], attribs ->
let required query name =
required_handler "lorentz" symbol attribs query name in
let name = required string_attrib "name" in
warn_symbol_name "lorentz" symbol name;
valid_fortran_id "lorentz" symbol;
SMap.add symbol
{ name;
symbol;
spins = required integer_list_attrib "spins";
structure =
UFOx.Lorentz.of_string (required string_attrib "structure") } map
| _ -> invalid_arg ("Lorentz.of_file: " ^ name_to_string d.S.kind)
let of_file lorentz =
List.fold_left of_file1 SMap.empty lorentz
end
module type Vertex =
sig
type lcc = private (* Lorentz-color-coupling *)
{ lorentz : string;
color : UFOx.Color.t;
coupling : string }
type t = private
{ name : string;
particles : string array;
lcc : lcc list }
val of_file : Particle.t SMap.t -> S.t -> t SMap.t
val to_string : string -> t -> string
val to_string_expanded :
Lorentz_UFO.t SMap.t -> UFO_Coupling.t SMap.t -> t -> string
val contains : Particle.t SMap.t -> (Particle.t -> bool) -> t -> bool
val filter : (t -> bool) -> t SMap.t -> t SMap.t
end
module Vertex : Vertex =
struct
type lcc =
{ lorentz : string;
color : UFOx.Color.t;
coupling : string }
type t =
{ name : string;
particles : string array;
lcc : lcc list }
let to_string symbol c =
Printf.sprintf
"vertex: %s => [name = '%s', particles = [%s], \
lorentz-color-couplings = [%s]"
symbol c.name
(String.concat
", " (Array.to_list c.particles))
(String.concat
", "
(List.map
(fun lcc ->
Printf.sprintf
"%s * %s * %s"
lcc.coupling lcc.lorentz
(UFOx.Color.to_string lcc.color))
c.lcc))
let to_string_expanded lorentz couplings c =
let expand_lorentz s =
try
UFOx.Lorentz.to_string (SMap.find s lorentz).Lorentz_UFO.structure
with
| Not_found -> "?" in
Printf.sprintf
"expanded: [%s] -> { lorentz-color-couplings = [%s] }"
(String.concat ", " (Array.to_list c.particles))
(String.concat
", "
(List.map
(fun lcc ->
Printf.sprintf
"%s * %s * %s"
lcc.coupling (expand_lorentz lcc.lorentz)
(UFOx.Color.to_string lcc.color))
c.lcc))
let contains particles predicate v =
let p = v.particles in
let rec contains' i =
if i < 0 then
false
else if predicate (SMap.find p.(i) particles) then
true
else
contains' (pred i) in
contains' (Array.length p - 1)
let force_adj_identity1 adj_indices = function
| UFOx.Color_Atom.Identity (a, b) as atom ->
begin match List.mem a adj_indices, List.mem b adj_indices with
| true, true -> UFOx.Color_Atom.Identity8 (a, b)
| false, false -> atom
| true, false | false, true ->
invalid_arg "force_adj_identity: mixed representations!"
end
| atom -> atom
let force_adj_identity adj_indices tensor =
UFOx.Color.map_atoms (force_adj_identity1 adj_indices) tensor
let find_adj_indices map particles =
let adj_indices = ref [] in
Array.iteri
(fun i p ->
(* We must pattern match against the O'Mega representation,
because [UFOx.Color.r] is abstract. *)
match UFOx.Color.omega (SMap.find p map).Particle.color with
| Color.AdjSUN _ -> adj_indices := succ i :: !adj_indices
| _ -> ())
particles;
!adj_indices
let classify_color_indices map particles =
let fund_indices = ref []
and conj_indices = ref []
and adj_indices = ref [] in
Array.iteri
(fun i p ->
(* We must pattern match against the O'Mega representation,
because [UFOx.Color.r] is abstract. *)
match UFOx.Color.omega (SMap.find p map).Particle.color with
| Color.SUN n ->
if n > 0 then
fund_indices := succ i :: !fund_indices
else if n < 0 then
conj_indices := succ i :: !conj_indices
else
failwith "classify_color_indices: SU(0)"
| Color.AdjSUN n ->
if n <> 0 then
adj_indices := succ i :: !adj_indices
else
failwith "classify_color_indices: SU(0)"
| _ -> ())
particles;
(!fund_indices, !conj_indices, !adj_indices)
(* FIXME: would have expected the opposite order \ldots *)
let force_identity1 (fund_indices, conj_indices, adj_indices) = function
| UFOx.Color_Atom.Identity (a, b) as atom ->
if List.mem a fund_indices then
begin
if List.mem b conj_indices then
UFOx.Color_Atom.Identity (b, a)
else
invalid_arg "force_adj_identity: mixed representations!"
end
else if List.mem a conj_indices then
begin
if List.mem b fund_indices then
UFOx.Color_Atom.Identity (a, b)
else
invalid_arg "force_adj_identity: mixed representations!"
end else if List.mem a adj_indices then begin
if List.mem b adj_indices then
UFOx.Color_Atom.Identity8 (a, b)
else
invalid_arg "force_adj_identity: mixed representations!"
end
else
atom
| atom -> atom
let force_identity indices tensor =
UFOx.Color.map_atoms (force_identity1 indices) tensor
(* Here we don't have the Lorentz structures available yet.
Thus we set [fermion_lines = []] for now and correct this
later. *)
let of_file1 particle_map map d =
let symbol = d.S.name in
match d.S.kind, d.S.attribs with
| [ "Vertex" ], attribs ->
let required query name =
required_handler "vertex" symbol attribs query name in
let name = required string_attrib "name" in
warn_symbol_name "vertices" symbol name;
let particles =
Array.of_list (required (name_list_attrib ~strip:"P") "particles") in
let color =
let indices = classify_color_indices particle_map particles in
Array.of_list
(List.map
(force_identity indices <*> UFOx.Color.of_string)
(required string_list_attrib "color"))
and lorentz =
Array.of_list (required (name_list_attrib ~strip:"L") "lorentz")
and couplings_alist =
required (coupling_dictionary_attrib ~strip:"C") "couplings" in
let lcc =
List.map
(fun (i, j, c) ->
{ lorentz = lorentz.(j);
color = color.(i);
coupling = c })
couplings_alist in
SMap.add symbol { name; particles; lcc } map
| _ -> invalid_arg ("Vertex.of_file: " ^ name_to_string d.S.kind)
let of_file particles vertices =
List.fold_left (of_file1 particles) SMap.empty vertices
let filter predicate map =
SMap.filter (fun symbol p -> predicate p) map
end
module type Parameter =
sig
type nature = private Internal | External
type ptype = private Real | Complex
type t = private
{ name : string;
nature : nature;
ptype : ptype;
value : value;
texname : string;
lhablock : string option;
lhacode : int list option;
sequence : int }
val of_file : S.t -> t SMap.t
val to_string : string -> t -> string
val missing : string -> t
val map_names : (string -> string) -> t -> t
end
module Parameter : Parameter =
struct
type nature = Internal | External
let nature_to_string = function
| Internal -> "internal"
| External -> "external"
let nature_of_string = function
| "internal" -> Internal
| "external" -> External
| s -> invalid_arg ("Parameter.nature_of_string: " ^ s)
type ptype = Real | Complex
let ptype_to_string = function
| Real -> "real"
| Complex -> "complex"
let ptype_of_string = function
| "real" -> Real
| "complex" -> Complex
| s -> invalid_arg ("Parameter.ptype_of_string: " ^ s)
type t =
{ name : string;
nature : nature;
ptype : ptype;
value : value;
texname : string;
lhablock : string option;
lhacode : int list option;
sequence : int }
let to_string symbol p =
Printf.sprintf
"parameter: %s => [#%d, name = '%s', nature = %s, type = %s, \
value = %s, texname = '%s', \
lhablock = %s, lhacode = [%s]]"
symbol p.sequence p.name
(nature_to_string p.nature)
(ptype_to_string p.ptype)
(value_to_string p.value) p.texname
(match p.lhablock with None -> "???" | Some s -> s)
(match p.lhacode with
| None -> ""
| Some c -> String.concat ", " (List.map string_of_int c))
let of_file1 (map, n) d =
let symbol = d.S.name in
match d.S.kind, d.S.attribs with
| [ "Parameter" ], attribs ->
let required query name =
required_handler "particle" symbol attribs query name in
let name = required string_attrib "name" in
warn_symbol_name "parameters" symbol name;
valid_fortran_id "parameter" name;
(SMap.add symbol
{ name;
nature = nature_of_string (required string_attrib "nature");
ptype = ptype_of_string (required string_attrib "type");
value = required value_attrib "value";
texname = required string_attrib "texname";
lhablock =
(try Some (string_attrib "lhablock" attribs) with
Not_found -> None);
lhacode =
(try Some (integer_list_attrib "lhacode" attribs) with
Not_found -> None);
sequence = n } map, succ n)
| _ -> invalid_arg ("Parameter.of_file: " ^ name_to_string d.S.kind)
let of_file parameters =
let map, _ = List.fold_left of_file1 (SMap.empty, 0) parameters in
map
let missing name =
{ name;
nature = External;
ptype = Real;
value = Integer 0;
texname = Printf.sprintf "\\texttt{%s}" name;
lhablock = None;
lhacode = None;
sequence = 0 }
(* If the [Name] has a prefix, apply [f] only to the last component. *)
let map_value f = function
| (Integer _ | Fraction (_, _) | Float _ as v) -> v
| Name n ->
begin match List.rev n with
| [] -> Name []
| stem :: prefix -> Name (List.rev (f stem :: prefix))
end
| Expr e -> Expr (UFOx.Expr.map_names f e)
let map_names f p =
{ p with name = f p.name; value = map_value f p.value }
end
(* Macros are encoded as a special [S.declaration] with
[S.kind = "$"]. This is slightly hackish, but general enough
and the overhead of a special union type is probably not worth
the effort. *)
module type Macro =
sig
type t
val empty : t
(* The domains and codomains are still a bit too much ad hoc,
but it does the job. *)
val define : t -> string -> S.value -> t
val expand_string : t -> string -> S.value
val expand_expr : t -> S.string_atom list -> string
(* Only for documentation: *)
val expand_atom : t -> S.string_atom -> string
end
module Macro : Macro =
struct
type t = S.value SMap.t
let empty = SMap.empty
let define macros name expansion =
SMap.add name expansion macros
let expand_string macros name =
SMap.find name macros
let rec expand_atom macros = function
| S.Literal s -> s
| S.Macro [name] ->
begin
try
begin match SMap.find name macros with
| S.String s -> s
| S.String_Expr expr -> expand_expr macros expr
| _ -> invalid_arg ("expand_atom: not a string: " ^ name)
end
with
| Not_found -> invalid_arg ("expand_atom: not found: " ^ name)
end
| S.Macro [] -> invalid_arg "expand_atom: empty"
| S.Macro name ->
invalid_arg ("expand_atom: compound name: " ^ String.concat "." name)
and expand_expr macros expr =
String.concat "" (List.map (expand_atom macros) expr)
end
module type Propagator_UFO =
sig
type t = (* private *)
{ name : string;
numerator : UFOx.Lorentz.t;
denominator : UFOx.Lorentz.t }
val of_file : S.t -> t SMap.t
val to_string : string -> t -> string
end
module Propagator_UFO : Propagator_UFO =
struct
type t =
{ name : string;
numerator : UFOx.Lorentz.t;
denominator : UFOx.Lorentz.t }
let to_string symbol p =
Printf.sprintf
"propagator: %s => [name = '%s', numerator = '%s', \
denominator = '%s']"
symbol p.name
(UFOx.Lorentz.to_string p.numerator)
(UFOx.Lorentz.to_string p.denominator)
(* The \texttt{denominator} attribute is optional and
there is a default (cf.~\texttt{arXiv:1308.1668}) *)
let default_denominator =
"P('mu', id) * P('mu', id) \
- Mass(id) * Mass(id) \
+ complex(0,1) * Mass(id) * Width(id)"
let of_string_with_error_correction symbol num_or_den s =
try
UFOx.Lorentz.of_string s
with
| Invalid_argument msg ->
begin
let fixed = s ^ ")" in
try
let tensor = UFOx.Lorentz.of_string fixed in
Printf.eprintf
"UFO.Propagator.of_string: added missing closing parenthesis \
in %s of %s: \"%s\"\n"
num_or_den symbol s;
tensor
with
| Invalid_argument _ ->
invalid_arg
(Printf.sprintf
"UFO.Propagator.of_string: %s of %s: %s in \"%s\"\n"
num_or_den symbol msg fixed)
end
let of_file1 (macros, map) d =
let symbol = d.S.name in
match d.S.kind, d.S.attribs with
| [ "Propagator" ], attribs ->
let required query name =
required_handler "particle" symbol attribs query name
and optional query name default =
optional_handler attribs query name default in
let name = required string_attrib "name" in
warn_symbol_name "propagators" symbol name;
let num_string_expr = required string_expr_attrib "numerator"
and den_string =
begin match optional find_attrib "denominator"
(S.String default_denominator) with
| S.String s -> s
| S.Name [n] ->
begin match Macro.expand_string macros n with
| S.String s -> s
| _ -> invalid_arg "Propagator.denominator"
end
| _ -> invalid_arg "Propagator.denominator: "
end in
let num_string = Macro.expand_expr macros num_string_expr in
let numerator =
of_string_with_error_correction symbol "numerator" num_string
and denominator =
of_string_with_error_correction symbol "denominator" den_string in
(macros, SMap.add symbol { name; numerator; denominator } map)
| [ "$" ], [ macro ] ->
begin match macro.S.a_value with
| S.String _ as s ->
(Macro.define macros symbol s, map);
| S.String_Expr expr ->
let expanded = S.String (Macro.expand_expr macros expr) in
(Macro.define macros symbol expanded, map)
| _ -> invalid_arg ("Propagator:of_file: not a string " ^ symbol)
end
| [ "$" ], [] ->
invalid_arg ("Propagator:of_file: empty declaration " ^ symbol)
| [ "$" ], _ ->
invalid_arg ("Propagator:of_file: multiple declaration " ^ symbol)
| _ -> invalid_arg ("Propagator:of_file: " ^ name_to_string d.S.kind)
let of_file propagators =
let _, propagators' =
List.fold_left of_file1 (Macro.empty, SMap.empty) propagators in
propagators'
end
module type Decay =
sig
type t = private
{ name : string;
particle : string;
widths : (string list * string) list }
val of_file : S.t -> t SMap.t
val to_string : string -> t -> string
end
module Decay : Decay =
struct
type t =
{ name : string;
particle : string;
widths : (string list * string) list }
let width_to_string ws =
String.concat ", "
(List.map
(fun (ps, w) ->
"(" ^ String.concat ", " ps ^ ") -> '" ^ w ^ "'")
ws)
let to_string symbol d =
Printf.sprintf
"decay: %s => [name = '%s', particle = '%s', widths = [%s]]"
symbol d.name d.particle (width_to_string d.widths)
let of_file1 map d =
let symbol = d.S.name in
match d.S.kind, d.S.attribs with
| [ "Decay" ], attribs ->
let required query name =
required_handler "particle" symbol attribs query name in
let name = required string_attrib "name" in
warn_symbol_name "decays" symbol name;
SMap.add symbol
{ name;
particle = required (name_attrib ~strip:"P") "particle";
widths = required decay_dictionary_attrib "partial_widths" } map
| _ -> invalid_arg ("Decay.of_file: " ^ name_to_string d.S.kind)
let of_file decays =
List.fold_left of_file1 SMap.empty decays
end
(* We can read the spinor representations off the
vertices to check for consistency. *)
(* \begin{dubious}
Note that we have to conjugate the representations!
\end{dubious} *)
let collect_spinor_reps_of_vertex particles lorentz v sets =
List.fold_left
(fun sets' lcc ->
let l = (SMap.find lcc.Vertex.lorentz lorentz).Lorentz_UFO.structure in
List.fold_left
(fun (spinors, conj_spinors as sets'') (i, rep) ->
let p = v.Vertex.particles.(pred i) in
match UFOx.Lorentz.omega rep with
| Coupling.ConjSpinor -> (SSet.add p spinors, conj_spinors)
| Coupling.Spinor -> (spinors, SSet.add p conj_spinors)
| _ -> sets'')
sets' (UFOx.Lorentz.classify_indices l))
sets v.Vertex.lcc
let collect_spinor_reps_of_vertices particles lorentz vertices =
SMap.fold
(fun _ v -> collect_spinor_reps_of_vertex particles lorentz v)
vertices (SSet.empty, SSet.empty)
let lorentz_reps_of_vertex particles v =
ThoList.alist_of_list ~predicate:(not <*> UFOx.Lorentz.rep_trivial) ~offset:1
(List.map
(fun p ->
(* Why do we need to conjugate??? *)
UFOx.Lorentz.rep_conjugate
(SMap.find p particles).Particle.spin)
(Array.to_list v.Vertex.particles))
let rep_compatible rep_vertex rep_particle =
let open UFOx.Lorentz in
let open Coupling in
match omega rep_vertex, omega rep_particle with
| (Spinor | ConjSpinor), Majorana -> true
| r1, r2 -> r1 = r2
let reps_compatible reps_vertex reps_particles =
List.for_all2
(fun (iv, rv) (ip, rp) -> iv = ip && rep_compatible rv rp)
reps_vertex reps_particles
let check_lorentz_reps_of_vertex particles lorentz v =
let reps_particles =
List.sort compare (lorentz_reps_of_vertex particles v) in
List.iter
(fun lcc ->
let l = (SMap.find lcc.Vertex.lorentz lorentz).Lorentz_UFO.structure in
let reps_vertex = List.sort compare (UFOx.Lorentz.classify_indices l) in
if not (reps_compatible reps_vertex reps_particles) then begin
Printf.eprintf "%s <> %s [%s]\n"
(UFOx.Index.classes_to_string
UFOx.Lorentz.rep_to_string reps_particles)
(UFOx.Index.classes_to_string
UFOx.Lorentz.rep_to_string reps_vertex)
v.Vertex.name (* [(Vertex.to_string v.Vertex.name v)] *);
(* [invalid_arg "check_lorentz_reps_of_vertex"] *) ()
end)
v.Vertex.lcc
let color_reps_of_vertex particles v =
ThoList.alist_of_list ~predicate:(not <*> UFOx.Color.rep_trivial) ~offset:1
(List.map
(fun p -> (SMap.find p particles).Particle.color)
(Array.to_list v.Vertex.particles))
let check_color_reps_of_vertex particles v =
let reps_particles =
List.sort compare (color_reps_of_vertex particles v) in
List.iter
(fun lcc ->
let reps_vertex =
List.sort compare (UFOx.Color.classify_indices lcc.Vertex.color) in
if reps_vertex <> reps_particles then begin
- Printf.printf "%s <> %s\n"
+ Printf.eprintf "particles: %s\n<> vertex: %s\n"
(UFOx.Index.classes_to_string UFOx.Color.rep_to_string reps_particles)
(UFOx.Index.classes_to_string UFOx.Color.rep_to_string reps_vertex);
invalid_arg "check_color_reps_of_vertex"
end)
v.Vertex.lcc
module P = Permutation.Default
module type Lorentz =
sig
type spins = private
| Unused
| Unique of Coupling.lorentz array
| Ambiguous of Coupling.lorentz array SMap.t
type t = private
{ name : string;
n : int;
spins : spins;
structure : UFO_Lorentz.t;
fermion_lines : Coupling.fermion_lines;
variables : string list }
val required_charge_conjugates : t -> t list
val permute : P.t -> t -> t
val of_lorentz_UFO :
Particle.t SMap.t -> Vertex.t SMap.t ->
Lorentz_UFO.t SMap.t -> t SMap.t
val lorentz_to_string : Coupling.lorentz -> string
val to_string : string -> t -> string
end
module Lorentz : Lorentz =
struct
let rec lorentz_to_string = function
| Coupling.Scalar -> "Scalar"
| Coupling.Spinor -> "Spinor"
| Coupling.ConjSpinor -> "ConjSpinor"
| Coupling.Majorana -> "Majorana"
| Coupling.Maj_Ghost -> "Maj_Ghost"
| Coupling.Vector -> "Vector"
| Coupling.Massive_Vector -> "Massive_Vector"
| Coupling.Vectorspinor -> "Vectorspinor"
| Coupling.Tensor_1 -> "Tensor_1"
| Coupling.Tensor_2 -> "Tensor_2"
| Coupling.BRS l -> "BRS(" ^ lorentz_to_string l ^ ")"
(* Unlike UFO, O'Mega distinguishes bewteen spinors
and conjugate spinors. However, we can inspect
the particles in the vertices in which a Lorentz
structure is used to determine the correct
quantum numbers.
Most model files in the real world contain unused Lorentz
structures. This is not a problem, we can just ignore them. *)
type spins =
| Unused
| Unique of Coupling.lorentz array
| Ambiguous of Coupling.lorentz array SMap.t
(* \begin{dubious}
Use [UFO_targets.Fortran.fusion_name] below in order
to avoid communication problems. Or even move away
from strings alltogether.
\end{dubious} *)
type t =
{ name : string;
n : int;
spins : spins;
structure : UFO_Lorentz.t;
fermion_lines : Coupling.fermion_lines;
variables : string list }
(* Add one charge conjugated fermion lines. *)
let charge_conjugate1 l (ket, bra as fermion_line) =
{ name = l.name ^ Printf.sprintf "_c%x%x" ket bra;
n = l.n;
spins = l.spins;
structure = UFO_Lorentz.charge_conjugate fermion_line l.structure;
fermion_lines = l.fermion_lines;
variables = l.variables }
(* Add several charge conjugated fermion lines. *)
let charge_conjugate l fermion_lines =
List.fold_left charge_conjugate1 l fermion_lines
(*i
let all_charge_conjugates l =
List.map (charge_conjugate l) (ThoList.power l.fermion_lines)
i*)
(* Add all combinations of charge conjugated fermion lines
that don't leave the fusion. *)
let required_charge_conjugates l =
let saturated_fermion_lines =
List.filter
(fun (ket, bra) -> ket != 1 && bra != 1)
l.fermion_lines in
List.map (charge_conjugate l) (ThoList.power saturated_fermion_lines)
let permute_spins p = function
| Unused -> Unused
| Unique s -> Unique (P.array p s)
| Ambiguous map -> Ambiguous (SMap.map (P.array p) map)
(* Note that we apply the \emph{inverse} permutation to
the indices in order to match the permutation of the
particles/spins. *)
let permute_structure n p (l, f) =
let permuted = P.array (P.inverse p) (Array.init n succ) in
let permute_index i =
if i > 0 then
UFOx.Index.map_position (fun pos -> permuted.(pred pos)) i
else
i in
(UFO_Lorentz.map_indices permute_index l,
UFO_Lorentz.map_fermion_lines permute_index f)
let permute p l =
let structure, fermion_lines =
permute_structure l.n p (l.structure, l.fermion_lines) in
{ name = l.name ^ "_p" ^ P.to_string (P.inverse p);
n = l.n;
spins = permute_spins p l.spins;
structure;
fermion_lines;
variables = l.variables }
let omega_lorentz_reps n alist =
let reps = Array.make n Coupling.Scalar in
List.iter
(fun (i, rep) -> reps.(pred i) <- UFOx.Lorentz.omega rep)
alist;
reps
let contained lorentz vertex =
List.exists
(fun lcc1 -> lcc1.Vertex.lorentz = lorentz.Lorentz_UFO.symbol)
vertex.Vertex.lcc
(* Find all vertices in with the Lorentz structure [lorentz] is
used and build a map from those vertices to the O'Mega
Lorentz representations inferred from UFO's Lorentz
structure and the [particles] involved.
Then scan the bindings and check that we have inferred
the same Lorentz representation from all vertices. *)
let lorentz_reps_of_structure particles vertices lorentz =
let uses =
SMap.fold
(fun name v acc ->
if contained lorentz v then
SMap.add
name
(omega_lorentz_reps
(Array.length v.Vertex.particles)
(lorentz_reps_of_vertex particles v)) acc
else
acc) vertices SMap.empty in
let variants =
ThoList.uniq (List.sort compare (List.map snd (SMap.bindings uses))) in
match variants with
| [] -> Unused
| [s] -> Unique s
| _ ->
Printf.eprintf "UFO.Lorentz.lorentz_reps_of_structure: AMBIGUOUS!\n";
List.iter
(fun variant ->
Printf.eprintf
"UFO.Lorentz.lorentz_reps_of_structure: %s\n"
(ThoList.to_string lorentz_to_string (Array.to_list variant)))
variants;
Ambiguous uses
let of_lorentz_tensor spins lorentz =
match spins with
| Unique s ->
begin
try
Some (UFO_Lorentz.parse (Array.to_list s) lorentz)
with
| Failure msg ->
begin
prerr_endline msg;
Some (UFO_Lorentz.dummy)
end
end
| Unused ->
Printf.eprintf
"UFO.Lorentz: stripping unused structure %s\n"
(UFOx.Lorentz.to_string lorentz);
None
| Ambiguous _ -> invalid_arg "UFO.Lorentz.of_lorentz_tensor: Ambiguous"
(* NB: if the \texttt{name} attribute of a \texttt{Lorentz} object
does \emph{not} match the the name of the object, the former has
a better chance to correspond to a valid Fortran name. Therefore
we use it. *)
let of_lorentz_UFO particles vertices lorentz_UFO =
SMap.fold
(fun name l acc ->
let spins = lorentz_reps_of_structure particles vertices l in
match of_lorentz_tensor spins l.Lorentz_UFO.structure with
| None -> acc
| Some structure ->
SMap.add
name
{ name = l.Lorentz_UFO.symbol;
n = List.length l.Lorentz_UFO.spins;
spins;
structure;
fermion_lines = UFO_Lorentz.fermion_lines structure;
variables = UFOx.Lorentz.variables l.Lorentz_UFO.structure }
acc)
lorentz_UFO SMap.empty
let to_string symbol l =
Printf.sprintf
"lorentz: %s => [name = '%s', spins = %s, \
structure = %s, fermion_lines = %s]"
symbol l.name
(match l.spins with
| Unique s ->
"[" ^ String.concat
", " (List.map lorentz_to_string (Array.to_list s)) ^ "]"
| Ambiguous _ -> "AMBIGUOUS!"
| Unused -> "UNUSED!")
(UFO_Lorentz.to_string l.structure)
(UFO_Lorentz.fermion_lines_to_string l.fermion_lines)
end
(* According to arxiv:1308:1668, there should not be a factor
of~$i$ in the numerators of propagators, but the (unused)
\texttt{propagators.py} in most models violate this rule! *)
let divide_propagators_by_i = ref false
module type Propagator =
sig
type t = (* private *)
{ name : string;
spins : Coupling.lorentz * Coupling.lorentz;
numerator : UFO_Lorentz.t;
denominator : UFO_Lorentz.t;
variables : string list }
val of_propagator_UFO : ?majorana:bool -> Propagator_UFO.t -> t
val of_propagators_UFO : ?majorana:bool -> Propagator_UFO.t SMap.t -> t SMap.t
val transpose : t -> t
val to_string : string -> t -> string
end
module Propagator : Propagator =
struct
type t = (* private *)
{ name : string;
spins : Coupling.lorentz * Coupling.lorentz;
numerator : UFO_Lorentz.t;
denominator : UFO_Lorentz.t;
variables : string list }
let lorentz_rep_at rep_classes i =
try
UFOx.Lorentz.omega (List.assoc i rep_classes)
with
| Not_found -> Coupling.Scalar
let imaginary = Algebra.QC.make Algebra.Q.null Algebra.Q.unit
let scalars = [Coupling.Scalar; Coupling.Scalar]
(* If~$51$ and~$52$ show up as indices, we must
map $(1,51)\to(1001,2001)$ and $(2,52)\to(1002,2002)$,
as per the UFO conventions for Lorentz structures. *)
(* \begin{dubious}
This does not work yet, because [UFOx.Lorentz.map_indices]
affects also the position argument of [P], [Mass] and [Width].
\end{dubious} *)
let contains_51_52 tensor =
List.exists
(fun (i, _) -> i = 51 || i = 52)
(UFOx.Lorentz.classify_indices tensor)
let remap_51_52 = function
| 1 -> 1001 | 51 -> 2001
| 2 -> 1002 | 52 -> 2002
| i -> i
let canonicalize_51_52 tensor =
if contains_51_52 tensor then
UFOx.Lorentz.rename_indices remap_51_52 tensor
else
tensor
let force_majorana = function
| Coupling.Spinor | Coupling.ConjSpinor -> Coupling.Majorana
| s -> s
let string_list_union l1 l2 =
Sets.String.elements
(Sets.String.union
(Sets.String.of_list l1)
(Sets.String.of_list l2))
(* In the current conventions, the factor of~$i$ is not included: *)
let of_propagator_UFO ?(majorana=false) p =
let numerator = canonicalize_51_52 p.Propagator_UFO.numerator in
let lorentz_reps = UFOx.Lorentz.classify_indices numerator in
let spin1 = lorentz_rep_at lorentz_reps 1
and spin2 = lorentz_rep_at lorentz_reps 2 in
let numerator_sans_i =
if !divide_propagators_by_i then
UFOx.Lorentz.map_coeff (fun q -> Algebra.QC.div q imaginary) numerator
else
numerator in
{ name = p.Propagator_UFO.name;
spins =
if majorana then
(force_majorana spin1, force_majorana spin2)
else
(spin1, spin2);
numerator =
UFO_Lorentz.parse ~allow_denominator:true [spin1; spin2] numerator_sans_i;
denominator = UFO_Lorentz.parse scalars p.Propagator_UFO.denominator;
variables =
string_list_union
(UFOx.Lorentz.variables p.Propagator_UFO.denominator)
(UFOx.Lorentz.variables numerator_sans_i) }
let of_propagators_UFO ?majorana propagators_UFO =
SMap.fold
(fun name p acc -> SMap.add name (of_propagator_UFO ?majorana p) acc)
propagators_UFO SMap.empty
let permute12 = function
| 1 -> 2
| 2 -> 1
| n -> n
let transpose_positions t =
UFOx.Index.map_position permute12 t
let transpose p =
{ name = p.name;
spins = (snd p.spins, fst p.spins);
numerator = UFO_Lorentz.map_indices transpose_positions p.numerator;
denominator = p.denominator;
variables = p.variables }
let to_string symbol p =
Printf.sprintf
"propagator: %s => [name = '%s', spin = '(%s, %s)', numerator/I = '%s', \
denominator = '%s']"
symbol p.name
(Lorentz.lorentz_to_string (fst p.spins))
(Lorentz.lorentz_to_string (snd p.spins))
(UFO_Lorentz.to_string p.numerator)
(UFO_Lorentz.to_string p.denominator)
end
type t =
{ particles : Particle.t SMap.t;
particle_array : Particle.t array; (* for diagnostics *)
couplings : UFO_Coupling.t SMap.t;
coupling_orders : Coupling_Order.t SMap.t;
vertices : Vertex.t SMap.t;
lorentz_UFO : Lorentz_UFO.t SMap.t;
lorentz : Lorentz.t SMap.t;
parameters : Parameter.t SMap.t;
propagators_UFO : Propagator_UFO.t SMap.t;
propagators : Propagator.t SMap.t;
decays : Decay.t SMap.t;
nc : int }
let use_majorana_spinors = ref false
let fallback_to_majorana_if_necessary particles vertices lorentz_UFO =
let majoranas =
SMap.fold
(fun p particle acc ->
if Particle.is_majorana particle then
SSet.add p acc
else
acc)
particles SSet.empty in
let spinors, conj_spinors =
collect_spinor_reps_of_vertices particles lorentz_UFO vertices in
let ambiguous =
SSet.diff (SSet.inter spinors conj_spinors) majoranas in
let no_majoranas = SSet.is_empty majoranas
and no_ambiguities = SSet.is_empty ambiguous in
if no_majoranas && no_ambiguities && not !use_majorana_spinors then
(SMap.mapi
(fun p particle ->
if SSet.mem p spinors then
Particle.force_spinor particle
else if SSet.mem p conj_spinors then
Particle.force_conjspinor particle
else
particle)
particles,
false)
else
begin
if !use_majorana_spinors then
Printf.eprintf "O'Mega: Majorana fermions requested.\n";
if not no_majoranas then
Printf.eprintf "O'Mega: found Majorana fermions!\n";
if not no_ambiguities then
Printf.eprintf
"O'Mega: found ambiguous spinor representations for %s!\n"
(String.concat ", " (SSet.elements ambiguous));
Printf.eprintf
"O'Mega: falling back to the Majorana representation for all fermions.\n";
(SMap.map Particle.force_majorana particles,
true)
end
let nc_of_particles particles =
let nc_set =
List.fold_left
(fun nc_set (_, p) ->
match UFOx.Color.omega p.Particle.color with
- | Color.Singlet -> nc_set
+ | Color.Singlet | Color.YT _ | Color.YTC _ -> nc_set
| Color.SUN nc -> Sets.Int.add (abs nc) nc_set
| Color.AdjSUN nc -> Sets.Int.add (abs nc) nc_set)
Sets.Int.empty (SMap.bindings particles) in
match Sets.Int.elements nc_set with
| [] -> 0
| [n] -> n
| nc_list ->
invalid_arg
("UFO.Model: more than one value of N_C: " ^
String.concat ", " (List.map string_of_int nc_list))
let of_file u =
let particles = Particle.of_file u.Files.particles in
let vertices = Vertex.of_file particles u.Files.vertices
and lorentz_UFO = Lorentz_UFO.of_file u.Files.lorentz
and propagators_UFO = Propagator_UFO.of_file u.Files.propagators in
let particles, majorana =
fallback_to_majorana_if_necessary particles vertices lorentz_UFO in
let particle_array = Array.of_list (values particles)
and lorentz = Lorentz.of_lorentz_UFO particles vertices lorentz_UFO
and propagators = Propagator.of_propagators_UFO ~majorana propagators_UFO in
let model =
{ particles;
particle_array;
couplings = UFO_Coupling.of_file u.Files.couplings;
coupling_orders = Coupling_Order.of_file u.Files.coupling_orders;
vertices;
lorentz_UFO;
lorentz;
parameters = Parameter.of_file u.Files.parameters;
propagators_UFO;
propagators;
decays = Decay.of_file u.Files.decays;
nc = nc_of_particles particles } in
SMap.iter
(fun _ v ->
check_color_reps_of_vertex model.particles v;
check_lorentz_reps_of_vertex model.particles model.lorentz_UFO v)
model.vertices;
model
let map_parameter_names f m =
{ m with
particles = SMap.map (Particle.map_mass_and_width f) m.particles;
particle_array = Array.map (Particle.map_mass_and_width f) m.particle_array;
parameters = SMap.map (Parameter.map_names f) m.parameters }
let parse_directory dir =
of_file (Files.parse_directory dir)
let dump model =
Printf.printf "NC = %d\n" model.nc;
SMap.iter (print_endline <**> Particle.to_string) model.particles;
SMap.iter (print_endline <**> UFO_Coupling.to_string) model.couplings;
SMap.iter (print_endline <**> Coupling_Order.to_string) model.coupling_orders;
(* [SMap.iter (print_endline <**> Vertex.to_string) model.vertices;] *)
SMap.iter
(fun symbol v ->
(print_endline <**> Vertex.to_string) symbol v;
print_endline
(Vertex.to_string_expanded model.lorentz_UFO model.couplings v))
model.vertices;
SMap.iter (print_endline <**> Lorentz_UFO.to_string) model.lorentz_UFO;
SMap.iter (print_endline <**> Lorentz.to_string) model.lorentz;
SMap.iter (print_endline <**> Parameter.to_string) model.parameters;
SMap.iter (print_endline <**> Propagator_UFO.to_string) model.propagators_UFO;
SMap.iter (print_endline <**> Propagator.to_string) model.propagators;
SMap.iter (print_endline <**> Decay.to_string) model.decays;
SMap.iter
(fun symbol d ->
List.iter (fun (_, w) -> ignore (UFOx.Expr.of_string w)) d.Decay.widths)
model.decays
exception Unhandled of string
let unhandled s = raise (Unhandled s)
module Model =
struct
(* NB: we could use [type flavor = Particle.t], but that would
be very inefficient, because we will use [flavor] as a key
for maps below. *)
type flavor = int
type constant = string
+ type coupling_order = string
type gauge = unit
- module M = Modeltools.Mutable
- (struct type f = flavor type g = gauge type c = constant end)
+ module M =
+ Modeltools.Mutable (struct type f = flavor type g = gauge type c = constant type co = string end)
+
+ let setup = M.setup
let flavors = M.flavors
let external_flavors = M.external_flavors
- let external_flavors = M.external_flavors
let lorentz = M.lorentz
+ let all_coupling_orders = M.all_coupling_orders
+ let coupling_orders = M.coupling_orders
+ let coupling_order_to_string co = co
let color = M.color
let nc = M.nc
let propagator = M.propagator
let width = M.width
let goldstone = M.goldstone
let conjugate = M.conjugate
let fermion = M.fermion
let vertices = M.vertices
let fuse2 = M.fuse2
let fuse3 = M.fuse3
let fuse = M.fuse
let max_degree = M.max_degree
let parameters = M.parameters
let flavor_of_string = M.flavor_of_string
let flavor_to_string = M.flavor_to_string
let flavor_to_TeX = M.flavor_to_TeX
let flavor_symbol = M.flavor_symbol
let gauge_symbol = M.gauge_symbol
let pdg = M.pdg
let mass_symbol = M.mass_symbol
let width_symbol = M.width_symbol
let constant_symbol = M.constant_symbol
module Ch = M.Ch
let charges = M.charges
let rec fermion_of_lorentz = function
| Coupling.Spinor -> 1
| Coupling.ConjSpinor -> -1
| Coupling.Majorana -> 2
| Coupling.Maj_Ghost -> 2
| Coupling.Vectorspinor -> 1
| Coupling.Vector | Coupling.Massive_Vector -> 0
| Coupling.Scalar | Coupling.Tensor_1 | Coupling.Tensor_2 -> 0
| Coupling.BRS f -> fermion_of_lorentz f
module Q = Algebra.Q
module QC = Algebra.QC
let dummy_tensor3 = Coupling.Scalar_Scalar_Scalar 1
let dummy_tensor4 = Coupling.Scalar4 1
let triplet p = (p.(0), p.(1), p.(2))
let quartet p = (p.(0), p.(1), p.(2), p.(3))
let half_times q1 q2 =
Q.mul (Q.make 1 2) (Q.mul q1 q2)
let name g =
g.UFO_Coupling.name
let fractional_coupling g r =
let g = name g in
match Q.to_ratio r with
| 0, _ -> "0.0_default"
| 1, 1 -> g
| -1, 1 -> Printf.sprintf "(-%s)" g
| n, 1 -> Printf.sprintf "(%d*%s)" n g
| 1, d -> Printf.sprintf "(%s/%d)" g d
| -1, d -> Printf.sprintf "(-%s/%d)" g d
| n, d -> Printf.sprintf "(%d*%s/%d)" n g d
let lorentz_of_symbol model symbol =
try
SMap.find symbol model.lorentz
with
| Not_found -> invalid_arg ("lorentz_of_symbol: " ^ symbol)
let lorentz_UFO_of_symbol model symbol =
try
SMap.find symbol model.lorentz_UFO
with
| Not_found -> invalid_arg ("lorentz_UFO_of_symbol: " ^ symbol)
let coupling_of_symbol model symbol =
try
SMap.find symbol model.couplings
with
| Not_found -> invalid_arg ("coupling_of_symbol: " ^ symbol)
let spin_triplet model name =
match (lorentz_of_symbol model name).Lorentz.spins with
| Lorentz.Unique [|s0; s1; s2|] -> (s0, s1, s2)
| Lorentz.Unique _ -> invalid_arg "spin_triplet: wrong number of spins"
| Lorentz.Unused -> invalid_arg "spin_triplet: Unused"
| Lorentz.Ambiguous _ -> invalid_arg "spin_triplet: Ambiguous"
let spin_quartet model name =
match (lorentz_of_symbol model name).Lorentz.spins with
| Lorentz.Unique [|s0; s1; s2; s3|] -> (s0, s1, s2, s3)
| Lorentz.Unique _ -> invalid_arg "spin_quartet: wrong number of spins"
| Lorentz.Unused -> invalid_arg "spin_quartet: Unused"
| Lorentz.Ambiguous _ -> invalid_arg "spin_quartet: Ambiguous"
let spin_multiplet model name =
match (lorentz_of_symbol model name).Lorentz.spins with
| Lorentz.Unique sarray -> sarray
| Lorentz.Unused -> invalid_arg "spin_multiplet: Unused"
| Lorentz.Ambiguous _ -> invalid_arg "spin_multiplet: Ambiguous"
(* If we have reason to belive that a $\delta_{ab}$-vertex is
an effective $\tr(T_aT_b)$-vertex generated at loop
level, like~$gg\to H\ldots$ in the SM, we should interpret
it as such and use the expression~(6.2) from~\cite{Kilian:2012pz}. *)
(* AFAIK, there is no way to distinguish these cases directly
in a UFO file. Instead we rely in a heuristic, in which
each massless color octet vector particle or ghost is a gluon
and colorless scalars are potential Higgses. *)
let is_massless p =
match ThoString.uppercase p.Particle.mass with
| "ZERO" -> true
| _ -> false
let is_gluon model f =
let p = model.particle_array.(f) in
match UFOx.Color.omega p.Particle.color,
UFOx.Lorentz.omega p.Particle.spin with
| Color.AdjSUN _, Coupling.Vector -> is_massless p
| Color.AdjSUN _, Coupling.Scalar ->
if p.Particle.ghost_number <> 0 then
is_massless p
else
false
| _ -> false
let is_color_singlet model f =
let p = model.particle_array.(f) in
match UFOx.Color.omega p.Particle.color with
| Color.Singlet -> true
| _ -> false
let is_higgs_gluon_vertex model p adjoints =
if Array.length p > List.length adjoints then
List.for_all
(fun (i, p) ->
if List.mem i adjoints then
is_gluon model p
else
is_color_singlet model p)
(ThoList.enumerate 1 (Array.to_list p))
else
false
let delta8_heuristics model p a b =
if is_higgs_gluon_vertex model p [a; b] then
Color.Vertex.delta8_loop a b
else
Color.Vertex.delta8 a b
let verbatim_higgs_glue = ref false
+ let yt_to_omega y =
+ Young.map pred y
+
let translate_color_atom model p = function
| UFOx.Color_Atom.Identity (i, j) -> Color.Vertex.delta3 j i
| UFOx.Color_Atom.Identity8 (a, b) ->
if !verbatim_higgs_glue then
Color.Vertex.delta8 a b
else
delta8_heuristics model p a b
+ | UFOx.Color_Atom.Delta (y, a, b) -> Color.Vertex.delta_of_tableau (yt_to_omega y) a b
| UFOx.Color_Atom.T (a, i, j) -> Color.Vertex.t a i j
+ | UFOx.Color_Atom.TY (y, a, i, j) -> Color.Vertex.t_of_tableau (yt_to_omega y) a i j
| UFOx.Color_Atom.F (a, b, c) -> Color.Vertex.f a b c
| UFOx.Color_Atom.D (a, b, c) -> Color.Vertex.d a b c
| UFOx.Color_Atom.Epsilon (i, j, k) -> Color.Vertex.epsilon [i; j; k]
| UFOx.Color_Atom.EpsilonBar (i, j, k) -> Color.Vertex.epsilon_bar [i; j; k]
| UFOx.Color_Atom.T6 (a, i, j) -> Color.Vertex.t6 a i j
| UFOx.Color_Atom.K6 (i, j, k) -> Color.Vertex.k6 i j k
| UFOx.Color_Atom.K6Bar (i, j, k) -> Color.Vertex.k6bar i j k
let translate_color_term model p = function
- | [], q ->
- Color.Vertex.scale q Color.Vertex.one
- | [atom], q ->
- Color.Vertex.scale q (translate_color_atom model p atom)
+ | [], q -> Birdtracks.scale q Birdtracks.one
+ | [atom], q -> Birdtracks.scale q (translate_color_atom model p atom)
| atoms, q ->
let atoms = List.map (translate_color_atom model p) atoms in
- Color.Vertex.scale q (Color.Vertex.multiply atoms)
+ Birdtracks.scale q (Birdtracks.multiply atoms)
let translate_color model p terms =
match terms with
| [] -> invalid_arg "translate_color: empty"
| [ term ] -> translate_color_term model p term
- | terms ->
- Color.Vertex.sum (List.map (translate_color_term model p) terms)
+ | terms -> Birdtracks.sum (List.map (translate_color_term model p) terms)
let translate_coupling_1 model p lcc =
let l = lcc.Vertex.lorentz in
let s = Array.to_list (spin_multiplet model l)
and fl = (SMap.find l model.lorentz).Lorentz.fermion_lines
and c = name (coupling_of_symbol model lcc.Vertex.coupling) in
match lcc.Vertex.color with
| UFOx.Color.Linear color ->
let col = translate_color model p color in
(Array.to_list p, Coupling.UFO (QC.unit, l, s, fl, col), c)
| UFOx.Color.Ratios _ as color ->
invalid_arg
("UFO.Model.translate_coupling: invalid color structure" ^
UFOx.Color.to_string color)
let translate_coupling model p lcc =
List.map (translate_coupling_1 model p) lcc
let long_flavors = ref false
module type Lookup =
sig
type f = private
{ flavors : flavor list;
flavor_of_string : string -> flavor;
flavor_of_symbol : string -> flavor;
particle : flavor -> Particle.t;
flavor_symbol : flavor -> string;
conjugate : flavor -> flavor }
type flavor_format =
| Long
| Decimal
| Hexadecimal
val flavor_format : flavor_format ref
val of_model : t -> f
end
module Lookup : Lookup =
struct
type f =
{ flavors : flavor list;
flavor_of_string : string -> flavor;
flavor_of_symbol : string -> flavor;
particle : flavor -> Particle.t;
flavor_symbol : flavor -> string;
conjugate : flavor -> flavor }
type flavor_format =
| Long
| Decimal
| Hexadecimal
let flavor_format = ref Hexadecimal
(*i
let match_pdf_code p1 p2 =
p1.Particle.pdg_code = p2.Particle.pdg_code
i*)
let conjugate_of_particle_array particles =
Array.init
(Array.length particles)
(fun i ->
let f' = Particle.conjugate particles.(i) in
match ThoArray.match_all f' particles with
| [i'] -> i'
| [] ->
invalid_arg ("no charge conjugate: " ^ f'.Particle.name)
| _ ->
invalid_arg ("multiple charge conjugates: " ^ f'.Particle.name))
let invert_flavor_array a =
let table = SHash.create 37 in
Array.iteri (fun i s -> SHash.add table s i) a;
(fun name ->
try
SHash.find table name
with
| Not_found -> invalid_arg ("not found: " ^ name))
let digits base n =
let rec digits' acc n =
if n < 1 then
acc
else
digits' (succ acc) (n / base) in
if n < 0 then
digits' 1 (-n)
else if n = 0 then
1
else
digits' 0 n
let of_model model =
let particle_array = Array.of_list (values model.particles) in
let conjugate_array = conjugate_of_particle_array particle_array
and name_array = Array.map (fun f -> f.Particle.name) particle_array
and symbol_array = Array.of_list (keys model.particles) in
let flavor_symbol f =
begin match !flavor_format with
| Long -> symbol_array.(f)
| Decimal ->
let w = digits 10 (Array.length particle_array - 1) in
Printf.sprintf "%0*d" w f
| Hexadecimal ->
let w = digits 16 (Array.length particle_array - 1) in
Printf.sprintf "%0*X" w f
end in
{ flavors = ThoList.range 0 (Array.length particle_array - 1);
flavor_of_string = invert_flavor_array name_array;
flavor_of_symbol = invert_flavor_array symbol_array;
particle = Array.get particle_array;
flavor_symbol = flavor_symbol;
conjugate = Array.get conjugate_array }
end
(* \begin{dubious}
We appear to need to conjugate all flavors. Why???
\end{dubious} *)
let translate_vertices model tables =
let vn =
List.fold_left
(fun acc v ->
let p = Array.map tables.Lookup.flavor_of_symbol v.Vertex.particles
and lcc = v.Vertex.lcc in
let p = Array.map conjugate p in (* FIXME: why? *)
translate_coupling model p lcc @ acc)
[] (values model.vertices) in
([], [], vn)
let propagator_of_lorentz = function
| Coupling.Scalar -> Coupling.Prop_Scalar
| Coupling.Spinor -> Coupling.Prop_Spinor
| Coupling.ConjSpinor -> Coupling.Prop_ConjSpinor
| Coupling.Majorana -> Coupling.Prop_Majorana
| Coupling.Maj_Ghost -> invalid_arg
"UFO.Model.propagator_of_lorentz: SUSY ghosts do not propagate"
| Coupling.Vector -> Coupling.Prop_Feynman
| Coupling.Massive_Vector -> Coupling.Prop_Unitarity
| Coupling.Tensor_2 -> Coupling.Prop_Tensor_2
| Coupling.Vectorspinor -> invalid_arg
"UFO.Model.propagator_of_lorentz: Vectorspinor"
| Coupling.Tensor_1 -> invalid_arg
"UFO.Model.propagator_of_lorentz: Tensor_1"
| Coupling.BRS _ -> invalid_arg
"UFO.Model.propagator_of_lorentz: no BRST"
let filter_unphysical model =
let physical_particles =
Particle.filter Particle.is_physical model.particles in
let physical_particle_array =
Array.of_list (values physical_particles) in
let physical_vertices =
Vertex.filter
(not <*> (Vertex.contains model.particles (not <*> Particle.is_physical)))
model.vertices in
{ model with
particles = physical_particles;
particle_array = physical_particle_array;
vertices = physical_vertices }
let whizard_constants =
SSet.of_list
[ "ZERO" ]
let filter_constants parameters =
List.filter
(fun p ->
not (SSet.mem (ThoString.uppercase p.Parameter.name) whizard_constants))
parameters
let add_name set parameter =
CSet.add parameter.Parameter.name set
let hardcoded_parameters =
CSet.of_list
["cmath.pi"]
let missing_parameters input derived couplings =
let input_parameters =
List.fold_left add_name hardcoded_parameters input in
let all_parameters =
List.fold_left add_name input_parameters derived in
let derived_dependencies =
dependencies
(List.map
(fun p -> (p.Parameter.name, p.Parameter.value))
derived) in
let coupling_dependencies =
dependencies
(List.map
(fun p -> (p.UFO_Coupling.name, Expr p.UFO_Coupling.value))
(values couplings)) in
let missing_input =
CMap.filter
(fun parameter derived_parameters ->
not (CSet.mem parameter all_parameters))
derived_dependencies
and missing =
CMap.filter
(fun parameter couplings ->
not (CSet.mem parameter all_parameters))
coupling_dependencies in
CMap.iter
(fun parameter derived_parameters ->
Printf.eprintf
"UFO warning: undefined input parameter %s appears in derived \
parameters {%s}: will be added to the list of input parameters!\n"
parameter (String.concat "; " (CSet.elements derived_parameters)))
missing_input;
CMap.iter
(fun parameter couplings ->
Printf.eprintf
"UFO warning: undefined parameter %s appears in couplings {%s}: \
will be added to the list of input parameters!\n"
parameter (String.concat "; " (CSet.elements couplings)))
missing;
keys_caseless missing_input @ keys_caseless missing
let classify_parameters model =
let compare_parameters p1 p2 =
compare p1.Parameter.sequence p2.Parameter.sequence in
let input, derived =
List.fold_left
(fun (input, derived) p ->
match p.Parameter.nature with
| Parameter.Internal -> (input, p :: derived)
| Parameter.External ->
begin match p.Parameter.ptype with
| Parameter.Real -> ()
| Parameter.Complex ->
Printf.eprintf
"UFO warning: invalid complex declaration of input \
parameter `%s' ignored!\n"
p.Parameter.name
end;
(p :: input, derived))
([], []) (filter_constants (values model.parameters)) in
let additional = missing_parameters input derived model.couplings in
(List.sort compare_parameters input @ List.map Parameter.missing additional,
List.sort compare_parameters derived)
(*i
List.iter
(fun line -> Printf.eprintf "par: %s\n" line)
(dependencies_to_strings derived_dependencies);
List.iter
(fun line -> Printf.eprintf "coupling: %s\n" line)
(dependencies_to_strings coupling_dependencies);
i*)
let translate_input p =
(p.Parameter.name, value_to_float p.Parameter.value)
let alpha_s_half e =
UFOx.Expr.substitute "aS" (UFOx.Expr.half "aS") e
let translate_derived p =
let make_atom s = s in
let c = make_atom p.Parameter.name
and v = value_to_coupling alpha_s_half make_atom p.Parameter.value in
match p.Parameter.ptype with
| Parameter.Real -> (Coupling.Real c, v)
| Parameter.Complex -> (Coupling.Complex c, v)
let translate_coupling_constant c =
let make_atom s = s in
(Coupling.Complex c.UFO_Coupling.name,
Coupling.Quot (value_to_coupling alpha_s_half make_atom (Expr c.UFO_Coupling.value), Coupling.I))
module Lowercase_Parameters =
struct
type elt = string
type base = string
let compare_elt = compare
let compare_base = compare
let pi = ThoString.lowercase
end
module Lowercase_Bundle = Bundle.Make (Lowercase_Parameters)
let coupling_names model =
SMap.fold
(fun _ c acc -> c.UFO_Coupling.name :: acc)
model.couplings []
let parameter_names model =
SMap.fold
(fun _ c acc -> c.Parameter.name :: acc)
model.parameters []
let ambiguous_parameters model =
let all_names =
List.rev_append (coupling_names model) (parameter_names model) in
let lc_bundle = Lowercase_Bundle.of_list all_names in
let lc_set =
List.fold_left
(fun acc s -> SSet.add s acc)
SSet.empty (Lowercase_Bundle.base lc_bundle)
and ambiguities =
List.filter
(fun (_, names) -> List.length names > 1)
(Lowercase_Bundle.fibers lc_bundle) in
(lc_set, ambiguities)
let disambiguate1 lc_set name =
let rec disambiguate1' i =
let name' = Printf.sprintf "%s_%d" name i in
let lc_name' = ThoString.lowercase name' in
if SSet.mem lc_name' lc_set then
disambiguate1' (succ i)
else
(SSet.add lc_name' lc_set, name') in
disambiguate1' 1
let disambiguate lc_set names =
let _, replacements =
List.fold_left
(fun (lc_set', acc) name ->
let lc_set'', name' = disambiguate1 lc_set' name in
(lc_set'', SMap.add name name' acc))
(lc_set, SMap.empty) names in
replacements
let omegalib_names =
["u"; "ubar"; "v"; "vbar"; "eps"]
let replacement_map model =
let lc_set, ambiguities = ambiguous_parameters model in
let replacement_list =
disambiguate lc_set (ThoList.flatmap snd ambiguities) in
SMap.iter
(Printf.eprintf
"UFO warning: case sensitive parameter names: renaming '%s' -> '%s'\n")
replacement_list;
List.fold_left
(fun acc name -> SMap.add name ("UFO_" ^ name) acc)
replacement_list omegalib_names
let translated_parameters model =
let input_parameters, derived_parameters = classify_parameters model
and couplings = values model.couplings in
{ Coupling.input = List.map translate_input input_parameters;
Coupling.derived =
List.map translate_derived derived_parameters @
List.map translate_coupling_constant couplings;
Coupling.derived_arrays = [] }
(* UFO requires us to look up the mass parameter to
distinguish between massless and massive vectors.
TODO: this is a candidate for another lookup table. *)
let lorentz_of_particle p =
match UFOx.Lorentz.omega p.Particle.spin with
| Coupling.Vector ->
begin match ThoString.uppercase p.Particle.mass with
| "ZERO" -> Coupling.Vector
| _ -> Coupling.Massive_Vector
end
| s -> s
type state =
{ directory : string;
model : t }
let initialized = ref None
let is_initialized_from dir =
match !initialized with
| None -> false
| Some state -> dir = state.directory
let dump_raw = ref false
(* Using [translated_parameters] only to extract the parameters, without
affecting the corresponding changes in the model tables couldn't work!
(Cf.~\url{https://answers.launchpad.net/whizard/+question/706815}
and~\url{https://gitlab.tp.nt.uni-siegen.de/whizard/development/-/issues/450}) *)
let map_names map name =
match SMap.find_opt name map with
| None -> name
| Some name -> name
- let init dir =
+ type init = string * string list
+
+ let init (dir, flags) =
+ if List.mem "dump" flags then
+ dump_raw := true;
let model = filter_unphysical (parse_directory dir) in
if !dump_raw then
dump model;
let replacements = replacement_map model in
let model = map_parameter_names (map_names replacements) model in
let parameters = translated_parameters model in
let tables = Lookup.of_model model in
let vertices () = translate_vertices model tables in
let particle f = tables.Lookup.particle f in
let lorentz f = lorentz_of_particle (particle f) in
let propagator f =
let p = particle f in
match p.Particle.propagator with
| None -> propagator_of_lorentz (lorentz_of_particle p)
| Some s -> Coupling.Prop_UFO s in
let gauge_symbol () = "?GAUGE?" in
let constant_symbol s = s in
+ let all_coupling_orders () =
+ List.map fst (SMap.bindings model.coupling_orders)
+ and coupling_orders c =
+ (coupling_of_symbol model c).UFO_Coupling.order
+ and coupling_order_to_string co = co in
M.setup
~color:(fun f -> UFOx.Color.omega (particle f).Particle.color)
~nc:(fun () -> model.nc)
~pdg:(fun f -> (particle f).Particle.pdg_code)
~lorentz
~propagator
~width:(fun f -> Coupling.Constant)
~goldstone:(fun f -> None)
~conjugate:tables.Lookup.conjugate
~fermion:(fun f -> fermion_of_lorentz (lorentz f))
~vertices
~flavors:[("All Flavors", tables.Lookup.flavors)]
~parameters:(fun () -> parameters)
~flavor_of_string:tables.Lookup.flavor_of_string
~flavor_to_string:(fun f -> (particle f).Particle.name)
~flavor_to_TeX:(fun f -> (particle f).Particle.texname)
~flavor_symbol:tables.Lookup.flavor_symbol
~gauge_symbol
~mass_symbol:(fun f -> (particle f).Particle.mass)
~width_symbol:(fun f -> (particle f).Particle.width)
- ~constant_symbol;
+ ~constant_symbol
+ ~all_coupling_orders
+ ~coupling_orders
+ ~coupling_order_to_string;
initialized := Some { directory = dir; model = model }
let ufo_directory = ref Config.default_UFO_dir
let load () =
if is_initialized_from !ufo_directory then
()
else
- init !ufo_directory
+ init (!ufo_directory, [])
let include_all_fusions = ref false
(* In case of Majorana spinors, also generate
all combinations of charge conjugated fermion lines.
The naming convention is to append
\texttt{\_c}$nm$ if the $\gamma$-matrices
of the fermion line $n\to m$ has been charge conjugated
(this could become impractical for too many fermions at
a vertex, but shouldn't matter in real life). *)
(* Here we alway generate \emph{all} charge conjugations, because
we treat \emph{all} fermions as Majorana fermion, if there
is at least one Majorana fermion in the model! *)
let is_majorana = function
| Coupling.Majorana | Coupling.Vectorspinor | Coupling.Maj_Ghost -> true
| _ -> false
let name_spins_structure spins l =
(l.Lorentz.name, spins, l.Lorentz.structure)
let fusions_of_model ?only model =
let include_fusion =
match !include_all_fusions, only with
| true, _
| false, None -> (fun name -> true)
| false, Some names -> (fun name -> SSet.mem name names)
in
SMap.fold
(fun name l acc ->
if include_fusion name then
List.fold_left
(fun acc p ->
let l' = Lorentz.permute p l in
match l'.Lorentz.spins with
| Lorentz.Unused -> acc
| Lorentz.Unique spins ->
if Array.exists is_majorana spins then
List.map
(name_spins_structure spins)
(Lorentz.required_charge_conjugates l')
@ acc
else
name_spins_structure spins l' :: acc
| Lorentz.Ambiguous _ -> failwith "fusions: Lorentz.Ambiguous")
[] (Permutation.Default.cyclic l.Lorentz.n) @ acc
else
acc)
model.lorentz []
let fusions ?only () =
match !initialized with
| None -> []
| Some { model = model } -> fusions_of_model ?only model
let propagators_of_model ?only model =
let include_propagator =
match !include_all_fusions, only with
| true, _
| false, None -> (fun name -> true)
| false, Some names -> (fun name -> SSet.mem name names)
in
SMap.fold
(fun name p acc ->
if include_propagator name then
(name, p) :: acc
else
acc)
model.propagators []
let propagators ?only () =
match !initialized with
| None -> []
| Some { model = model } -> propagators_of_model ?only model
let include_hadrons = ref true
+(*i
let ufo_majorana_warnings =
[ "***************************************************";
"* *";
"* CAVEAT: *";
"* *";
"* These amplitudes have been computed for a *";
"* UFO model containing Majorana fermions. *";
"* This version of O'Mega contains some known *";
"* bugs for this case. It was released early at *";
"* the request of the Linear Collider community. *";
"* *";
"* These amplitudes MUST NOT be used for *";
"* publications without prior consulation *";
"* with the WHIZARD authors !!! *";
"* *";
"***************************************************" ]
let caveats () =
if !use_majorana_spinors then
ufo_majorana_warnings
else
[]
+i*)
+
+ let caveats () = []
- module Whizard : sig val write : unit -> unit end =
+ module Whizard : sig val write : out_channel -> unit end =
struct
- let write_header dir =
- Printf.printf "# WHIZARD Model file derived from UFO directory\n";
- Printf.printf "# '%s'\n\n" dir;
- List.iter (fun s -> Printf.printf "# %s\n" s) (M.caveats ());
- Printf.printf "model \"%s\"\n\n" (Filename.basename dir)
+ let write_header oc dir =
+ let open Printf in
+ fprintf oc "# WHIZARD Model file derived from UFO directory\n";
+ fprintf oc "# '%s'\n\n" dir;
+ List.iter (fun s -> fprintf oc "# %s\n" s) (M.caveats ());
+ fprintf oc "model \"%s\"\n\n" (Filename.basename dir)
- let write_input_parameters parameters =
+ let write_input_parameters oc parameters =
+ let open Printf in
let open Parameter in
- Printf.printf "# Independent (input) Parameters\n";
+ fprintf oc "# Independent (input) Parameters\n";
List.iter
(fun p ->
- Printf.printf
+ fprintf oc
"parameter %s = %s"
p.name (value_to_numeric p.value);
begin match p.lhablock, p.lhacode with
| None, None -> ()
| Some name, Some (index :: indices) ->
- Printf.printf " slha_entry %s %d" name index;
- List.iter (fun i -> Printf.printf " %d" i) indices
+ fprintf oc " slha_entry %s %d" name index;
+ List.iter (fun i -> fprintf oc " %d" i) indices
| Some name, None ->
- Printf.eprintf
- "UFO: parameter %s: slhablock %s without slhacode\n"
- p.name name
+ eprintf "UFO: parameter %s: slhablock %s without slhacode\n" p.name name
| Some name, Some [] ->
- Printf.eprintf
- "UFO: parameter %s: slhablock %s with empty slhacode\n"
- p.name name
+ eprintf "UFO: parameter %s: slhablock %s with empty slhacode\n" p.name name
| None, Some _ ->
- Printf.eprintf
- "UFO: parameter %s: slhacode without slhablock\n"
- p.name
+ eprintf "UFO: parameter %s: slhacode without slhablock\n" p.name
end;
- Printf.printf "\n")
+ fprintf oc "\n")
parameters;
- Printf.printf "\n"
+ fprintf oc "\n"
- let write_derived_parameters parameters =
+ let write_derived_parameters oc parameters =
+ let open Printf in
let open Parameter in
- Printf.printf "# Dependent (derived) Parameters\n";
+ fprintf oc "# Dependent (derived) Parameters\n";
List.iter
(fun p ->
- Printf.printf
+ fprintf oc
"derived %s = %s\n"
p.name (value_to_expr alpha_s_half p.value))
parameters
- let write_particles particles =
+ let write_particles oc particles =
+ let open Printf in
let open Particle in
- Printf.printf "# Particles\n";
- Printf.printf "# NB: hypercharge assignments appear to be unreliable\n";
- Printf.printf "# therefore we can't infer the isospin\n";
- Printf.printf "# NB: parton-, gauge- & handedness are unavailable\n";
+ fprintf oc "# Particles\n";
+ fprintf oc "# NB: hypercharge assignments appear to be unreliable\n";
+ fprintf oc "# therefore we can't infer the isospin\n";
+ fprintf oc "# NB: parton-, gauge- & handedness are unavailable\n";
List.iter
(fun p ->
if not p.is_anti then begin
- Printf.printf
+ fprintf oc
"particle \"%s\" %d ### parton? gauge? left?\n"
p.name p.pdg_code;
- Printf.printf
+ fprintf oc
" spin %s charge %s color %s ### isospin?\n"
(UFOx.Lorentz.rep_to_string_whizard p.spin)
(charge_to_string p.charge)
(UFOx.Color.rep_to_string_whizard p.color);
- Printf.printf " name \"%s\"\n" p.name;
+ fprintf oc " name \"%s\"\n" p.name;
if p.antiname <> p.name then
- Printf.printf " anti \"%s\"\n" p.antiname;
- Printf.printf " tex_name \"%s\"\n" p.texname;
+ fprintf oc " anti \"%s\"\n" p.antiname;
+ fprintf oc " tex_name \"%s\"\n" p.texname;
if p.antiname <> p.name then
- Printf.printf " tex_anti \"%s\"\n" p.antitexname;
- Printf.printf " mass %s width %s\n\n" p.mass p.width
+ fprintf oc " tex_anti \"%s\"\n" p.antitexname;
+ fprintf oc " mass %s width %s\n\n" p.mass p.width
end)
(values particles);
- Printf.printf "\n"
+ fprintf oc "\n"
- let write_hadrons () =
- Printf.printf "# Hadrons (protons and beam remnants)\n";
- Printf.printf "# NB: these are NOT part of the UFO model\n";
- Printf.printf "# but added for WHIZARD's convenience!\n";
- Printf.printf "particle PROTON 2212\n";
- Printf.printf " spin 1/2 charge 1\n";
- Printf.printf " name p \"p+\"\n";
- Printf.printf " anti pbar \"p-\"\n";
- Printf.printf "particle HADRON_REMNANT 90\n";
- Printf.printf " name hr\n";
- Printf.printf " tex_name \"had_r\"\n";
- Printf.printf "particle HADRON_REMNANT_SINGLET 91\n";
- Printf.printf " name hr1\n";
- Printf.printf " tex_name \"had_r^{(1)}\"\n";
- Printf.printf "particle HADRON_REMNANT_TRIPLET 92\n";
- Printf.printf " color 3\n";
- Printf.printf " name hr3\n";
- Printf.printf " tex_name \"had_r^{(3)}\"\n";
- Printf.printf " anti hr3bar\n";
- Printf.printf " tex_anti \"had_r^{(\\bar 3)}\"\n";
- Printf.printf "particle HADRON_REMNANT_OCTET 93\n";
- Printf.printf " color 8\n";
- Printf.printf " name hr8\n";
- Printf.printf " tex_name \"had_r^{(8)}\"\n";
- Printf.printf "\n"
+ let write_hadrons oc =
+ let open Printf in
+ fprintf oc "# Hadrons (protons and beam remnants)\n";
+ fprintf oc "# NB: these are NOT part of the UFO model\n";
+ fprintf oc "# but added for WHIZARD's convenience!\n";
+ fprintf oc "particle PROTON 2212\n";
+ fprintf oc " spin 1/2 charge 1\n";
+ fprintf oc " name p \"p+\"\n";
+ fprintf oc " anti pbar \"p-\"\n";
+ fprintf oc "particle HADRON_REMNANT 90\n";
+ fprintf oc " name hr\n";
+ fprintf oc " tex_name \"had_r\"\n";
+ fprintf oc "particle HADRON_REMNANT_SINGLET 91\n";
+ fprintf oc " name hr1\n";
+ fprintf oc " tex_name \"had_r^{(1)}\"\n";
+ fprintf oc "particle HADRON_REMNANT_TRIPLET 92\n";
+ fprintf oc " color 3\n";
+ fprintf oc " name hr3\n";
+ fprintf oc " tex_name \"had_r^{(3)}\"\n";
+ fprintf oc " anti hr3bar\n";
+ fprintf oc " tex_anti \"had_r^{(\\bar 3)}\"\n";
+ fprintf oc "particle HADRON_REMNANT_OCTET 93\n";
+ fprintf oc " color 8\n";
+ fprintf oc " name hr8\n";
+ fprintf oc " tex_name \"had_r^{(8)}\"\n";
+ fprintf oc "\n"
let vertex_to_string model v =
String.concat
" "
(List.map
(fun s ->
"\"" ^ (SMap.find s model.particles).Particle.name ^ "\"")
(Array.to_list v.Vertex.particles))
- let write_vertices3 model vertices =
- Printf.printf "# Vertices (for phasespace generation only)\n";
- Printf.printf "# NB: particles should be sorted increasing in mass.\n";
- Printf.printf "# This is NOT implemented yet!\n";
+ let write_vertices3 oc model vertices =
+ let open Printf in
+ fprintf oc "# Vertices (for phasespace generation only)\n";
+ fprintf oc "# NB: particles should be sorted increasing in mass.\n";
+ fprintf oc "# This is NOT implemented yet!\n";
List.iter
(fun v ->
if Array.length v.Vertex.particles = 3 then
- Printf.printf "vertex %s\n" (vertex_to_string model v))
+ fprintf oc "vertex %s\n" (vertex_to_string model v))
(values vertices);
- Printf.printf "\n"
+ fprintf oc "\n"
- let write_vertices_higher model vertices =
- Printf.printf
+ let write_vertices_higher oc model vertices =
+ let open Printf in
+ fprintf oc
"# Higher Order Vertices (ignored by phasespace generation)\n";
List.iter
(fun v ->
if Array.length v.Vertex.particles <> 3 then
- Printf.printf "# vertex %s\n" (vertex_to_string model v))
+ fprintf oc "# vertex %s\n" (vertex_to_string model v))
(values vertices);
- Printf.printf "\n"
+ fprintf oc "\n"
- let write_vertices model vertices =
- write_vertices3 model vertices;
- write_vertices_higher model vertices
+ let write_vertices oc model vertices =
+ write_vertices3 oc model vertices;
+ write_vertices_higher oc model vertices
- let write () =
+ let write oc =
match !initialized with
| None -> failwith "UFO.Whizard.write: UFO model not initialized"
| Some { directory = dir; model = model } ->
let input_parameters, derived_parameters =
classify_parameters model in
- write_header dir;
- write_input_parameters input_parameters;
- write_derived_parameters derived_parameters;
- write_particles model.particles;
+ write_header oc dir;
+ write_input_parameters oc input_parameters;
+ write_derived_parameters oc derived_parameters;
+ write_particles oc model.particles;
if !include_hadrons then
- write_hadrons ();
- write_vertices model model.vertices;
+ write_hadrons oc;
+ write_vertices oc model model.vertices;
exit 0
end
- let options =
+ let write_whizard = Whizard.write
+
+ let coupling_order_option co =
+ let s = M.coupling_order_to_string co in
+ ("-order:" ^ s,
+ Arg.Int
+ (fun n ->
+ Printf.eprintf "coupling_order(%s) = %d\n" s n;
+ flush stderr (*; [M.set_coupling_order co n] *) ),
+ Printf.sprintf "n set %s coupling order n [>=0] (still ignored)" s)
+
+ let coupling_order_options () =
+ Arg.align (List.map coupling_order_option (all_coupling_orders ()))
+
+ let flavor_list_to_string f_list =
+ String.concat "|" (List.map flavor_to_string f_list)
+
+ let all_flavors () =
+ try
+ ThoList.flatmap snd (external_flavors ())
+ with
+ | Modeltools.Uninitialized _ -> []
+
+ let load_and_update_cmdline () =
+ load () (* [;
+ Options.global := !Options.global @ (coupling_order_options ());
+ Options.usage :=
+ "usage: " ^ Sys.argv.(0) ^
+ " [options] [-scatter|-decay] process {flavors: " ^
+ flavor_list_to_string (all_flavors ()) ^ "}"] *)
+
+ let options =
Options.create
[ ("UFO_dir", Arg.String (fun name -> ufo_directory := name),
- "UFO model directory (default: " ^ !ufo_directory ^ ")");
+ "dir UFO model directory (default: " ^ !ufo_directory ^ ")");
("Majorana", Arg.Set use_majorana_spinors,
- "use Majorana spinors (must come _before_ exec!)");
+ " use Majorana spinors (must come _before_ exec!)");
("divide_propagators_by_i", Arg.Set divide_propagators_by_i,
- "divide propagators by I (pre 2013 FeynRules convention)");
+ " divide propagators by I (pre 2013 FeynRules convention)");
("verbatim_Hg", Arg.Set verbatim_higgs_glue,
- "don't correct the color flows for effective Higgs Gluon couplings");
- ("write_WHIZARD", Arg.Unit Whizard.write,
- "write the WHIZARD model file (required once per model)");
+ " don't correct the color flows for effective Higgs Gluon couplings");
+ ("write_WHIZARD", Arg.Unit (fun () -> Whizard.write stdout),
+ " write the WHIZARD model file (required once per model)");
("long_flavors",
Arg.Unit (fun () -> Lookup.flavor_format := Lookup.Long),
- "write use the UFO flavor names instead of integers");
+ " write use the UFO flavor names instead of integers");
("dump", Arg.Set dump_raw,
- "dump UFO model for debugging the parser (must come _before_ exec!)");
+ " dump UFO model for debugging the parser (must come _before_ exec!)");
("all_fusions", Arg.Set include_all_fusions,
- "include all fusions in the fortran module");
+ " include all fusions in the fortran module");
("no_hadrons", Arg.Clear include_hadrons,
- "don't add any particle not in the UFO file");
+ " don't add any particle not in the UFO file");
("add_hadrons", Arg.Set include_hadrons,
- "add protons and beam remants for WHIZARD");
- ("exec", Arg.Unit load,
- "load the UFO model files (required _before_ using particles names)");
+ " add protons and beam remants for WHIZARD");
+ ("exec", Arg.Unit load_and_update_cmdline,
+ " load the UFO model files (required _before_ using particles names)");
("help", Arg.Unit (fun () -> prerr_endline "..."),
- "print information on the model")]
+ " print information on the model")]
end
module type Fortran_Target =
sig
val fuse :
Algebra.QC.t -> string ->
Coupling.lorentzn -> Coupling.fermion_lines ->
string -> string list -> string list -> Coupling.fusen -> unit
val lorentz_module :
?only:SSet.t -> ?name:string ->
?fortran_module:string -> ?parameter_module:string ->
Format_Fortran.formatter -> unit -> unit
end
module Targets =
struct
module Fortran : Fortran_Target =
struct
open Format_Fortran
let fuse = UFO_targets.Fortran.fuse
let lorentz_functions ff fusions () =
List.iter
(fun (name, s, l) ->
UFO_targets.Fortran.lorentz ff name s l)
fusions
let propagator_functions ff parameter_module propagators () =
List.iter
(fun (name, p) ->
UFO_targets.Fortran.propagator
ff name
parameter_module p.Propagator.variables
p.Propagator.spins
p.Propagator.numerator p.Propagator.denominator)
propagators
let lorentz_module
?only ?(name="omega_amplitude_ufo")
?(fortran_module="omega95")
?(parameter_module="parameter_module") ff () =
let printf fmt = fprintf ff fmt
and nl = pp_newline ff in
printf "module %s" name; nl ();
printf " use kinds"; nl ();
printf " use %s" fortran_module; nl ();
printf " implicit none"; nl ();
printf " private"; nl ();
let fusions = Model.fusions ?only ()
and propagators = Model.propagators () in
List.iter
(fun (name, _, _) -> printf " public :: %s" name; nl ())
fusions;
List.iter
(fun (name, _) -> printf " public :: pr_U_%s" name; nl ())
propagators;
UFO_targets.Fortran.eps4_g4_g44_decl ff ();
UFO_targets.Fortran.eps4_g4_g44_init ff ();
printf "contains"; nl ();
UFO_targets.Fortran.inner_product_functions ff ();
lorentz_functions ff fusions ();
propagator_functions ff parameter_module propagators ();
printf "end module %s" name; nl ();
pp_flush ff ()
end
end
module type Test =
sig
val suite : OUnit.test
end
module Test : Test =
struct
open OUnit
let lexer s =
UFO_lexer.token (UFO_lexer.init_position "" (Lexing.from_string s))
let suite_lexer_escapes =
"escapes" >:::
[ "single-quote" >::
(fun () ->
assert_equal (UFO_parser.STRING "a'b'c") (lexer "'a\\'b\\'c'"));
"unterminated" >::
(fun () ->
assert_raises End_of_file (fun () -> lexer "'a\\'b\\'c")) ]
let suite_lexer =
"lexer" >:::
[suite_lexer_escapes]
let suite =
"UFO" >:::
[suite_lexer]
end
Index: trunk/omega/src/omega_THDM_CKM.ml
===================================================================
--- trunk/omega/src/omega_THDM_CKM.ml (revision 8899)
+++ trunk/omega/src/omega_THDM_CKM.ml (revision 8900)
@@ -1,36 +1,27 @@
(* omega_THDM_CKM.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
cf. main AUTHORS file
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.Fortran)
- (Modellib_BSM.TwoHiggsDoublet(Modellib_BSM.THDM_CKM))
+module O = Omega.Mixed23(Target_Fortran.Make)(Modellib_BSM.TwoHiggsDoublet(Modellib_BSM.THDM_CKM))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/omega_SM_rx.ml
===================================================================
--- trunk/omega/src/omega_SM_rx.ml (revision 8899)
+++ trunk/omega/src/omega_SM_rx.ml (revision 8900)
@@ -1,36 +1,27 @@
(* omega_SM_rx.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Marco Sekulla <marco.sekulla@kit.edu>
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.Fortran)
- (Modellib_SM.SM(Modellib_SM.SM_k_matrix))
+module O = Omega.Mixed23(Target_Fortran.Make)(Modellib_SM.SM(Modellib_SM.SM_k_matrix))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/omega_HSExt.ml
===================================================================
--- trunk/omega/src/omega_HSExt.ml (revision 8899)
+++ trunk/omega/src/omega_HSExt.ml (revision 8900)
@@ -1,35 +1,26 @@
(* omega_HSExt.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.Fortran)
- (Modellib_BSM.HSExt(Modellib_BSM.BSM_bsm))
+module O = Omega.Mixed23(Target_Fortran.Make)(Modellib_BSM.HSExt(Modellib_BSM.BSM_bsm))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/omega/src/omega_Simplest.ml
===================================================================
--- trunk/omega/src/omega_Simplest.ml (revision 8899)
+++ trunk/omega/src/omega_Simplest.ml (revision 8900)
@@ -1,35 +1,26 @@
(* omega_Simplest.ml --
Copyright (C) 1999-2023 by
Wolfgang Kilian <kilian@physik.uni-siegen.de>
Thorsten Ohl <ohl@physik.uni-wuerzburg.de>
Juergen Reuter <juergen.reuter@desy.de>
with contributions from
Christian Speckner <cnspeckn@googlemail.com>
WHIZARD is free software; you can redistribute it and/or modify it
under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
WHIZARD is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *)
-module O = Omega.Mixed23(Targets.Fortran_Majorana)
- (Modellib_BSM.Simplest(Modellib_BSM.BSM_bsm))
+module O = Omega.Mixed23(Target_Fortran.Make_Majorana)(Modellib_BSM.Simplest(Modellib_BSM.BSM_bsm))
let _ = O.main ()
-
-(*i
- * Local Variables:
- * mode:caml
- * indent-tabs-mode:nil
- * page-delimiter:"^(\\* .*\n"
- * End:
-i*)
Index: trunk/synchronize.sh
===================================================================
--- trunk/synchronize.sh (revision 8899)
+++ trunk/synchronize.sh (revision 8900)
@@ -1,60 +1,177 @@
#!/bin/sh
### Consider it safer to explicitly mention all files that contain
### email addresses or copyright tags.
OLD_YEAR="Copyright (C) 1999-2022";
NEW_YEAR="Copyright (C) 1999-2023";
OLD_YEAR2="Copyright (C) 2001-2022";
NEW_YEAR2="Copyright (C) 2001-2023";
OLD_YEAR3="Copyright (C) 2019-2022";
NEW_YEAR3="Copyright (C) 2019-2023";
+OLD_YEAR4="Copyright (C) 2020-2022";
+NEW_YEAR4="Copyright (C) 2020-2023";
+OLD_YEAR5="Copyright (C) 2021-2022";
+NEW_YEAR5="Copyright (C) 2021-2023";
+OLD_YEAR6="Copyright (C) 2022-2022";
+NEW_YEAR6="Copyright (C) 2022-2023";
# OLD_ADDRESS="Soyoung Shim <soyoung.shim@desy.de>"
# NEW_ADDRESS="So Young Shim <soyoung.shim@desy.de>"
OLD_ADDRESS="Soyoung Shim"
NEW_ADDRESS="So Young Shim"
OLD_DATE="Mar 10 2023"
NEW_DATE="Mar 21 2023"
OLD_VERSION="3.1.2"
NEW_VERSION="3.1.2.1"
#OLD_STATUS="PACKAGE_STATUS=\"alpha\""
#NEW_STATUS="PACKAGE_STATUS=\"beta\""
OLD_STATUS="PACKAGE_STATUS=\"release\""
#NEW_STATUS="PACKAGE_STATUS=\"rc1\""
NEW_STATUS="PACKAGE_STATUS=\"alpha\""
## We should add an option to add an author here.
## share/doc/manual.tex should be changed manually
## We have to discuss the entries in gamelan/manual
## We have to discuss the entries in src/shower
MAIN_FILES="AUTHORS BUGS Makefile.am.in README build_master.sh tests/Makefile.am tests/models/Makefile.am tests/models/UFO/Makefile.am tests/models/UFO/SM/Makefile.am tests/models/UFO/MSSM/Makefile.am tests/functional_tests/Makefile.am tests/ext_tests_mssm/Makefile.am tests/ext_tests_nmssm/Makefile.am tests/ext_tests_ilc/Makefile.am tests/ext_tests_nlo/Makefile.am tests/ext_tests_nlo_add/Makefile.am tests/ext_tests_shower/Makefile.am tests/unit_tests/Makefile.am"
CONFIGURE_FILES="configure.ac.in src/noweb-frame/whizard-prelude.nw"
VERSION_FILES="NEWS circe2/src/circe2.nw"
SCRIPTS_FILES="scripts/Makefile.am scripts/whizard-config.in scripts/whizard-setup.csh.in scripts/whizard-setup.sh.in"
SHARE_FILES="share/Makefile.am share/doc/Makefile.am share/doc/custom.hva share/examples/NLO_eettbar_GoSam.sin share/examples/NLO_eettbar_OpenLoops.sin share/examples/HERA_DIS.sin share/examples/LEP_cc10.sin share/examples/LEP_higgs.sin share/examples/W-endpoint.sin share/examples/Z-lineshape.sin share/examples/Zprime.sin share/examples/casc_dec.sin share/examples/circe1.sin share/examples/eeww_polarized.sin share/examples/DrellYanMatchingP.sin share/examples/DrellYanMatchingW.sin share/examples/DrellYanNoMatchingP.sin share/examples/DrellYanNoMatchingW.sin share/examples/EEMatching2P.sin share/examples/EEMatching2W.sin share/examples/EEMatching3P.sin share/examples/EEMatching3W.sin share/examples/EEMatching4P.sin share/examples/EEMatching4W.sin share/examples/EEMatching5P.sin share/examples/EEMatching5W.sin share/examples/EENoMatchingP.sin share/examples/EENoMatchingW.sin share/examples/LHC_VBS_likesign.sin share/tests/Makefile.am"
SRC_FILES="src/Makefile.am src/feynmf/Makefile.am src/hepmc/Makefile.am src/hepmc/HepMCWrap_dummy.f90 src/lcio/Makefile.am src/lcio/LCIOWrap_dummy.f90 src/tauola/Makefile.am src/lhapdf/Makefile.am src/lhapdf/lhapdf.f90 src/lhapdf5/Makefile.am src/pdf_builtin/Makefile.am src/pdf_builtin/pdf_builtin.f90 src/pdf_builtin/pdf_builtin_sub.f90 src/qed_pdf/Makefile.am src/qed_pdf/qed_pdf.nw src/fastjet/Makefile.am src/fastjet/cpp_strings.f90 src/fastjet/cpp_strings_sub.f90 src/fastjet/fastjet.f90 src/fastjet/Makefile.am src/hoppet/Makefile.am src/hoppet/hoppet.f90 contrib/Makefile.am contrib/pythia6/Makefile.am contrib/tauola/Makefile.am contrib/mcfio/Makefile.am contrib/stdhep/Makefile.am src/noweb-frame/Makefile.am src/noweb-frame/whizard-prelude.nw src/noweb-frame/whizard-postlude.nw src/utilities/Makefile.am src/matrix_elements/Makefile.am src/matrix_elements/matrix_elements.nw src/mci/Makefile.am src/vegas/Makefile.am src/vegas/vegas.nw src/mci/mci.nw src/utilities/utilities.nw src/testing/Makefile.am src/testing/testing.nw src/system/Makefile.am src/system/system.nw src/system/system_dependencies.f90.in src/system/debug_master.f90.in src/combinatorics/Makefile.am src/combinatorics/combinatorics.nw src/parsing/Makefile.am src/parsing/parsing.nw src/particles/Makefile.am src/particles/particles.nw src/phase_space/Makefile.am src/phase_space/phase_space.nw src/physics/Makefile.am src/physics/physics.nw src/beams/Makefile.am src/beams/beams.nw src/qft/Makefile.am src/qft/qft.nw src/rng/Makefile.am src/rng/rng.nw src/types/Makefile.am src/types/types.nw src/whizard-core/Makefile.am src/whizard-core/whizard.nw src/pythia8/Makefile.am src/shower/Makefile.am src/shower/shower.nw src/muli/Makefile.am src/muli/muli.nw src/model_features/model_features.nw src/model_features/Makefile.am src/me_methods/Makefile.am src/me_methods/me_methods.nw src/gosam/Makefile.am src/gosam/gosam.nw src/fks/Makefile.am src/fks/fks.nw src/expr_base/Makefile.am src/expr_base/expr_base.nw src/events/Makefile.am src/events/events.nw src/blha/Makefile.am src/blha/blha.nw src/variables/Makefile.am src/variables/variables.nw src/xdr/Makefile.am src/xdr/xdr_wo_stdhep.f90 src/looptools/Makefile.am src/process_integration/Makefile.am src/process_integration/process_integration.nw src/matching/Makefile.am src/matching/matching.nw src/openloops/Makefile.am src/openloops/openloops.nw src/recola/Makefile.am src/recola/recola.nw src/transforms/Makefile.am src/transforms/transforms.nw src/threshold/Makefile.am src/threshold/threshold.nw src/api/Makefile.am src/api/api.nw src/main/Makefile.am src/main/main.nw"
CIRCE1_FILES="circe1/Makefile.am circe1/share/Makefile.am circe1/share/doc/Makefile.am circe1/src/Makefile.am circe1/src/circe1.nw circe1/minuit/Makefile.am circe1/src/minuit.nw circe1/tools/Makefile.am"
CIRCE2_FILES="circe2/Makefile.am circe2/share/Makefile.am circe2/share/doc/Makefile.am circe2/src/Makefile.am circe2/src/Makefile.ocaml circe2/src/circe2.nw circe2/src/Makefile.sources circe2/src/postlude.nw circe2/tests/Makefile.am circe2/src/circe2_tool.ml circe2/src/commands.ml circe2/src/commands.mli circe2/src/diffmap.ml circe2/src/diffmap.mli circe2/src/diffmaps.ml circe2/src/diffmaps.mli circe2/src/division.ml circe2/src/division.mli circe2/src/events.ml circe2/src/events.mli circe2/src/filter.ml circe2/src/filter.mli circe2/src/float.ml circe2/src/float.mli circe2/src/grid.ml circe2/src/grid.mli circe2/src/histogram.mli circe2/src/histogram.ml circe2/src/syntax.ml circe2/src/syntax.mli circe2/src/thoArray.ml circe2/src/thoArray.mli circe2/src/thoMatrix.ml circe2/src/thoMatrix.mli"
SRC_GAMELAN_FILES="src/gamelan/Makefile.am src/gamelan/whizard-gml.in"
SRC_BASICS_FILES="src/basics/constants.f90 src/basics/io_units.f90 src/basics/Makefile.am"
-SRC_MODELS_FILES="src/models/threeshl_bundle/Makefile.am src/models/threeshl_bundle/threeshl_bundle.f90 src/models/threeshl_bundle/threeshl_bundle_lt.f90 src/models/external.Test.f90 src/models/external.Threeshl.f90 src/models/external.SM_tt_threshold.f90 src/models/Makefile.am src/models/parameters.THDM.f90 src/models/parameters.GravTest.f90 src/models/parameters.Littlest.f90 src/models/parameters.Littlest_Eta.f90 src/models/parameters.Littlest_Tpar.f90 src/models/parameters.MSSM.f90 src/models/parameters.MSSM_4.f90 src/models/parameters.MSSM_CKM.f90 src/models/parameters.MSSM_Grav.f90 src/models/parameters.MSSM_Hgg.f90 src/models/parameters.NMSSM.f90 src/models/parameters.NMSSM_CKM.f90 src/models/parameters.NMSSM_Hgg.f90 src/models/parameters.PSSSM.f90 src/models/parameters.QCD.f90 src/models/parameters.QED.f90 src/models/parameters.SM.f90 src/models/parameters.SM_CKM.f90 src/models/parameters.SM_ac.f90 src/models/parameters.SM_ac_CKM.f90 src/models/parameters.SM_dim6.f90 src/models/parameters.SM_rx.f90 src/models/parameters.SM_ul.f90 src/models/parameters.NoH_rx.f90 src/models/parameters.AltH.f90 src/models/parameters.SSC.f90 src/models/parameters.SSC_2.f90 src/models/parameters.SSC_AltT.f90 src/models/parameters.SM_top.f90 src/models/parameters.SM_top_anom.f90 src/models/parameters.SM_Higgs.f90 src/models/parameters.SM_Higgs_CKM.f90 src/models/parameters.SM_tt_threshold.f90 src/models/parameters.Simplest.f90 src/models/parameters.Simplest_univ.f90 src/models/parameters.Template.f90 src/models/parameters.HSExt.f90 src/models/parameters.Test.f90 src/models/parameters.Threeshl.f90 src/models/parameters.UED.f90 src/models/parameters.Xdim.f90 src/models/parameters.Zprime.f90 src/models/parameters.WZW.f90"
-OMEGA_FILES="omega/Makefile.am omega/share/Makefile.am omega/share/doc/Makefile.am omega/src/Makefile.am omega/src/Makefile.ocaml omega/src/Makefile.sources omega/bin/Makefile.am omega/extensions/Makefile.am omega/extensions/people/Makefile.am omega/extensions/people/jr/Makefile.am omega/extensions/people/jr/f90_SAGT.ml omega/extensions/people/jr/f90_SQED.ml omega/extensions/people/jr/f90_WZ.ml omega/extensions/people/tho/Makefile.am omega/extensions/people/tho/f90_O2.ml omega/lib/Makefile.am omega/models/Makefile.am omega/scripts/Makefile.am omega/scripts/omega-config.in omega/tools/Makefile.am omega/tests/parameters_QED.f90 omega/tests/parameters_QCD.f90 omega/tests/parameters_SM.f90 omega/tests/parameters_SM_CKM.f90 omega/tests/parameters_SM_Higgs.f90 omega/tests/parameters_SM_from_UFO.f90 omega/tests/parameters_SYM.f90 omega/tests/parameters_SM_top_anom.f90 omega/tests/parameters_HSExt.f90 omega/tests/parameters_THDM.f90 omega/tests/parameters_THDM_CKM.f90 omega/tests/parameters_Zprime.f90 omega/tests/test_openmp.f90 omega/tests/tao_random_numbers.f90 omega/tests/test_qed_eemm.f90 omega/tests/Makefile.am omega/tests/benchmark.f90 omega/tests/color_test_lib.f90 omega/tests/omega_interface.f90 omega/tests/ward_lib.f90 omega/tests/omega_unit.ml omega/tests/compare_lib.f90 omega/tests/compare_lib_recola.f90 omega/tests/benchmark_UFO_SM.f90 omega/tests/benchmark_UFO_SMEFT.f90 omega/tests/keystones_omegalib_generate.ml omega/tests/keystones_UFO_generate.ml omega/tests/keystones_omegalib_bispinors_generate.ml omega/tests/keystones_UFO_bispinors_generate.ml omega/tests/keystones.ml omega/tests/keystones.mli omega/tests/keystones_tools.f90 omega/tests/fermi_lib.f90 omega/tests/parameters_SM_Higgs_recola.f90 omega/tests/parameters_MSSM.f90 omega/tests/keystones.mli"
-OMEGA_SRC_FILES="omega/src/algebra.ml omega/src/algebra.mli omega/src/bundle.ml omega/src/bundle.mli omega/src/cache.ml omega/src/cache.mli omega/src/cascade.ml omega/src/cascade.mli omega/src/cascade_lexer.mll omega/src/cascade_parser.mly omega/src/cascade_syntax.ml omega/src/cascade_syntax.mli omega/src/charges.ml omega/src/charges.mli omega/src/color.ml omega/src/color.mli omega/src/colorize.ml omega/src/colorize.mli omega/src/combinatorics.ml omega/src/combinatorics.mli omega/src/complex.ml omega/src/complex.mli omega/src/config.ml.in omega/src/config.mli omega/src/count.ml omega/src/coupling.mli omega/src/DAG.ml omega/src/DAG.mli omega/src/fusion.ml omega/src/fusion_vintage.ml omega/src/fusion.mli omega/src/fusion_vintage.mli omega/src/linalg.ml omega/src/linalg.mli omega/src/model.mli omega/src/modellib_BSM.ml omega/src/modellib_NoH.ml omega/src/modellib_NoH.mli omega/src/modellib_BSM.mli omega/src/modellib_MSSM.ml omega/src/modellib_MSSM.mli omega/src/modellib_NMSSM.ml omega/src/modellib_NMSSM.mli omega/src/modellib_PSSSM.ml omega/src/modellib_PSSSM.mli omega/src/modellib_SM.ml omega/src/modellib_SM.mli omega/src/modellib_Zprime.mli omega/src/modellib_Zprime.ml omega/src/modellib_WZW.mli omega/src/modellib_WZW.ml omega/src/UFO.ml omega/src/UFO.mli omega/src/UFO_targets.ml omega/src/UFO_Lorentz.ml omega/src/UFO_syntax.ml omega/src/UFO_syntax.mli omega/src/UFOx.ml omega/src/UFOx.mli omega/src/UFO_lexer.mll omega/src/UFO_parser.mly omega/src/UFOx_syntax.ml omega/src/UFOx_syntax.mli omega/src/UFOx_lexer.mll omega/src/UFOx_parser.mly omega/src/omega_UFO.ml omega/src/modeltools.ml omega/src/modeltools.mli omega/src/momentum.ml omega/src/momentum.mli omega/src/OVM.ml omega/src/OVM.mli omega/src/omega.ml omega/src/omega.mli omega/src/omega_THDM.ml omega/src/omega_THDM_VM.ml omega/src/omega_THDM_CKM.ml omega/src/omega_THDM_CKM_VM.ml omega/src/omega_CQED.ml omega/src/omega_GravTest.ml omega/src/omega_Littlest.ml omega/src/omega_Littlest_Eta.ml omega/src/omega_Littlest_Tpar.ml omega/src/omega_Littlest_Zprime.ml omega/src/omega_MSSM.ml omega/src/omega_MSSM_CKM.ml omega/src/omega_MSSM_Grav.ml omega/src/omega_MSSM_Hgg.ml omega/src/omega_NMSSM.ml omega/src/omega_NMSSM_CKM.ml omega/src/omega_NMSSM_Hgg.ml omega/src/omega_PSSSM.ml omega/src/omega_Phi3.ml omega/src/omega_Phi3h.ml omega/src/omega_Phi4.ml omega/src/omega_Phi4h.ml omega/src/omega_QCD.ml omega/src/omega_QCD_VM.ml omega/src/omega_QED.ml omega/src/omega_QED_VM.ml omega/src/omega_SM.ml omega/src/omega_SM_tt_threshold.ml omega/src/omega_SM_VM.ml omega/src/omega_SM_CKM.ml omega/src/omega_SM_CKM_VM.ml omega/src/ovm_SM.ml omega/src/process.ml omega/src/process.mli omega/src/thoFilename.ml omega/src/thoFilename.mli omega/src/omega_SM_Higgs.ml omega/src/omega_SM_Higgs_CKM.ml omega/src/omega_SM_Higgs_VM.ml omega/src/omega_SM_Higgs_CKM_VM.ml omega/src/omega_SM_Rxi.ml omega/src/omega_SM_ac.ml omega/src/omega_SM_ac_CKM.ml omega/src/omega_SM_clones.ml omega/src/omega_SM_rx.ml omega/src/omega_SM_ul.ml omega/src/omega_SM_Majorana_legacy.ml omega/src/omega_SM_Majorana.ml omega/src/omega_NoH_rx.ml omega/src/omega_AltH.ml omega/src/omega_SSC.ml omega/src/omega_SSC_2.ml omega/src/omega_SM_top.ml omega/src/omega_SM_top_anom.ml omega/src/omega_SMh.ml omega/src/omega_SYM.ml omega/src/omega_Simplest.ml omega/src/omega_Simplest_univ.ml omega/src/omega_Template.ml omega/src/omega_HSExt.ml omega/src/omega_HSExt_VM.ml omega/src/omega_Threeshl.ml omega/src/omega_Threeshl_nohf.ml omega/src/omega_UED.ml omega/src/omega_Xdim.ml omega/src/omega_Zprime.ml omega/src/omega_Zprime_VM.ml omega/src/omega_logo.mp omega/src/omega_parameters_tool.nw omega/src/omegalib.nw omega/src/options.ml omega/src/options.mli omega/src/partition.ml omega/src/partition.mli omega/src/phasespace.ml omega/src/phasespace.mli omega/src/pmap.ml omega/src/pmap.mli omega/src/powSet.ml omega/src/powSet.mli omega/src/product.ml omega/src/product.mli omega/src/progress.ml omega/src/progress.mli omega/src/permutation.ml omega/src/permutation.mli omega/src/target.mli omega/src/targets.ml omega/src/targets.mli omega/src/targets_Kmatrix.ml omega/src/targets_Kmatrix.mli omega/src/test_linalg.ml omega/src/thoArray.ml omega/src/thoFilename.ml omega/src/thoArray.mli omega/src/thoList.ml omega/src/thoList.mli omega/src/thoString.ml omega/src/thoString.mli omega/src/topology.ml omega/src/topology.mli omega/src/tree.ml omega/src/tree.mli omega/src/tree2.ml omega/src/tree2.mli omega/src/trie.ml omega/src/trie.mli omega/src/tuple.ml omega/src/tuple.mli omega/src/vertex.ml omega/src/vertex.mli omega/src/vertex_lexer.mll omega/src/vertex_parser.mly omega/src/vertex_syntax.ml omega/src/vertex_syntax.mli omega/src/whizard.ml omega/src/whizard.mli omega/src/whizard_tool.ml omega/src/constants.f90 omega/src/sets.mli omega/src/sets.ml omega/src/UFO_tools.ml omega/src/UFO_tools.mli omega/src/fortran_unit.ml omega/src/format_Fortran.ml omega/src/format_Fortran.mli omega/src/omega_UFO_Majorana.ml omega/src/omega_UFO_Dirac.ml omega/src/young.mli omega/src/young.ml"
+SRC_MODELS_FILES="\
+ src/models/threeshl_bundle/Makefile.am src/models/threeshl_bundle/threeshl_bundle.f90 \
+ src/models/threeshl_bundle/threeshl_bundle_lt.f90 src/models/external.Test.f90 \
+ src/models/external.Threeshl.f90 src/models/external.SM_tt_threshold.f90 src/models/Makefile.am \
+ src/models/parameters.THDM.f90 src/models/parameters.GravTest.f90 src/models/parameters.Littlest.f90 \
+ src/models/parameters.Littlest_Eta.f90 src/models/parameters.Littlest_Tpar.f90 \
+ src/models/parameters.MSSM.f90 src/models/parameters.MSSM_4.f90 src/models/parameters.MSSM_CKM.f90 \
+ src/models/parameters.MSSM_Grav.f90 src/models/parameters.MSSM_Hgg.f90 src/models/parameters.NMSSM.f90 \
+ src/models/parameters.NMSSM_CKM.f90 src/models/parameters.NMSSM_Hgg.f90 src/models/parameters.PSSSM.f90 \
+ src/models/parameters.QCD.f90 src/models/parameters.QED.f90 src/models/parameters.SM.f90 \
+ src/models/parameters.SM_CKM.f90 src/models/parameters.SM_ac.f90 src/models/parameters.SM_ac_CKM.f90 \
+ src/models/parameters.SM_dim6.f90 src/models/parameters.SM_rx.f90 src/models/parameters.SM_ul.f90 \
+ src/models/parameters.NoH_rx.f90 src/models/parameters.AltH.f90 src/models/parameters.SSC.f90 \
+ src/models/parameters.SSC_2.f90 src/models/parameters.SSC_AltT.f90 src/models/parameters.SM_top.f90 \
+ src/models/parameters.SM_top_anom.f90 src/models/parameters.SM_Higgs.f90 \
+ src/models/parameters.SM_Higgs_CKM.f90 src/models/parameters.SM_tt_threshold.f90 \
+ src/models/parameters.Simplest.f90 src/models/parameters.Simplest_univ.f90 \
+ src/models/parameters.Template.f90 src/models/parameters.HSExt.f90 src/models/parameters.Test.f90 \
+ src/models/parameters.Threeshl.f90 src/models/parameters.UED.f90 src/models/parameters.Xdim.f90 \
+ src/models/parameters.Zprime.f90 src/models/parameters.WZW.f90"
+OMEGA_FILES="\
+ omega/Makefile.am omega/share/Makefile.am omega/share/doc/Makefile.am \
+ omega/src/Makefile.am omega/src/Makefile.ocaml omega/src/Makefile.sources \
+ omega/bin/Makefile.am omega/extensions/Makefile.am omega/extensions/people/Makefile.am \
+ omega/extensions/people/jr/Makefile.am omega/extensions/people/jr/f90_SAGT.ml \
+ omega/extensions/people/jr/f90_SQED.ml omega/extensions/people/jr/f90_WZ.ml \
+ omega/extensions/people/tho/Makefile.am omega/extensions/people/tho/f90_O2.ml \
+ omega/lib/Makefile.am omega/models/Makefile.am omega/scripts/Makefile.am \
+ omega/scripts/omega-config.in omega/tools/Makefile.am omega/tests/parameters_QED.f90 \
+ omega/tests/parameters_QCD.f90 omega/tests/parameters_SM.f90 omega/tests/parameters_SM_CKM.f90 \
+ omega/tests/parameters_SM_Higgs.f90 omega/tests/parameters_SM_from_UFO.f90 omega/tests/parameters_SYM.f90 \
+ omega/tests/parameters_SM_top_anom.f90 omega/tests/parameters_HSExt.f90 omega/tests/parameters_THDM.f90 \
+ omega/tests/parameters_THDM_CKM.f90 omega/tests/parameters_Zprime.f90 omega/tests/test_openmp.f90 \
+ omega/tests/tao_random_numbers.f90 omega/tests/test_qed_eemm.f90 omega/tests/Makefile.am \
+ omega/tests/benchmark.f90 omega/tests/color_test_lib.f90 omega/tests/omega_interface.f90 \
+ omega/tests/ward_lib.f90 omega/tests/omega_unit.ml omega/tests/compare_lib.f90 \
+ omega/tests/compare_lib_recola.f90 omega/tests/benchmark_UFO_SM.f90 omega/tests/benchmark_UFO_SMEFT.f90 \
+ omega/tests/keystones_omegalib_generate.ml omega/tests/keystones_UFO_generate.ml \
+ omega/tests/keystones_omegalib_bispinors_generate.ml omega/tests/keystones_UFO_bispinors_generate.ml \
+ omega/tests/keystones.ml omega/tests/keystones.mli omega/tests/keystones_tools.f90 \
+ omega/tests/fermi_lib.f90 omega/tests/parameters_SM_Higgs_recola.f90 omega/tests/parameters_MSSM.f90 \
+ omega/tests/keystones.mli"
+OMEGA_SRC_FILES="\
+ omega/src/algebra.ml omega/src/algebra.mli omega/src/arrow.ml omega/src/arrow.mli \
+ omega/src/bundle.ml omega/src/bundle.mli omega/src/cache.ml omega/src/cache.mli \
+ omega/src/cascade.ml omega/src/cascade.mli omega/src/cascade_lexer.mll \
+ omega/src/cascade_parser.mly omega/src/cascade_syntax.ml omega/src/cascade_syntax.mli \
+ omega/src/charges.ml omega/src/charges.mli omega/src/color.ml omega/src/color.mli \
+ omega/src/colorize.ml omega/src/colorize.mli omega/src/combinatorics.ml omega/src/combinatorics.mli \
+ omega/src/complex.ml omega/src/complex.mli omega/src/config.ml.in omega/src/config.mli \
+ omega/src/count.ml omega/src/coupling.mli omega/src/DAG.ml omega/src/DAG.mli \
+ omega/src/fusion.ml omega/src/fusion_vintage.ml omega/src/fusion.mli omega/src/fusion_vintage.mli \
+ omega/src/linalg.ml omega/src/linalg.mli omega/src/model.mli omega/src/modellib_BSM.ml \
+ omega/src/modellib_NoH.ml omega/src/modellib_NoH.mli omega/src/modellib_BSM.mli \
+ omega/src/modellib_MSSM.ml omega/src/modellib_MSSM.mli omega/src/modellib_NMSSM.ml \
+ omega/src/modellib_NMSSM.mli omega/src/modellib_PSSSM.ml omega/src/modellib_PSSSM.mli \
+ omega/src/modellib_SM.ml omega/src/modellib_SM.mli omega/src/modellib_Zprime.mli \
+ omega/src/modellib_Zprime.ml omega/src/modellib_WZW.mli omega/src/modellib_WZW.ml omega/src/UFO.ml \
+ omega/src/UFO.mli omega/src/UFO_targets.ml omega/src/UFO_Lorentz.ml omega/src/UFO_syntax.ml \
+ omega/src/UFO_syntax.mli omega/src/UFOx.ml omega/src/UFOx.mli omega/src/UFO_lexer.mll \
+ omega/src/UFO_parser.mly omega/src/UFOx_syntax.ml omega/src/UFOx_syntax.mli omega/src/UFOx_lexer.mll \
+ omega/src/UFOx_parser.mly omega/src/omega_UFO.ml omega/src/modeltools.ml omega/src/modeltools.mli \
+ omega/src/momentum.ml omega/src/momentum.mli omega/src/NEList.nl omega/src/NEList.mli \
+ omega/src/NList.ml omega/src/NList.mli omega/src/OVM.ml omega/src/OVM.mli \
+ omega/src/omega.ml omega/src/omega.mli omega/src/omega_THDM.ml omega/src/omega_THDM_VM.ml \
+ omega/src/omega_THDM_CKM.ml omega/src/omega_THDM_CKM_VM.ml omega/src/omega_CQED.ml \
+ omega/src/omega_GravTest.ml omega/src/omega_Littlest.ml omega/src/omega_Littlest_Eta.ml \
+ omega/src/omega_Littlest_Tpar.ml omega/src/omega_Littlest_Zprime.ml \
+ omega/src/omega_MSSM.ml omega/src/omega_MSSM_CKM.ml omega/src/omega_MSSM_Grav.ml \
+ omega/src/omega_MSSM_Hgg.ml omega/src/omega_NMSSM.ml omega/src/omega_NMSSM_CKM.ml \
+ omega/src/omega_NMSSM_Hgg.ml omega/src/omega_PSSSM.ml \
+ omega/src/omega_Phi3.ml omega/src/omega_Phi3h.ml omega/src/omega_Phi4.ml omega/src/omega_Phi4h.ml \
+ omega/src/omega_QCD.ml omega/src/omega_QCD_VM.ml omega/src/omega_QED.ml omega/src/omega_QED_VM.ml \
+ omega/src/omega_SM.ml omega/src/omega_SM_tt_threshold.ml omega/src/omega_SM_VM.ml \
+ omega/src/omega_SM_CKM.ml omega/src/omega_SM_CKM_VM.ml omega/src/ovm_SM.ml \
+ omega/src/process.ml omega/src/process.mli omega/src/thoFilename.ml \
+ omega/src/thoFilename.mli omega/src/omega_SM_Higgs.ml omega/src/omega_SM_Higgs_CKM.ml \
+ omega/src/omega_SM_Higgs_VM.ml omega/src/omega_SM_Higgs_CKM_VM.ml omega/src/omega_SM_Rxi.ml \
+ omega/src/omega_SM_ac.ml omega/src/omega_SM_ac_CKM.ml omega/src/omega_SM_clones.ml \
+ omega/src/omega_SM_rx.ml omega/src/omega_SM_ul.ml omega/src/omega_SM_Majorana_legacy.ml \
+ omega/src/omega_SM_Majorana.ml omega/src/omega_NoH_rx.ml omega/src/omega_AltH.ml \
+ omega/src/omega_SSC.ml omega/src/omega_SSC_2.ml omega/src/omega_SM_top.ml \
+ omega/src/omega_SM_top_anom.ml omega/src/omega_SMh.ml omega/src/omega_SYM.ml \
+ omega/src/omega_Simplest.ml omega/src/omega_Simplest_univ.ml omega/src/omega_Template.ml \
+ omega/src/omega_HSExt.ml omega/src/omega_HSExt_VM.ml omega/src/omega_Threeshl.ml \
+ omega/src/omega_Threeshl_nohf.ml omega/src/omega_UED.ml omega/src/omega_Xdim.ml \
+ omega/src/omega_Zprime.ml omega/src/omega_Zprime_VM.ml omega/src/omega_logo.mp \
+ omega/src/omega_parameters_tool.nw omega/src/omegalib.nw omega/src/options.ml \
+ omega/src/options.mli omega/src/PArray.ml omega/src/PArray.mli \
+ omega/src/partition.ml omega/src/partition.mli omega/src/phasespace.ml \
+ omega/src/phasespace.mli omega/src/pmap.ml omega/src/pmap.mli \
+ omega/src/powSet.ml omega/src/powSet.mli omega/src/product.ml \
+ omega/src/product.mli omega/src/progress.ml omega/src/progress.mli \
+ omega/src/permutation.ml omega/src/permutation.mli \
+ omega/src/target.mli omega/src/targets.ml omega/src/targets.mli \
+ omega/src/targets_vintage.ml omega/src/targets_vintage.mli \
+ omega/src/target_VM.ml omega/src/target_VM.mli \
+ omega/src/target_Fortran.ml omega/src/target_Fortran.mli \
+ omega/src/target_Fortran_Names.ml omega/src/target_Fortran_Names.mli \
+ omega/src/targets_Kmatrix.ml omega/src/targets_Kmatrix.mli omega/src/test_linalg.ml \
+ omega/src/thoArray.ml omega/src/thoFilename.ml omega/src/thoArray.mli \
+ omega/src/thoList.ml omega/src/thoList.mli omega/src/thoString.ml \
+ omega/src/thoString.mli omega/src/topology.ml omega/src/topology.mli \
+ omega/src/tree.ml omega/src/tree.mli omega/src/tree2.ml \
+ omega/src/tree2.mli omega/src/trie.ml omega/src/trie.mli \
+ omega/src/tuple.ml omega/src/tuple.mli omega/src/vertex.ml \
+ omega/src/vertex.mli omega/src/vertex_lexer.mll omega/src/vertex_parser.mly \
+ omega/src/vertex_syntax.ml omega/src/vertex_syntax.mli omega/src/whizard.ml \
+ omega/src/whizard.mli omega/src/whizard_tool.ml omega/src/constants.f90 \
+ omega/src/sets.mli omega/src/sets.ml omega/src/UFO_tools.ml \
+ omega/src/UFO_tools.mli omega/src/fortran_unit.ml omega/src/format_Fortran.ml \
+ omega/src/format_Fortran.mli omega/src/omega_UFO_Majorana.ml omega/src/omega_UFO_Dirac.ml \
+ omega/src/young.mli omega/src/young.ml omega/src/feynmp.mli \
+ omega/src/feynmp.ml omega/src/omega_cli.mli omega/src/omega_cli.ml omega/src/omega3.ml"
SRC_PDF_BUILTIN_FILES="src/pdf_builtin/pdf_builtin.f90"
VAMP_FILES="vamp/Makefile.am vamp/share/Makefile.am vamp/share/doc/Makefile.am vamp/src/Makefile.am vamp/tests/Makefile.am"
FILES="$MAIN_FILES $CONFIGURE_FILES $VERSION_FILES $SHARE_FILES $OMEGA_FILES $SCRIPTS_FILES $SRC_FILES $CIRCE1_FILES $CIRCE2_FILES $SRC_GAMELAN_FILES $SRC_PDF_BUILTIN_FILES $VAMP_FILES $SRC_BASICS_FILES $SRC_MODELS_FILES $OMEGA_SRC_FILES"
for f in $FILES; do
-sed -e "s/$OLD_YEAR/$NEW_YEAR/g" -e "s/$OLD_YEAR2/$NEW_YEAR2/g" -e "s/$OLD_YEAR3/$NEW_YEAR3/g" $f > $f.tmp;
+sed -e "s/$OLD_YEAR/$NEW_YEAR/g" -e "s/$OLD_YEAR2/$NEW_YEAR2/g" -e "s/$OLD_YEAR3/$NEW_YEAR3/g" -e "s/$OLD_YEAR4/$NEW_YEAR4/g" -e "s/$OLD_YEAR5/$NEW_YEAR5/g" -e "s/$OLD_YEAR6/$NEW_YEAR6/g" $f > $f.tmp;
cp -f $f.tmp $f;
rm -f $f.tmp;
done
CHANGE_FILES="$CONFIGURE_FILES $VERSION_FILES"
for f in $CHANGE_FILES; do
sed -e "s/$OLD_DATE/$NEW_DATE/g" -e "s/$OLD_VERSION/$NEW_VERSION/g" -e "s/$OLD_STATUS/$NEW_STATUS/g" $f > $f.tmp;
cp -f $f.tmp $f;
rm -f $f.tmp;
done
Index: trunk/ChangeLog
===================================================================
--- trunk/ChangeLog (revision 8899)
+++ trunk/ChangeLog (revision 8900)
@@ -1,2410 +1,2410 @@
ChangeLog -- Summary of changes to the WHIZARD package
Use git log/svn log to see detailed changes.
Version 3.1.2.1
2023-10-02
CIRCE2: add 'null' maps for regions with not enough statistics
- Since OCaml 4.08, we can retire the Bigarray compatibility hack
+ OMEGA/CIRCE2: remove pre OCaml 4.08 workarounds
2023-09-25
Minimal compiler versions: OCaml 4.08, gfortran 9.1.0
2023-06-01
Common folder 'contrib' for external codes shipped with WHIZARD
2023-05-28
Bug fix UFO interface:workaround for case-sensitive parameters
2023-05-05
Update of meson and baryon listings in SM hadrons model
2023-03-28
Workaround for Intel oneAPI 2022/23 regression(s)
##################################################################
2023-03-21
RELEASE: version 3.1.2
2023-03-21
Bug fix in cyclic build dependence of WHIZARD core
2023-03-11
Resolve minor inconsistency in manual for NLO real partition
##################################################################
2023-03-10
RELEASE: version 3.1.1
2023-03-09
Bug fix in UFO file parser
Small bug fix in NLO EW infrastructure
2023-03-01
Bug fix: numerical mapping stability for peaked PDFs
2023-02-28
Bug fix UFO interface: avoid too long ME code lines
2023-02-22
Infrastructure for calculation of kinematic MT2 variable
2023-02-17
Bug fix UFO interface: correct parentheses in rational functions
##################################################################
2022-12-14
RELEASE: version 3.1.0
2022-12-12
Bug fix Pythia8 interface: production vertices, shower history
O'Mega support for epsilon tensor color structures
2023-01-27
Support for loop-induced processes
2022-11-30
O'Mega support for general SU(N) color representations
2022-11-07
Modernize configure checks for Python versions v3.10+
2022-10-21
General POWHEG matching
with optional NLO real phase space partitioning
2022-09-26
Bug fix: accept negative scale values in SLHA block header
2022-08-08
Numerical stability of testsuite for Apple M1 processors
2022-08-07
Technically allow for muons as CIRCE2 beam spectra
2022-06-22
POWHEG matching for Drell-Yan and similar processes
2022-06-12
Add unit tests for Lorentz and phase-space modules
2022-05-09
Massive eikonals: Numeric robustness at ultrahigh energies
2022-04-20
Bug fix for VAMP2 event generation with indefinite samples
##################################################################
2022-04-06
RELEASE: version 3.0.3
2022-04-05
POWHEG matching for single flavor hadron collisions
2022-03-31
NLO EW processes with massless leptons and jets (i.e.
jet clustering and photon recombination) supported
NLO EW for massive initial leptons validated
2022-03-27
Complete implementation/validation of NLL electron PDFs
2022-02-22
Bug fix: correct normalization for CIRCE2+EPA+polarization
2022-02-21
WHIZARD core now uses Fortran modules and submodules
2022-01-27
Infrastructure for POWHEG matching for hadron collisions
2021-12-16
Event files can be written/read also for decay processes
Implementation of running QED coupling alpha
2021-12-10
Independent variations of renormalization/factorization scale
##################################################################
2021-11-23
RELEASE: version 3.0.2
2021-11-19
Support for a wide class of mixed NLO QCD/EW processes
2021-11-18
Add pp processes for NLO EW corrections to testsuite
2021-11-11
Output numerically critical values with LCIO 2.17+ as double
2021-11-05
Minor refactoring on phase space points and kinematics
2021-10-21
NLO (QCD) differential distributions supported for full
lepton collider setup: polarization, QED ISR, beamstrahlung
2021-10-15
SINDARIN now has a sum and product function of expressions,
SINDARIN supports observables defined on full (sub)events
First application: transverse mass
Bug fix: 2HDM did not allow H+, H- as external particles
2021-10-14
CT18 PDFs included (NLO, NNLO)
2021-09-30
Bug fix: keep non-recombined photons in the event record
2021-09-13
Modular NLO event generation with real partition
2021-08-20
Bug fix: correctly reading in NLO fixed order events
2021-08-06
Generalize optional partitioning of the NLO real phase space
##################################################################
2021-07-08
RELEASE: version 3.0.1
2021-07-06
MPI parallelization now comes with two incarnations:
- standard MPI parallelization ("simple", default)
- MPI with load balancer ("load")
2021-07-05
Bug fix for C++17 default compilers w/ HepMC3/ROOT interface
2021-07-02
Improvement for POWHEG matching:
- implement massless recoil case
- enable reading in existing POWHEG grids
- support kinematic cuts at generator level
2021-07-01
Distinguish different cases of photons in NLO EW corrections
2021-06-21
Option to keep negative PDF entries or set them zero
2021-05-31
Full LCIO MC production files can be properly recasted
2021-05-24
Use defaults for UFO models without propagators.py
2021-05-21
Bug fix: prevent invalid code for UFO models containing hyphens
2021-05-20
UFO files with scientific notation float constants allowed
UFO files: max. n-arity of vertices bound by process multiplicity
##################################################################
2021-04-27
RELEASE: version 3.0.0
2021-04-20
Minimal required OCaml version is now 4.05.0.
Bug fix for tau polarization from stau decays
2021-04-19
NLO EW splitting functions and collinear remnants completed
Photon recombination implemented
2021-04-14
Bug fix for vertices/status codes with HepMC2/3 event format
2021-04-08
Correct Lorentz statistics for UFO model with Majorana fermions
2021-04-06
Bug fix for rare script failure in system_dependencies.f90.in
Kappa factor for quartic Higgs coupling in SM_ac(_CKM) model
2021-04-04
Support for UFO extensions in SMEFTSim 3.0
2021-02-25
Enable VAMP and VAMP2 channel equivalences for NLO integrations
2021-02-04
Bug fix if user does not set a prefix at configuration
2020-12-10
Generalize NLO calculations to non-CMS lab frames
2020-12-08
Bug fix in expanded p-wave form factor for top threshold
2020-12-06
Patch for macOS Big Sur shared library handling due to libtool;
the patch also demands gcc/gfortran 11.0/10.3/9.4/8.5
2020-12-04
O'Mega only inserts non-vanishing couplings from UFO models
2020-11-21
Bug fix for fractional hypercharges in UFO models
2020-11-11
Enable PYTHIA6 settings for eh collisions (enable-pythia6_eh)
2020-11-09
Correct flavor assignment for NLO fixed-order events
2020-11-05
Bug fix for ISR handler not working with unstable particles
2020-10-08
Bug fix in LHAPDF interface for photon PDFs
2020-10-07
Bug fix for structure function setup with asymmetric beams
2020-10-02
Python/Cython layer for WHIZARD API
2020-09-30
Allow mismatches of Python and name attributes in UFO models
2020-09-26
Support for negative PDG particles from certain UFO models
2020-09-24
Allow for QNUMBERS blocks in BSM SLHA files
2020-09-22
Full support for compilation with clang(++) on Darwin/macOS
More documentation in the manual
Minor clean-ups
2020-09-16
Bug fix enables reading LCIO events with LCIO v2.15+
##################################################################
2020-09-16
RELEASE: version 2.8.5
2020-09-11
Bug fix for H->tau tau transverse polarization with PYTHIA6
(thanks to Junping Tian / Akiya Miyamoto)
2020-09-09
Fix a long standing bug (since 2.0) in the calculation of color
factors when particles of different color were combined in a
particle class. NB: O'Mega never produced a wrong number,
it only declared all processes as invalid.
2020-09-08
Enable Openloops matrix element equivalences for optimization
2020-09-02
Compatibility fix for PYTHIA v8.301+ interface
2020-09-01
Support exclusive jet clustering in ee for Fastjet interface
##################################################################
2020-08-30
RELEASE: version 3.0.0_beta
2020-08-27
Major revision of NLO distributions and events for
processes with structure functions:
- Use parton momenta/flavors (instead of beams) for events
- Bug fix for Lorentz boosts and Lorentz frames of momenta
- Bug fix: apply cuts to virtual NLO component in correct frame
- Correctly assign ISR radiation momenta in data structures
- Refactoring on quantum numbers for NLO event data structures
- Functional tests for hadron collider NLO distributions
- many minor bug fixes regarding NLO hadron collider physics
2020-08-11
Bug fix for linking problem with OpenMPI
2020-08-07
New WHIZARD API: WHIZARD can be externally linked as a
library, added examples for Fortran, C, C++ programs
##################################################################
2020-07-08
RELEASE: version 2.8.4
2020-07-07
Bug fix: steering of UFO Majorana models from WHIZARD
##################################################################
2020-07-06
Combined integration also for hadron collider processes at NLO
2020-07-05
Bug fix: correctly steer e+e- FastJet clustering algorithms
Major revision of NLO differential distributions and events:
- Correctly assign quantum numbers to NLO fixed-order events
- Correctly assign weights to NLO fixed-order events for
combined simulation
- Cut all NLO fixed-order subevents in event groups individually
- Only allow "sigma" normalization for NLO fixed-order events
- Use correct PDF setup for NLO counter events
- Several technical fixes and updates of the NLO testsuite
##################################################################
2020-07-03
RELEASE: version 2.8.3
2020-07-02
Feature-complete UFO implementation for Majorana fermions
2020-06-22
Running width scheme supported for O'Mega matrix elements
2020-06-20
Adding H-s-s coupling to SM_Higgs(_CKM) models
2020-06-17
Completion of ILC 2->6 fermion extended test suite
2020-06-15
Bug fix: PYTHIA6/Tauola, correctly assign tau spins for stau decays
2020-06-09
Bug fix: correctly update calls for additional VAMP/2 iterations
Bug fix: correct assignment for tau spins from PYTHIA6 interface
2020-06-04
Bug fix: cascades2 tree merge with empty subtree(s)
2020-05-31
Switch $epa_mode for different EPA implementations
2020-05-26
Bug fix: spin information transferred for resonance histories
2020-04-13
HepMC: correct weighted events for non-xsec event normalizations
2020-04-04
Improved HepMC3 interface: HepMC3 Root/RootTree interface
2020-03-24
ISR: Fix on-shell kinematics for events with ?isr_handler=true
(set ?isr_handler_keep_mass=false for old behavior)
2020-03-11
Beam masses are correctly passed to hard matrix element for CIRCE2
EPA with polarized beams: double-counting corrected
##################################################################
2020-03-03
RELEASE: version 3.0.0_alpha
2020-02-25
Bug fix: Scale and alphas can be retrieved from internal event format to
external formats
2020-02-17
Bug fix: ?keep_failed_events now forces output of actual event data
Bug fix: particle-set reconstruction (rescanning events w/o radiation)
2020-01-28
Bug fix for left-over EPA parameter epa_e_max (replaced by epa_q_max)
2020-01-23
Bug fix for real components of NLO QCD 2->1 processes
2020-01-22
Bug fix: correct random number sequencing during parallel MPI event
generation with rng_stream
2020-01-21
Consistent distribution of events during parallel MPI event generation
2020-01-20
Bug fix for configure setup for automake v1.16+
2020-01-18
General SLHA parameter files for UFO models supported
2020-01-08
Bug fix: correctly register RECOLA processes with flavor sums
2019-12-19
Support for UFO customized propagators
O'Mega unit tests for fermion-number violating interactions
2019-12-10
For distribution building: check for graphviz/dot
version 2.40 or newer
2019-11-21
Bug fix: alternate setups now work correctly
Infrastructure for accessing alpha_QED event-by-event
Guard against tiny numbers that break ASCII event output
Enable inverse hyperbolic functions as SINDARIN observables
Remove old compiler bug workarounds
2019-11-20
Allow quoted -e argument, implemented -f option
2019-11-19
Bug fix: resonance histories now work also with UFO models
Fix in numerical precision of ASCII VAMP2 grids
2019-11-06
Add squared matrix elements to the LCIO event header
2019-11-05
Do not include RNG state in MD5 sum for CIRCE1/2
2019-11-04
Full CIRCE2 ILC 250 and 500 GeV beam spectra added
Minor update on LCIO event header information
2019-10-30
NLO QCD for final states completed
When using Openloops, v2.1.1+ mandatory
2019-10-25
Binary grid files for VAMP2 integrator
##################################################################
2019-10-24
RELEASE: version 2.8.2
2019-10-20
Bug fix for HepMC linker flags
2019-10-19
Support for spin-2 particles from UFO files
2019-09-27
LCIO event format allows rescan and alternate weights
2019-09-24
Compatibility fix for OCaml v4.08.0+
##################################################################
2019-09-21
RELEASE: version 2.8.1
2019-09-19
Carriage return characters in UFO models can be parsed
Mathematica symbols in UFO models possible
Unused/undefined parameters in UFO models handled
2019-09-13
New extended NLO test suite for ee and pp processes
2019-09-09
Photon isolation (separation of perturbative and fragmentation
part a la Frixione)
2019-09-05
Major progress on NLO QCD for hadron collisions:
- correctly assign flavor structures for alpha regions
- fix crossing of particles for initial state splittings
- correct assignment for PDF factors for real subtractions
- fix kinematics for collinear splittings
- bug fix for integrated virtual subtraction terms
2019-09-03
b and c jet selection in cuts and analysis
2019-08-27
Support for Intel MPI
2019-08-20
Complete (preliminary) HepMC3 support (incl.
backwards HepMC2 write/read mode)
2019-08-08
Bug fix: handle carriage returns in UFO files (non-Unix OS)
##################################################################
2019-08-07
RELEASE: version 2.8.0
2019-07-31
Complete WHIZARD UFO interface:
- general Lorentz structures
- matrix element support for general color factors
- missing features: Majorana fermions and SLHA
2019-07-20
Make WHIZARD compatible with OCaml 4.08.0+
2019-07-19
Fix version testing for LHAPDF 6.2.3 and newer
Minimal required OCaml version is now 4.02.3.
2019-04-18
Correctly generate ordered FKS tuples for alpha regions
from all possible underlying Born processes
2019-04-08
Extended O'Mega/Recola matrix element test suite
2019-03-29
Correct identical particle symmetry factors for FKS subtraction
2019-03-28
Correct assertion of spin-correlated matrix
elements for hadron collisions
2019-03-27
Bug fix for cut-off parameter delta_i for
collinear plus/minus regions
##################################################################
2019-03-27
RELEASE: version 2.7.1
2019-02-19
Further infrastructure for HepMC3 interface (v3.01.00)
2019-02-07
Explicit configure option for using debugging options
Bug fix for performance by removing unnecessary debug operations
2019-01-29
Bug fix for DGLAP remnants with cut-off parameter delta_i
2019-01-24
Radiative decay neu2 -> neu1 A added to MSSM_Hgg model
##################################################################
2019-01-21
RELEASE: version 2.7.0
2018-12-18
Support RECOLA for integrated und unintegrated subtractions
2018-12-11
FCNC top-up sector in model SM_top_anom
2018-12-05
Use libtirpc instead of SunRPC on Arch Linux etc.
2018-11-30
Display rescaling factor for weighted event samples with cuts
2018-11-29
Reintroduce check against different masses in flavor sums
Bug fix for wrong couplings in the Littlest Higgs model(s)
2018-11-22
Bug fix for rescanning events with beam structure
2018-11-09
Major refactoring of internal process data
2018-11-02
PYTHIA8 interface
2018-10-29
Flat phase space parametrization with RAMBO (on diet) implemented
2018-10-17
Revise extended test suite
2018-09-27
Process container for RECOLA processes
2018-09-15
Fixes by M. Berggren for PYTHIA6 interface
2018-09-14
First fixes after HepForge modernization
##################################################################
2018-08-23
RELEASE: version 2.6.4
2018-08-09
Infrastructure to check colored subevents
2018-07-10
Infrastructure for running WHIZARD in batch mode
2018-07-04
MPI available from distribution tarball
2018-06-03
Support Intel Fortran Compiler under MAC OS X
2018-05-07
FKS slicing parameter delta_i (initial state) implementend
2018-05-03
Refactor structure function assignment for NLO
2018-05-02
FKS slicing parameter xi_cut, delta_0 implemented
2018-04-20
Workspace subdirectory for process integration (grid/phs files)
Packing/unpacking of files at job end/start
Exporting integration results from scan loops
2018-04-13
Extended QCD NLO test suite
2018-04-09
Bug fix for Higgs Singlet Extension model
2018-04-06
Workspace subdirectory for process generation and compilation
--job-id option for creating job-specific names
2018-03-20
Bug fix for color flow matching in hadron collisions
with identical initial state quarks
2018-03-08
Structure functions quantum numbers correctly assigned for NLO
2018-02-24
Configure setup includes 'pgfortran' and 'flang'
2018-02-21
Include spin-correlated matrix elements in interactions
2018-02-15
Separate module for QED ISR structure functions
##################################################################
2018-02-10
RELEASE: version 2.6.3
2018-02-08
Improvements in memory management for PS generation
2018-01-31
Partial refactoring: quantum number assigment NLO
Initial-state QCD splittings for hadron collisions
2018-01-25
Bug fix for weighted events with VAMP2
2018-01-17
Generalized interface for Recola versions 1.3+ and 2.1+
2018-01-15
Channel equivalences also for VAMP2 integrator
2018-01-12
Fix for OCaml compiler 4.06 (and newer)
2017-12-19
RECOLA matrix elements with flavor sums can be integrated
2017-12-18
Bug fix for segmentation fault in empty resonance histories
2017-12-16
Fixing a bug in PYTHIA6 PYHEPC routine by omitting CMShowers
from transferral between PYTHIA and WHIZARD event records
2017-12-15
Event index for multiple processes in event file correct
##################################################################
2017-12-13
RELEASE: version 2.6.2
2017-12-07
User can set offset in event numbers
2017-11-29
Possibility to have more than one RECOLA process in one file
2017-11-23
Transversal/mixed (and unitarized) dim-8 operators
2017-11-16
epa_q_max replaces epa_e_max (trivial factor 2)
2017-11-15
O'Mega matrix element compilation silent now
2017-11-14
Complete expanded P-wave form factor for top threshold
2017-11-10
Incoming particles can be accessed in SINDARIN
2017-11-08
Improved handling of resonance insertion, additional parameters
2017-11-04
Added Higgs-electron coupling (SM_Higgs)
##################################################################
2017-11-03
RELEASE: version 2.6.1
2017-10-20
More than 5 NLO components possible at same time
2017-10-19
Gaussian cutoff for shower resonance matching
2017-10-12
Alternative (more efficient) method to generate
phase space file
2017-10-11
Bug fix for shower resonance histories for processes
with multiple components
2017-09-25
Bug fix for process libraries in shower resonance histories
2017-09-21
Correctly generate pT distribution for EPA remnants
2017-09-20
Set branching ratios for unstable particles also by hand
2017-09-14
Correctly generate pT distribution for ISR photons
##################################################################
2017-09-08
RELEASE: version 2.6.0
2017-09-05
Bug fix for initial state NLO QCD flavor structures
Real and virtual NLO QCD hadron collider processes
work with internal interactions
2017-09-04
Fully validated MPI integration and event generation
2017-09-01
Resonance histories for shower: full support
Bug fix in O'Mega model constraints
O'Mega allows to output a parsable form of the DAG
2017-08-24
Resonance histories in events for transferral
to parton shower (e.g. in ee -> jjjj)
2017-08-01
Alpha version of HepMC v3 interface
(not yet really functional)
2017-07-31
Beta version for RECOLA OLP support
2017-07-06
Radiation generator fix for LHC processes
2017-06-30
Fix bug for NLO with structure
functions and/or polarization
2017-06-23
Collinear limit for QED corrections works
2017-06-17
POWHEG grids generated already during integration
2017-06-12
Soft limit for QED corrections works
2017-05-16
Beta version of full MPI parallelization (VAMP2)
Check consistency of POWHEG grid files
Logfile config-summary.log for configure summary
2017-05-12
Allow polarization in top threshold
2017-05-09
Minimal demand automake 1.12.2
Silent rules for make procedures
2017-05-07
Major fix for POWHEG damping
Correctly initialize FKS ISR phasespace
##################################################################
2017-05-06
RELEASE: version 2.5.0
2017-05-05
Full UFO support (SM-like models)
Fixed-beam ISR FKS phase space
2017-04-26
QED splittings in radiation generator
2017-04-10
Retire deprecated O'Mega vertex cache files
##################################################################
2017-03-24
RELEASE: version 2.4.1
2017-03-16
Distinguish resonance charge in phase space channels
Keep track of resonance histories in phase space
Complex mass scheme default for OpenLoops amplitudes
2017-03-13
Fix helicities for polarized OpenLoops calculations
2017-03-09
Possibility to advance RNG state in rng_stream
2017-03-04
General setup for partitioning real emission
phase space
2017-03-06
Bug fix on rescan command for converting event files
2017-02-27
Alternative multi-channel VEGAS implementation
VAMP2: serial backbone for MPI setup
Smoothstep top threshold matching
2017-02-25
Single-beam structure function with
s-channel mapping supported
Safeguard against invalid process libraries
2017-02-16
Radiation generator for photon emission
2017-02-10
Fixes for NLO QCD processes (color correlations)
2017-01-16
LCIO variable takes precedence over LCIO_DIR
2017-01-13
Alternative random number generator
rng_stream (cf. L'Ecuyer et al.)
2017-01-01
Fix for multi-flavor BLHA tree
matrix elements
2016-12-31
Grid path option for VAMP grids
2016-12-28
Alpha version of Recola OLP support
2016-12-27
Dalitz plots for FKS phase space
2016-12-14
NLO multi-flavor events possible
2016-12-09
LCIO event header information added
2016-12-02
Alpha version of RECOLA interface
Bug fix for generator status in LCIO
##################################################################
2016-11-28
RELEASE: version 2.4.0
2016-11-24
Bug fix for OpenLoops interface: EW scheme
is set by WHIZARD
Bug fixes for top threshold implementation
2016-11-11
Refactoring of dispatching
2016-10-18
Bug fix for LCIO output
2016-10-10
First implementation for collinear soft terms
2016-10-06
First full WHIZARD models from UFO files
2016-10-05
WHIZARD does not support legacy gcc 4.7.4 any longer
2016-09-30
Major refactoring of process core and NLO components
2016-09-23
WHIZARD homogeneous entity: discarding subconfigures
for CIRCE1/2, O'Mega, VAMP subpackages; these are
reconstructable by script projectors
2016-09-06
Introduce main configure summary
2016-08-26
Fix memory leak in event generation
##################################################################
2016-08-25
RELEASE: version 2.3.1
2016-08-19
Bug fix for EW-scheme dependence of gluino propagators
2016-08-01
Beta version of complex mass scheme support
2016-07-26
Fix bug in POWHEG damping for the matching
##################################################################
2016-07-21
RELEASE: version 2.3.0
2016-07-20
UFO file support (alpha version) in O'Mega
2016-07-13
New (more) stable of WHIZARD GUI
Support for EW schemes for OpenLoops
Factorized NLO top decays for threshold model
2016-06-15
Passing factorization scale to PYTHIA6
Adding charge and neutral observables
2016-06-14
Correcting angular distribution/tweaked kinematics in
non-collinear structure functions splittings
2016-05-10
Include (Fortran) TAUOLA/PHOTOS for tau decays via PYTHIA6
(backwards validation of LC CDR/TDR samples)
2016-04-27
Within OpenLoops virtuals: support for Collier library
2016-04-25
O'Mega vertex tables only loaded at first usage
2016-04-21
New CJ15 PDF parameterizations added
2016-04-21
Support for hadron collisions at NLO QCD
2016-04-05
Support for different (parameter) schemes in model files
2016-03-31
Correct transferral of lifetime/vertex from PYTHIA/TAUOLA
into the event record
2016-03-21
New internal implementation of polarization
via Bloch vectors, remove pointer constructions
2016-03-13
Extension of cascade syntax for processes:
exclude propagators/vertices etc. possible
2016-02-24
Full support for OpenLoops QCD NLO matrix
elements, inclusion in test suite
2016-02-12
Substantial progress on QCD NLO support
2016-02-02
Automated resonance mapping for FKS subtraction
2015-12-17
New BSM model WZW for diphoton resonances
##################################################################
2015-11-22
RELEASE: version 2.2.8
2015-11-21
Bug fix for fixed-order NLO events
2015-11-20
Anomalous FCNC top-charm vertices
2015-11-19
StdHEP output via HEPEVT/HEPEV4 supported
2015-11-18
Full set of electroweak dim-6 operators included
2015-10-22
Polarized one-loop amplitudes supported
2015-10-21
Fixes for event formats for showered events
2015-10-14
Callback mechanism for event output
2015-09-22
Bypass matrix elements in pure event sample rescans
StdHep frozen final version v5.06.01 included internally
2015-09-21
configure option --with-precision to
demand 64bit, 80bit, or 128bit Fortran
and bind C precision types
2015-09-07
More extensive tests of NLO
infrastructure and POWHEG matching
2015-09-01
NLO decay infrastructure
User-defined squared matrix elements
Inclusive FastJet algorithm plugin
Numerical improvement for small boosts
##################################################################
2015-08-11
RELEASE: version 2.2.7
2015-08-10
Infrastructure for damped POWHEG
Massive emitters in POWHEG
Born matrix elements via BLHA
GoSam filters via SINDARIN
Minor running coupling bug fixes
Fixed-order NLO events
2015-08-06
CT14 PDFs included (LO, NLO, NNLL)
2015-07-07
Revalidation of ILC WHIZARD-PYTHIA event chain
Extended test suite for showered events
Alpha version of massive FSR for POWHEG
2015-06-09
Fix memory leak in interaction for long cascades
Catch mismatch between beam definition and CIRCE2 spectrum
2015-06-08
Automated POWHEG matching: beta version
Infrastructure for GKS matching
Alpha version of fixed-order NLO events
CIRCE2 polarization averaged spectra with
explicitly polarized beams
2015-05-12
Abstract matching type: OO structure for matching/merging
2015-05-07
Bug fix in event record WHIZARD-PYTHIA6 transferral
Gaussian beam spectra for lepton colliders
##################################################################
2015-05-02
RELEASE: version 2.2.6
2015-05-01
Models for (unitarized) tensor resonances in VBS
2015-04-28
Bug fix in channel weights for event generation.
2015-04-18
Improved event record transfer WHIZARD/PYTHIA6
2015-03-19
POWHEG matching: alpha version
##################################################################
2015-02-27
RELEASE: version 2.2.5
2015-02-26
Abstract types for quantum numbers
2015-02-25
Read-in of StdHEP events, self-tests
2015-02-22
Bug fix for mother-daughter relations in
showered/hadronized events
2015-02-20
Projection on polarization in intermediate states
2015-02-13
Correct treatment of beam remnants in
event formats (also LC remnants)
##################################################################
2015-02-06
RELEASE: version 2.2.4
2015-02-06
Bug fix in event output
2015-02-05
LCIO event format supported
2015-01-30
Including state matrices in WHIZARD's internal IO
Versioning for WHIZARD's internal IO
Libtool update from 2.4.3 to 2.4.5
LCIO event output (beta version)
2015-01-27
Progress on NLO integration
Fixing a bug for multiple processes in a single
event file when using beam event files
2015-01-19
Bug fix for spin correlations evaluated in the rest
frame of the mother particle
2015-01-17
Regression fix for statically linked processes
from SARAH and FeynRules
2015-01-10
NLO: massive FKS emitters supported (experimental)
2015-01-06
MMHT2014 PDF sets included
2015-01-05
Handling mass degeneracies in auto_decays
2014-12-19
Fixing bug in rescan of event files
##################################################################
2014-11-30
RELEASE: version 2.2.3
2014-11-29
Beta version of LO continuum/NLL-threshold
matched top threshold model for e+e- physics
2014-11-28
More internal refactoring: disentanglement of module
dependencies
2014-11-21
OVM: O'Mega Virtual Machine, bytecode instructions
instead of compiled Fortran code
2014-11-01
Higgs Singlet extension model included
2014-10-18
Internal restructuring of code; half-way
WHIZARD main code file disassembled
2014-07-09
Alpha version of NLO infrastructure
##################################################################
2014-07-06
RELEASE: version 2.2.2
2014-07-05
CIRCE2: correlated LC beam spectra and
GuineaPig Interface to LC machine parameters
2014-07-01
Reading LHEF for decayed/factorized/showered/
hadronized events
2014-06-25
Configure support for GoSAM/Ninja/Form/QGraf
2014-06-22
LHAPDF6 interface
2014-06-18
Module for automatic generation of
radiation and loop infrastructure code
2014-06-11
Improved internal directory structure
##################################################################
2014-06-03
RELEASE: version 2.2.1
2014-05-30
Extensions of internal PDG arrays
2014-05-26
FastJet interface
2014-05-24
CJ12 PDFs included
2014-05-20
Regression fix for external models (via SARAH
or FeynRules)
##################################################################
2014-05-18
RELEASE: version 2.2.0
2014-04-11
Multiple components: inclusive process definitions,
syntax: process A + B + ...
2014-03-13
Improved PS mappings for e+e- ISR
ILC TDR and CLIC spectra included in CIRCE1
2014-02-23
New models: AltH w\ Higgs for exclusion purposes,
SM_rx for Dim 6-/Dim-8 operators, SSC for
general strong interactions (w/ Higgs), and
NoH_rx (w\ Higgs)
2014-02-14
Improved s-channel mapping, new on-shell
production mapping (e.g. Drell-Yan)
2014-02-03
PRE-RELEASE: version 2.2.0_beta
2014-01-26
O'Mega: Feynman diagram generation possible (again)
2013-12-16
HOPPET interface for b parton matching
2013-11-15
PRE-RELEASE: version 2.2.0_alpha-4
2013-10-27
LHEF standards 1.0/2.0/3.0 implemented
2013-10-15
PRE-RELEASE: version 2.2.0_alpha-3
2013-10-02
PRE-RELEASE: version 2.2.0_alpha-2
2013-09-25
PRE-RELEASE: version 2.2.0_alpha-1
2013-09-12
PRE-RELEASE: version 2.2.0_alpha
2013-09-03
General 2HDM implemented
2013-08-18
Rescanning/recalculating events
2013-06-07
Reconstruction of complete event
from 4-momenta possible
2013-05-06
Process library stacks
2013-05-02
Process stacks
2013-04-29
Single-particle phase space module
2013-04-26
Abstract interface for random
number generator
2013-04-24
More object-orientation on modules
Midpoint-rule integrator
2013-04-05
Object-oriented integration and
event generation
2013-03-12
Processes recasted object-oriented:
MEs, scales, structure functions
First infrastructure for general Lorentz
structures
2013-01-17
Object-orientated reworking of library and
process core, more variable internal structure,
unit tests
2012-12-14
Update Pythia version to 6.4.27
2012-12-04
Fix the phase in HAZ vertices
2012-11-21
First O'Mega unit tests, some infrastructure
2012-11-13
Bug fix in anom. HVV Lorentz structures
##################################################################
2012-09-18
RELEASE: version 2.1.1
2012-09-11
Model MSSM_Hgg with Hgg and HAA vertices
2012-09-10
First version of implementation of multiple
interactions in WHIZARD
2012-09-05
Infrastructure for internal CKKW matching
2012-09-02
C, C++, Python API
2012-07-19
Fixing particle numbering in HepMC format
##################################################################
2012-06-15
RELEASE: version 2.1.0
2012-06-14
Analytical and kT-ordered shower officially
released
PYTHIA interface officially released
2012-05-09
Intrisince PDFs can be used for showering
2012-05-04
Anomalous Higgs couplings a la hep-ph/9902321
##################################################################
2012-03-19
RELEASE: version 2.0.7
2012-03-15
Run IDs are available now
More event variables in analysis
Modified raw event format (compatibility mode exists)
2012-03-12
Bug fix in decay-integration order
MLM matching steered completely internally now
2012-03-09
Special phase space mapping for narrow resonances
decaying to 4-particle final states with far off-shell
intermediate states
Running alphas from PDF collaborations with
builtin PDFs
2012-02-16
Bug fix in cascades decay infrastructure
2012-02-04
WHIZARD documentation compatible with TeXLive 2011
2012-02-01
Bug fix in FeynRules interface with --prefix flag
2012-01-29
Bug fix with name clash of O'Mega variable names
2012-01-27
Update internal PYTHIA to version 6.4.26
Bug fix in LHEF output
2012-01-21
Catching stricter automake 1.11.2 rules
2011-12-23
Bug fix in decay cascade setup
2011-12-20
Bug fix in helicity selection rules
2011-12-16
Accuracy goal reimplemented
2011-12-14
WHIZARD compatible with TeXLive 2011
2011-12-09
Option --user-target added
##################################################################
2011-12-07
RELEASE: version 2.0.6
2011-12-07
Bug fixes in SM_top_anom
Added missing entries to HepMC format
2011-12-06
Allow to pass options to O'Mega
Bug fix for HEPEVT block for showered/hadronized events
2011-12-01
Reenabled user plug-in for external code for
cuts, structure functions, routines etc.
2011-11-29
Changed model SM_Higgs for Higgs phenomenology
2011-11-25
Supporting a Y, (B-L) Z' model
2011-11-23
Make WHIZARD compatible for MAC OS X Lion/XCode 4
2011-09-25
WHIZARD paper published: Eur.Phys.J. C71 (2011) 1742
2011-08-16
Model SM_QCD: QCD with one EW insertion
2011-07-19
Explicit output channel for dvips avoids printing
2011-07-10
Test suite for WHIZARD unit tests
2011-07-01
Commands for matrix element tests
More OpenMP parallelization of kinematics
Added unit tests
2011-06-23
Conversion of CIRCE2 from F77 to F90, major
clean-up
2011-06-14
Conversion of CIRCE1 from F77 to F90
2011-06-10
OpenMP parallelization of channel kinematics
(by Matthias Trudewind)
2011-05-31
RELEASE: version 1.97
2011-05-24
Minor bug fixes: update grids and elsif statement.
##################################################################
2011-05-10
RELEASE: version 2.0.5
2011-05-09
Fixed bug in final state flavor sums
Minor improvements on phase-space setup
2011-05-05
Minor bug fixes
2011-04-15
WHIZARD as a precompiled 64-bit binary available
2011-04-06
Wall clock instead of cpu time for time estimates
2011-04-05
Major improvement on the phase space setup
2011-04-02
OpenMP parallelization for helicity loop in O'Mega
matrix elements
2011-03-31
Tools for relocating WHIZARD and use in batch
environments
2011-03-29
Completely static builds possible, profiling options
2011-03-28
Visualization of integration history
2011-03-27
Fixed broken K-matrix implementation
2011-03-23
Including the GAMELAN manual in the distribution
2011-01-26
WHIZARD analysis can handle hadronized event files
2011-01-17
MSTW2008 and CT10 PDF sets included
2010-12-23
Inclusion of NMSSM with Hgg couplings
2010-12-21
Advanced options for integration passes
2010-11-16
WHIZARD supports CTEQ6 and possibly other PDFs
directly; data files included in the distribution
##################################################################
2010-10-26
RELEASE: version 2.0.4
2010-10-06
Bug fix in MSSM implementation
2010-10-01
Update to libtool 2.4
2010-09-29
Support for anomalous top couplings (form factors etc.)
Bug fix for running gauge Yukawa SUSY couplings
2010-09-28
RELEASE: version 1.96
2010-09-21
Beam remnants and pT spectra for lepton collider re-enabled
Restructuring subevt class
2010-09-16
Shower and matching are disabled by default
PYTHIA as a conditional on these two options
2010-09-14
Possibility to read in beam spectra re-enabled (e.g. Guinea
Pig)
2010-09-13
Energy scan as (pseudo-) structure functions re-implemented
2010-09-10
CIRCE2 included again in WHIZARD 2 and validated
2010-09-02
Re-implementation of asymmetric beam energies and collision
angles, e-p collisions work, inclusion of a HERA DIS test
case
##################################################################
2010-10-18
RELEASE: version 2.0.3
2010-08-08
Bug in CP-violating anomalous triple TGCs fixed
2010-08-06
Solving backwards compatibility problem with O'Caml 3.12.0
2010-07-12
Conserved quantum numbers speed up O'Mega code generation
2010-07-07
Attaching full ISR/FSR parton shower and MPI/ISR
module
Added SM model containing Hgg, HAA, HAZ vertices
2010-07-02
Matching output available as LHEF and STDHEP
2010-06-30
Various bug fixes, missing files, typos
2010-06-26
CIRCE1 completely re-enabled
Chaining structure functions supported
2010-06-25
Partial support for conserved quantum numbers in
O'Mega
2010-06-21
Major upgrade of the graphics package: error bars,
smarter SINDARIN steering, documentation, and all that...
2010-06-17
MLM matching with PYTHIA shower included
2010-06-16
Added full CIRCE1 and CIRCE2 versions including
full documentation and miscellanea to the trunk
2010-06-12
User file management supported, improved variable
and command structure
2010-05-24
Improved handling of variables in local command lists
2010-05-20
PYTHIA interface re-enabled
2010-05-19
ASCII file formats for interfacing ROOT and gnuplot in
data analysis
##################################################################
2010-05-18
RELEASE: version 2.0.2
2010-05-14
Reimplementation of visualization of phase space
channels
Minor bug fixes
2010-05-12
Improved phase space - elimination of redundancies
2010-05-08
Interface for polarization completed: polarized beams etc.
2010-05-06
Full quantum numbers appear in process log
Integration results are usable as user variables
Communication with external programs
2010-05-05
Split module commands into commands, integration,
simulation modules
2010-05-04
FSR+ISR for the first time connected to the WHIZARD 2 core
##################################################################
2010-04-25
RELEASE: version 2.0.1
2010-04-23
Automatic compile and integrate if simulate is called
Minor bug fixes in O'Mega
2010-04-21
Checkpointing for event generation
Flush statements to use WHIZARD inside a pipe
2010-04-20
Reimplementation of signal handling in WGIZARD 2.0
2010-04-19
VAMP is now a separately configurable and installable unit of
WHIZARD, included VAMP self-checks
Support again compilation in quadruple precision
2010-04-06
Allow for logarithmic plots in GAMELAN, reimplement the
possibility to set the number of bins
2010-04-15
Improvement on time estimates for event generation
##################################################################
2010-04-12
RELEASE: version 2.0.0
2010-04-09
Per default, the code for the amplitudes is subdivided to allow
faster compiler optimization
More advanced and unified and straightforward command language
syntax
Final bug fixes
2010-04-07
Improvement on SINDARIN syntax; printf, sprintf function
thorugh a C interface
2010-04-05
Colorizing DAGs instead of model vertices: speed boost
in colored code generation
2010-03-31
Generalized options for normalization of weighted and
unweighted events
Grid and weight histories added again to log files
Weights can be used in analyses
2010-03-28
Cascade decays completely implemented including color and
spin correlations
2010-03-07
Added new WHIZARD header with logo
2010-03-05
Removed conflict in O'Mega amplitudes between flavour sums
and cascades
StdHEP interface re-implemented
2010-03-03
RELEASE: version 2.0.0rc3
Several bug fixes for preventing abuse in input files
OpenMP support for amplitudes
Reimplementation of WHIZARD 1 HEPEVT ASCII event formats
FeynRules interface successfully passed MSSM test
2010-02-26
Eliminating ghost gluons from multi-gluon amplitudes
2010-02-25
RELEASE: version 1.95
HEPEVT format from WHIZARD 1 re-implemented in WHIZARD 2
2010-02-23
Running alpha_s implemented in the FeynRules interface
2010-02-19
MSSM (semi-) automatized self-tests finalized
2010-02-17
RELEASE: version 1.94
2010-02-16
Closed memory corruption in WHIZARD 1
Fixed problems of old MadGraph and CompHep drivers
with modern compilers
Uncolored vertex selection rules for colored amplitudes in
O'Mega
2010-02-15
Infrastructure for color correlation computation in O'Mega
finished
Forbidden processes are warned about, but treated as non-fatal
2010-02-14
Color correlation computation in O'Mega finalized
2010-02-10
Improving phase space mappings for identical particles in
initial and final states
Introduction of more extended multi-line error message
2010-02-08
First O'Caml code for computation of color correlations in
O'Mega
2010-02-07
First MLM matching with e+ e- -> jets
##################################################################
2010-02-06
RELEASE: version 2.0.0rc2
2010-02-05
Reconsidered the Makefile structure and more extended tests
Catch a crash between WHIZARD and O'Mega for forbidden processes
Tensor products of arbitrary color structures in jet definitions
2010-02-04
Color correlation computation in O'Mega finalized
##################################################################
2010-02-03
RELEASE: version 2.0.0rc1
##################################################################
2010-01-31
Reimplemented numerical helicity selection rules
Phase space functionality of version 1 restored and improved
2009-12-05
NMSSM validated with FeynRules in WHIZARD 1 (Felix Braam)
2009-12-04
RELEASE: version 2.0.0alpha
##################################################################
2009-04-16
RELEASE: version 1.93
2009-04-15
Clean-up of Makefiles and configure scripts
Reconfiguration of BSM model implementation
extended supersymmetric models
2008-12-23
New model NMSSM (Felix Braam)
SLHA2 added
Bug in LHAPDF interface fixed
2008-08-16
Bug fixed in K matrix implementation
Gravitino option in the MSSM added
2008-03-20
Improved color and flavor sums
##################################################################
2008-03-12
RELEASE: version 1.92
LHEF (Les Houches Event File) format added
Fortran 2003 command-line interface (if supported by the compiler)
Automated interface to colored models
More bug fixes and workarounds for compiler compatibility
##################################################################
2008-03-06
RELEASE: version 1.91
New model K-matrix (resonances and anom. couplings in WW scattering)
EWA spectrum
Energy-scan pseudo spectrum
Preliminary parton shower module (only from final-state quarks)
Cleanup and improvements of configure process
Improvements for O'Mega parameter files
Quadruple precision works again
More plotting options: lines, symbols, errors
Documentation with PDF bookmarks enabled
Various bug fixes
2007-11-29
New model UED
##################################################################
2007-11-23
RELEASE: version 1.90
O'Mega now part of the WHIZARD tree
Madgraph/CompHEP disabled by default (but still usable)
Support for LHAPDF (preliminary)
Added new models: SMZprime, SM_km, Template
Improved compiler recognition and compatibility
Minor bug fixes
##################################################################
2006-06-15
RELEASE: version 1.51
Support for anomaly-type Higgs couplings (to gluon and photon/Z)
Support for spin 3/2 and spin 2
New models: Little Higgs (4 versions), toy models for extra dimensions
and gravitinos
Fixes to the whizard.nw source documentation to run through LaTeX
Intel 9.0 bug workaround (deallocation of some arrays)
2006-05-15
O'Mega RELEASE: version 0.11
merged JRR's O'Mega extensions
##################################################################
2006-02-07
RELEASE: version 1.50
To avoid confusion: Mention outdated manual example in BUGS file
O'Mega becomes part of the WHIZARD generator
2006-02-02 [bug fix update]
Bug fix: spurious error when writing event files for weighted events
Bug fix: 'r' option for omega produced garbage for some particle names
Workaround for ifort90 bug (crash when compiling whizard_event)
Workaround for ifort90 bug (crash when compiling hepevt_common)
2006-01-27
Added process definition files for MSSM 2->2 processes
Included beam recoil for EPA (T.Barklow)
Updated STDHEP byte counts (for STDHEP 5.04.02)
Fixed STDHEP compatibility (avoid linking of incomplete .so libs)
Fixed issue with comphep requiring Xlibs on Opteron
Fixed issue with ifort 8.x on Opteron (compiling 'signal' interface)
Fixed color-flow code: was broken for omega with option 'c' and 'w'
Workaround hacks for g95 compatibility
2005-11-07
O'Mega RELEASE: version 0.10
O'Mega, merged JRR's and WK's color hack for WHiZard
O'Mega, EXPERIMENTAL: cache fusion tables (required for colors
a la JRR/WK)
O'Mega, make JRR's MSSM official
##################################################################
2005-10-25
RELEASE: version 1.43
Minor fixes in MSSM couplings (Higgs/3rd gen squarks).
This should be final, since the MSSM results agree now completely
with Madgraph and Sherpa
User-defined lower and upper limits for split event file count
Allow for counters (events, bytes) exceeding $2^{31}$
Revised checksum treatment and implementation (now MD5)
Bug fix: missing process energy scale in raw event file
##################################################################
2005-09-30
RELEASE: version 1.42
Graphical display of integration history ('make history')
Allow for switching off signals even if supported (configure option)
2005-09-29
Revised phase space generation code, in particular for flavor sums
Negative cut and histogram codes use initial beams instead of
initial parton momenta. This allows for computing, e.g., E_miss
Support constant-width and zero-width options for O'Mega
Width options now denoted by w:X (X=f,c,z). f option obsolescent
Bug fix: colorized code: flipped indices could screw up result
Bug fix: O'Mega with 'c' and 'w:f' option together (still some problem)
Bug fix: dvips on systems where dvips defaults to lpr
Bug fix: integer overflow if too many events are requested
2005-07-29
Allow for 2 -> 1 processes (if structure functions are on)
2005-07-26
Fixed and expanded the 'test' matrix element:
Unit matrix element with option 'u' / default: normalized phase space
##################################################################
2005-07-15
RELEASE: version 1.41
Bug fix: no result for particle decay processes with width=0
Bug fix: line breaks in O'Mega files with color decomposition
2005-06-02
New self-tests (make test-QED / test-QCD / test-SM)
check lists of 2->2 processes
Bug fix: HELAS calling convention for wwwwxx and jwwwxx (4W-Vertex)
2005-05-25
Revised Makefile structure
Eliminated obsolete references to ISAJET/SUSY (superseded by SLHA)
2005-05-19
Support for color in O'Mega (using color flow decomposition)
New model QCD
Parameter file changes that correspond to replaced SM module in O'Mega
Bug fixes in MSSM (O'Mega) parameter file
2005-05-18
New event file formats, useful for LHC applications:
ATHENA and Les Houches Accord (external fragmentation)
Naive (i.e., leading 1/N) color factor now implemented both for
incoming and outgoing partons
2005-01-26
include missing HELAS files for bundle
pgf90 compatibility issues [note: still internal error in pgf90]
##################################################################
2004-12-13
RELEASE: version 1.40
compatibility fix: preprocessor marks in helas code now commented out
minor bug fix: format string in madgraph source
2004-12-03
support for arbitray beam energies and directions
allow for pT kick in structure functions
bug fix: rounding error could result in zero cross section
(compiler-dependent)
2004-10-07
simulate decay processes
list fraction (of total width/cross section) instead of efficiency
in process summary
new cut/analysis parameters AA, AAD, CTA: absolute polar angle
2004-10-04
Replaced Madgraph I by Madgraph II. Main improvement: model no
longer hardcoded
introduced parameter reset_seed_each_process (useful for debugging)
bug fix: color initialization for some processes was undefined
2004-09-21
don't compile unix_args module if it is not required
##################################################################
2004-09-20
RELEASE: version 1.30
g95 compatibility issues resolved
some (irrelevant) memory leaks closed
removed obsolete warning in circe1
manual update (essentially) finished
2004-08-03
O'Mega RELEASE: version 0.9
O'Mega, src/trie.mli, src/trie.ml: make interface compatible with
the O'Caml 3.08 library (remains compatible with older
versions). Implementation of unused functions still
incomplete.
2004-07-26
minor fixes and improvements in make process
2004-06-29
workarounds for new Intel compiler bugs ...
no rebuild of madgraph/comphep executables after 'make clean'
bug fix in phase space routine:
wrong energy for massive initial particles
bug fix in (new) model interface: name checks for antiparticles
pre-run checks for comphep improved
ww-strong model file extended
Model files particle name fixes, chep SM vertices included
2004-06-22
O'Mega RELEASE: version 0.8
O'Mega MSSM: sign of W+/W-/A and W+/W-/Z couplings
2004-05-05
Fixed bug in PDFLIB interface: p+pbar was initialized as p+p (ThO)
NAG compiler: set number of continuation lines to 200 as default
Extended format for cross section summary; appears now in whizard.out
Fixed 'bundle' feature
2004-04-28
Fixed compatibility with revised O'Mega SM_ac model
Fixed problem with x=0 or x=1 when calling PDFLIB (ThO)
Fixed bug in comphep module: Vtb was overlooked
##################################################################
2004-04-15
RELEASE: version 1.28
Fixed bug: Color factor was missing for O'Mega processes with
four quarks and more
Manual partially updated
2004-04-08
Support for grid files in binary format
New default value show_histories=F (reduce output file size)
Revised phase space switches: removed annihilation_lines,
removed s_channel_resonance, changed meaning of
extra_off_shell_lines, added show_deleted_channels
Bug fixed which lead to omission of some phase space channels
Color flow guessed only if requested by guess_color_flow
2004-03-10
New model interface: Only one model name specified in whizard.prc
All model-dependent files reside in conf/models (modellib removed)
2004-03-03
Support for input/output in SUSY Les Houches Accord format
Split event files if requested
Support for overall time limit
Support for CIRCE and CIRCE2 generator mode
Support for reading beam events from file
2004-02-05
Fixed compiler problems with Intel Fortran 7.1 and 8.0
Support for catching signals
##################################################################
2003-08-06
RELEASE: version 1.27
User-defined PDF libraries as an alternative to the standard PDFLIB
2003-07-23
Revised phase space module: improved mappings for massless particles,
equivalences of phase space channels are exploited
Improved mapping for PDF (hadron colliders)
Madgraph module: increased max number of color flows from 250 to 1000
##################################################################
2003-06-23
RELEASE: version 1.26
CIRCE2 support
Fixed problem with 'TC' integer kind [Intel compiler complained]
2003-05-28
Support for drawing histograms of grids
Bug fixes for MSSM definitions
##################################################################
2003-05-22
RELEASE: version 1.25
Experimental MSSM support with ISAJET interface
Improved capabilities of generating/analyzing weighted events
Optional drawing phase space diagrams using FeynMF
##################################################################
2003-01-31
RELEASE: version 1.24
A few more fixes and workarounds (Intel and Lahey compiler)
2003-01-15
Fixes and workarounds needed for WHIZARD to run with Intel compiler
Command-line option interface for the Lahey compiler
Bug fix: problem with reading whizard.phs
##################################################################
2002-12-10
RELEASE: version 1.23
Command-line options (on some systems)
Allow for initial particles in the event record, ordered:
[beams, initials] - [remnants] - outgoing partons
Support for PYTHIA 6.2: Les Houches external process interface
String pythia_parameters can be up to 1000 characters long
Select color flow states in (internal) analysis
Bug fix in color flow content of raw event files
Support for transversal polarization of fermion beams
Cut codes: PHI now for absolute azimuthal angle, DPHI for distance
'Test' matrix elements optionally respect polarization
User-defined code can be inserted for spectra, structure functions
and fragmentation
Time limits can be specified for adaptation and simulation
User-defined file names and file directory
Initial weights in input file no longer supported
Bug fix in MadGraph (wave function counter could overflow)
Bug fix: Gamelan (graphical analysis) was not built if noweb absent
##################################################################
2002-03-16
RELEASE: version 1.22
Allow for beam remnants in the event record
2002-03-01
Handling of aliases in whizard.prc fixed (aliases are whole tokens)
2002-02-28
Optimized phase space handling routines
(total execution time reduced by 20-60%, depending on process)
##################################################################
2002-02-26
RELEASE: version 1.21
Fixed ISR formula (ISR was underestimated in previous versions).
New version includes ISR in leading-log approximation up to
third order. Parameter ISR_sqrts renamed to ISR_scale.
##################################################################
2002-02-19
RELEASE: version 1.20
New process-generating method 'test' (dummy matrix element)
Compatibility with autoconf 2.50 and current O'Mega version
2002-02-05
Prevent integration channels from being dropped (optionally)
New internal mapping for structure functions improves performance
Old whizard.phx file deleted after recompiling (could cause trouble)
2002-01-24
Support for user-defined cuts and matrix element reweighting
STDHEP output now written by write_events_format=20 (was 3)
2002-01-16
Improved structure function handling; small changes in user interface:
new parameter structured_beams in &process_input
parameter fixed_energy in &beam_input removed
Support for multiple initial states
Eta-phi (cone) cut possible (hadron collider applications)
Fixed bug: Whizard library was not always recompiled when necessary
Fixed bug: Default cuts were insufficient in some cases
Fixed bug: Unusable phase space mappings generated in some cases
2001-12-06
Reorganized document source
2001-12-05
Preliminary CIRCE2 support (no functionality yet)
2001-11-27
Intel compiler support (does not yet work because of compiler bugs)
New cut and analysis mode cos-theta* and related
Fixed circular jetset_interface dependency warning
Some broadcast routines removed (parallel support disabled anyway)
Minor shifts in cleanup targets (Makefiles)
Modified library search, check for pdflib8*
2001-08-06
Fixed bug: I/O unit number could be undefined when reading phase space
Fixed bug: Unitialized variable could cause segfault when
event generation was disabled
Fixed bug: Undefined subroutine in CIRCE replacement module
Enabled feature: TGCs in O'Mega (not yet CompHEP!) matrix elements
(CompHEP model sm-GF #5, O'Mega model SM_ac)
Fixed portability issue: Makefile did rely on PWD environment variable
Fixed portability issue: PYTHIA library search ambiguity resolved
2001-08-01
Default whizard.prc and whizard.in depend on activated modules
Fixed bug: TEX=latex was not properly enabled when making plots
2001-07-20
Fixed output settings in PERL script calls
Cache enabled in various configure checks
2001-07-13
Support for multiple processes in a single WHIZARD run. The
integrations are kept separate, but the generated events are mixed
The whizard.evx format has changed (incompatible), including now
the color flow information for PYTHIA fragmentation
Output files are now process-specific, except for the event file
Phase space file whizard.phs (if present) is used only as input,
program-generated phase space is now in whizard.phx
2001-07-10
Bug fix: Undefined parameters in parameters_SM_ac.f90 removed
2001-07-04
Bug fix: Compiler options for the case OMEGA is disabled
Small inconsistencies in whizard.out format fixed
2001-07-01
Workaround for missing PDFLIB dummy routines in PYTHIA library
##################################################################
2001-06-30
RELEASE: version 1.13
Default path /cern/pro/lib in configure script
2001-06-20
New fragmentation option: Interface for PYTHIA with full color flow
information, beam remnants etc.
2001-06-18
Severe bug fixed in madgraph interface: 3-gluon coupling was missing
Enabled color flow information in madgraph
2001-06-11
VAMP interface module rewritten
Revised output format: Multiple VAMP iterations count as one WHIZARD
iteration in integration passes 1 and 3
Improved message and error handling
Bug fix in VAMP: handle exceptional cases in rebinning_weights
2001-05-31
new parameters for grid adaptation: accuracy_goal and efficiency_goal
##################################################################
2001-05-29
RELEASE: version 1.12
bug fixes (compilation problems): deleted/modified unused functions
2001-05-16
diagram selection improved and documented
2001-05-06
allow for disabling packages during configuration
2001-05-03
slight changes in whizard.out format; manual extended
##################################################################
2001-04-20
RELEASE: version 1.11
fixed some configuration and compilation problems (PDFLIB etc.)
2001-04-18
linked PDFLIB: support for quark/gluon structure functions
2001-04-05
parameter interface written by PERL script
SM_ac model file: fixed error in continuation line
2001-03-13
O'Mega, O'Caml 3.01: incompatible changes
O'Mega, src/trie.mli: add covariance annotation to T.t
This breaks O'Caml 3.00, but is required for O'Caml 3.01.
O'Mega, many instances: replace `sig include Module.T end' by
`Module.T', since the bug is fixed in O'Caml 3.01
2001-02-28
O'Mega, src/model.mli:
new field Model.vertices required for model functors, will
retire Model.fuse2, Model.fuse3, Model.fusen soon.
##################################################################
2001-03-27
RELEASE: version 1.10
reorganized the modules as libraries
linked PYTHIA: support for parton fragmentation
2000-12-14
fixed some configuration problems (if noweb etc. are absent)
##################################################################
2000-12-01
RELEASE of first public version: version 1.00beta