Index: trunk/m4/recola.m4 =================================================================== --- trunk/m4/recola.m4 (revision 8252) +++ trunk/m4/recola.m4 (revision 8253) @@ -1,99 +1,99 @@ dnl recola.m4 -- checks for Recola package dnl AC_DEFUN([WO_PROG_RECOLA], [dnl AC_REQUIRE([AC_PROG_FC]) AC_ARG_ENABLE([recola], [AS_HELP_STRING([--enable-recola], [(experimental) enable Recola for NLO matrix elements [[no]]])], [], [enable_recola="no"]) AC_ARG_WITH([recola], [AS_HELP_STRING([--with-recola=dir], [assume the given directory for Recola])]) if test "$enable_recola" = "yes"; then if test -n "$with_recola"; then WO_PATH_LIB(RECOLA, [recola], [librecola.${SHRLIB_EXT}], ${with_recola}) else WO_PATH_LIB(RECOLA, [recola], [librecola.${SHRLIB_EXT}], $LD_LIBRARY_PATH) fi if test "$RECOLA" != "no"; then AC_MSG_CHECKING([for get_recola_version_rcl in RECOLA]) AC_LANG_PUSH([Fortran]) recola_libdir=`dirname $RECOLA` RECOLA_DIR=$recola_libdir wo_recola_libdir="-L${recola_libdir}" wo_recola_ldflags="-Wl,-rpath,$RECOLA_DIR -L$RECOLA_DIR -lrecola -lcollier" wo_recola_includes="-I${recola_libdir}/../include" wo_recola_version="" save_LIBS="$LIBS" - LIBS="${LIBS} ${wo_recola_libdir} -lrecola -lcollier ${wo_recola_includes}" + LIBS="${LIBS} ${wo_recola_ldflags} -lrecola -lcollier ${wo_recola_includes}" AC_LINK_IFELSE([dnl AC_LANG_PROGRAM([],[[ use recola character(len=10) :: version call get_recola_version_rcl (version) print *, version ]])], [wo_recola_version=`./conftest | $SED -e 's/^[ \t]*//'`], [enable_recola="no"]) AC_MSG_RESULT([$enable_recola]) if test "$enable_recola" = "no"; then LIBS="$save_LIBS" AC_MSG_NOTICE([warning: ********************************************************]) AC_MSG_NOTICE([warning: It seems your RECOLA was not compiled properly or ]) AC_MSG_NOTICE([warning: compiled with a different FORTRAN compiler and you ]) AC_MSG_NOTICE([warning: forgot to add the proper runtime to ]) AC_MSG_NOTICE([warning: LIBS / LD_LIBRARY_PATH. Disabling RECOLA support... ]) AC_MSG_NOTICE([warning: ********************************************************]) AC_MSG_CHECKING([for Recola]) AC_MSG_RESULT([disabled]) else if test "$wo_recola_version" = "1.0" || test "$wo_recola_version" = "1.1" || test "$wo_recola_version" = "1.2" || test "$wo_recola_version" = "2.0.0" || test "$wo_recola_version" = 2.1.0 || test "$wo_recola_version" = 2.1.1; then AC_MSG_NOTICE([error: **************************************************]) AC_MSG_NOTICE([error: Old RECOLA versions (1.0/1.1/1.2, 2.0.0/2.1.0-1) ]) AC_MSG_NOTICE([error: are not supported. RECOLA will be disabled. ]) AC_MSG_NOTICE([error: **************************************************]) AC_MSG_CHECKING([for Recola]) AC_MSG_RESULT([(disabled)]) enable_recola = "no" else RECOLA_INCLUDES=$wo_recola_includes RECOLA_VERSION=$wo_recola_version LDFLAGS_RECOLA=$wo_recola_ldflags AC_SUBST([RECOLA_VERSION]) AC_SUBST([RECOLA_DIR]) AC_MSG_CHECKING([for Recola version]) AC_MSG_RESULT([$wo_recola_version]) fi fi AC_LANG_POP() else AC_MSG_CHECKING([for Recola]) AC_MSG_RESULT([(disabled)]) enable_recola="no" fi else AC_MSG_CHECKING([for Recola]) AC_MSG_RESULT([(disabled)]) fi AC_SUBST([RECOLA_INCLUDES]) AC_SUBST([LDFLAGS_RECOLA]) if test "$enable_recola" = "yes"; then RECOLA_AVAILABLE_FLAG=".true." else RECOLA_AVAILABLE_FLAG=".false." fi AC_SUBST([RECOLA_AVAILABLE_FLAG]) AM_CONDITIONAL([RECOLA_AVAILABLE], [test "$enable_recola" = "yes"]) ]) dnl WO_PROG_RECOLA Index: trunk/configure.ac.in =================================================================== --- trunk/configure.ac.in (revision 8252) +++ trunk/configure.ac.in (revision 8253) @@ -1,1191 +1,1191 @@ 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-2019 by dnl Wolfgang Kilian dnl Thorsten Ohl dnl Juergen Reuter 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],[2.8.0]) 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="May 31 2019" 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([**************************************************************]) ### Dump Package version and date to file 'VERSION' echo "$PACKAGE_STRING ($PACKAGE_STATUS) $PACKAGE_DATE" \ > VERSION ######################################################################## ###--------------------------------------------------------------------- ### shared library versioning (not the same as the package version!) LIBRARY_VERSION="-version-info 1: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]) ######################################################################## ###--------------------------------------------------------------------- ### 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/.*CFBundleShortVersionString<\/key>.\([[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_SUPP_PDF() AC_PROG_GZIP() AC_PATH_PROG(ACROREAD,acroread,false) AC_PATH_PROG(GHOSTVIEW,gv ghostview,false) AC_PATH_PROG(DOT,dot,false) AM_CONDITIONAL([DOT_AVAILABLE],[test "$DOT" != "false"]) ### 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 4 versions WO_FC_VETO_GFORTRAN_4() ### Veto against buggy gfortran 6.5.0 version WO_FC_VETO_GFORTRAN_65() ### Veto against ifort 15/16 WO_FC_VETO_IFORT_1516() ### Veto against ifort 17.0.0/1/2/3 WO_FC_VETO_IFORT_170123() ### Veto against ifort 19.0.0/1/2 WO_FC_VETO_IFORT_190012() ### 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() ### 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], [FC_MODULE_EXT], [$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 }}} ######################################################################## ###--------------------------------------------------------------------- ### O'Caml 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(312000) 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: O'Caml 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() ### 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() ###--------------------------------------------------------------------- ### 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() ###--------------------------------------------------------------------- ### 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() ###--------------------------------------------------------------------- -### Recola - -WO_CONFIGURE_SECTION([RECOLA]) - -WO_PROG_RECOLA() - -###--------------------------------------------------------------------- ### 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"]) ######################################################################## ###--------------------------------------------------------------------- ### Checks for external interfaces WO_CONFIGURE_SECTION([Auxiliary stuff for external interfaces]) AX_PYTHON() ### ONLY_FULL }}} ######################################################################## ###--------------------------------------------------------------------- ### Wrapup WO_CONFIGURE_SECTION([Finalize configuration]) ### Main directory AC_CONFIG_FILES([Makefile]) ### ONLY_FULL {{{ ###--------------------------------------------------------------------- ### Subdirectory src AC_CONFIG_FILES([src/Makefile]) ###--------------------------------------------------------------------- ### Subdirectory src/hepmc AC_CONFIG_FILES([src/hepmc/Makefile]) ###--------------------------------------------------------------------- ### Subdirectory src/lcio AC_CONFIG_FILES([src/lcio/Makefile]) ###--------------------------------------------------------------------- ### Subdirectory pythia6: WHIZARD's internal PYTHIA6 version AC_CONFIG_FILES([pythia6/Makefile]) ###--------------------------------------------------------------------- ### Subdirectory tauola: WHIZARD's internal TAUOLA version AC_CONFIG_FILES([tauola/Makefile]) ###--------------------------------------------------------------------- ### Subdirectory stdhep: WHIZARD's internal StdHep version AC_CONFIG_FILES([mcfio/Makefile]) AC_CONFIG_FILES([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: Builtin PDFs AC_CONFIG_FILES([src/pdf_builtin/Makefile]) ###--------------------------------------------------------------------- ### Subdirectory src/pdf_builtin: Electron PDFs AC_CONFIG_FILES([src/qed_pdf/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], [ maxlen=70 i=1 pat="" while test ${i} -lt ${maxlen}; do pat="${pat}."; i=`expr ${i} + 1`; done pat=${pat}[[^\"]] pat="/^ \"${pat}/ s/${pat}/&\&\\ \&/g" $SED "${pat}" < 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/user: user plugin support AC_CONFIG_FILES([src/user/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/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/interfaces AC_CONFIG_FILES([share/interfaces/Makefile]) AC_CONFIG_FILES([share/interfaces/py_whiz_setup.py]) ###--------------------------------------------------------------------- ### 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/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/unit_tests/run_whizard_ut.sh], [chmod u+x tests/unit_tests/run_whizard_ut.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]) ###-------------------------------------------------------------------- ### 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/tools/Makefile]) AC_CONFIG_FILES([omega/scripts/Makefile]) AC_CONFIG_FILES([omega/scripts/omega-config], [chmod u+x omega/scripts/omega-config]) # 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/src/model_features/model_features.nw =================================================================== --- trunk/src/model_features/model_features.nw (revision 8252) +++ trunk/src/model_features/model_features.nw (revision 8253) @@ -1,16667 +1,16668 @@ % -*- ess-noweb-default-code-mode: f90-mode; noweb-default-code-mode: f90-mode; -*- % WHIZARD code as NOWEB source: model features %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Model Handling and Features} \includemodulegraph{model_features} These modules deal with process definitions and physics models. These modules use the [[model_data]] methods to automatically generate process definitions. \begin{description} \item[auto\_components] Generic process-definition generator. We can specify a basic process or initial particle(s) and some rules to extend this process, given a model definition with particle names and vertex structures. \item[radiation\_generator] Applies the generic generator to the specific problem of generating NLO corrections in a restricted setup. \end{description} Model construction: \begin{description} \item[eval\_trees] Implementation of the generic [[expr_t]] type for the concrete evaluation of expressions that access user variables. This module is actually part of the Sindarin language implementation, and should be moved elsewhere. Currently, the [[models]] module relies on it. \item[models] Extends the [[model_data_t]] structure by user-variable objects for easy access, and provides the means to read a model definition from file. \item[slha\_interface] Read/write a SUSY model in the standardized SLHA format. The format defines fields and parameters, but no vertices. \end{description} \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Automatic generation of process components} This module provides the functionality for automatically generating radiation corrections or decays, provided as lists of PDG codes. <<[[auto_components.f90]]>>= <> module auto_components <> <> use io_units use diagnostics use model_data use pdg_arrays use physics_defs, only: PHOTON, GLUON, Z_BOSON, W_BOSON use numeric_utils, only: extend_integer_array <> <> <> <> <> contains <> end module auto_components @ %def auto_components @ \subsection{Constraints: Abstract types} An abstract type that denotes a constraint on the automatically generated states. The concrete objects are applied as visitor objects at certain hooks during the splitting algorithm. <>= type, abstract :: split_constraint_t contains <> end type split_constraint_t @ %def split_constraint_t @ By default, all checks return true. <>= procedure :: check_before_split => split_constraint_check_before_split procedure :: check_before_insert => split_constraint_check_before_insert procedure :: check_before_record => split_constraint_check_before_record <>= subroutine split_constraint_check_before_split (c, table, pl, k, passed) class(split_constraint_t), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: k logical, intent(out) :: passed passed = .true. end subroutine split_constraint_check_before_split subroutine split_constraint_check_before_insert (c, table, pa, pl, passed) class(split_constraint_t), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_array_t), intent(in) :: pa type(pdg_list_t), intent(inout) :: pl logical, intent(out) :: passed passed = .true. end subroutine split_constraint_check_before_insert subroutine split_constraint_check_before_record (c, table, pl, n_loop, passed) class(split_constraint_t), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_loop logical, intent(out) :: passed passed = .true. end subroutine split_constraint_check_before_record @ %def check_before_split @ %def check_before_insert @ %def check_before_record @ A transparent wrapper, so we can collect constraints of different type. <>= type :: split_constraint_wrap_t class(split_constraint_t), allocatable :: c end type split_constraint_wrap_t @ %def split_constraint_wrap_t @ A collection of constraints. <>= public :: split_constraints_t <>= type :: split_constraints_t class(split_constraint_wrap_t), dimension(:), allocatable :: cc contains <> end type split_constraints_t @ %def split_constraints_t @ Initialize the constraints set with a specific number of elements. <>= procedure :: init => split_constraints_init <>= subroutine split_constraints_init (constraints, n) class(split_constraints_t), intent(out) :: constraints integer, intent(in) :: n allocate (constraints%cc (n)) end subroutine split_constraints_init @ %def split_constraints_init @ Set a constraint. <>= procedure :: set => split_constraints_set <>= subroutine split_constraints_set (constraints, i, c) class(split_constraints_t), intent(inout) :: constraints integer, intent(in) :: i class(split_constraint_t), intent(in) :: c allocate (constraints%cc(i)%c, source = c) end subroutine split_constraints_set @ %def split_constraints_set @ Apply checks. [[check_before_split]] is applied to the particle list that we want to split. [[check_before_insert]] is applied to the particle list [[pl]] that is to replace the particle [[pa]] that is split. This check may transform the particle list. [[check_before_record]] is applied to the complete new particle list that results from splitting before it is recorded. <>= procedure :: check_before_split => split_constraints_check_before_split procedure :: check_before_insert => split_constraints_check_before_insert procedure :: check_before_record => split_constraints_check_before_record <>= subroutine split_constraints_check_before_split & (constraints, table, pl, k, passed) class(split_constraints_t), intent(in) :: constraints class(ps_table_t), intent(in) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: k logical, intent(out) :: passed integer :: i passed = .true. do i = 1, size (constraints%cc) call constraints%cc(i)%c%check_before_split (table, pl, k, passed) if (.not. passed) return end do end subroutine split_constraints_check_before_split subroutine split_constraints_check_before_insert & (constraints, table, pa, pl, passed) class(split_constraints_t), intent(in) :: constraints class(ps_table_t), intent(in) :: table type(pdg_array_t), intent(in) :: pa type(pdg_list_t), intent(inout) :: pl logical, intent(out) :: passed integer :: i passed = .true. do i = 1, size (constraints%cc) call constraints%cc(i)%c%check_before_insert (table, pa, pl, passed) if (.not. passed) return end do end subroutine split_constraints_check_before_insert subroutine split_constraints_check_before_record & (constraints, table, pl, n_loop, passed) class(split_constraints_t), intent(in) :: constraints class(ps_table_t), intent(in) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_loop logical, intent(out) :: passed integer :: i passed = .true. do i = 1, size (constraints%cc) call constraints%cc(i)%c%check_before_record (table, pl, n_loop, passed) if (.not. passed) return end do end subroutine split_constraints_check_before_record @ %def split_constraints_check_before_split @ %def split_constraints_check_before_insert @ %def split_constraints_check_before_record @ \subsection{Specific constraints} \subsubsection{Number of particles} Specific constraint: The number of particles plus the number of loops, if any, must remain less than the given limit. Note that the number of loops is defined only when we are recording the entry. <>= type, extends (split_constraint_t) :: constraint_n_tot private integer :: n_max = 0 contains procedure :: check_before_split => constraint_n_tot_check_before_split procedure :: check_before_record => constraint_n_tot_check_before_record end type constraint_n_tot @ %def constraint_n_tot <>= public :: constrain_n_tot <>= function constrain_n_tot (n_max) result (c) integer, intent(in) :: n_max type(constraint_n_tot) :: c c%n_max = n_max end function constrain_n_tot subroutine constraint_n_tot_check_before_split (c, table, pl, k, passed) class(constraint_n_tot), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: k logical, intent(out) :: passed passed = pl%get_size () < c%n_max end subroutine constraint_n_tot_check_before_split subroutine constraint_n_tot_check_before_record (c, table, pl, n_loop, passed) class(constraint_n_tot), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_loop logical, intent(out) :: passed passed = pl%get_size () + n_loop <= c%n_max end subroutine constraint_n_tot_check_before_record @ %def constrain_n_tot @ %def constraint_n_tot_check_before_insert @ \subsubsection{Number of loops} Specific constraint: The number of loops is limited, independent of the total number of particles. <>= type, extends (split_constraint_t) :: constraint_n_loop private integer :: n_loop_max = 0 contains procedure :: check_before_record => constraint_n_loop_check_before_record end type constraint_n_loop @ %def constraint_n_loop <>= public :: constrain_n_loop <>= function constrain_n_loop (n_loop_max) result (c) integer, intent(in) :: n_loop_max type(constraint_n_loop) :: c c%n_loop_max = n_loop_max end function constrain_n_loop subroutine constraint_n_loop_check_before_record & (c, table, pl, n_loop, passed) class(constraint_n_loop), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_loop logical, intent(out) :: passed passed = n_loop <= c%n_loop_max end subroutine constraint_n_loop_check_before_record @ %def constrain_n_loop @ %def constraint_n_loop_check_before_insert @ \subsubsection{Particles allowed in splitting} Specific constraint: The entries in the particle list ready for insertion are matched to a given list of particle patterns. If a match occurs, the entry is replaced by the corresponding pattern. If there is no match, the check fails. If a massless gauge boson splitting is detected, the splitting partners are checked against a list of excluded particles. If a match occurs, the check fails. <>= type, extends (split_constraint_t) :: constraint_splittings private type(pdg_list_t) :: pl_match, pl_excluded_gauge_splittings contains procedure :: check_before_insert => constraint_splittings_check_before_insert end type constraint_splittings @ %def constraint_splittings <>= public :: constrain_splittings <>= function constrain_splittings (pl_match, pl_excluded_gauge_splittings) result (c) type(pdg_list_t), intent(in) :: pl_match type(pdg_list_t), intent(in) :: pl_excluded_gauge_splittings type(constraint_splittings) :: c c%pl_match = pl_match c%pl_excluded_gauge_splittings = pl_excluded_gauge_splittings end function constrain_splittings subroutine constraint_splittings_check_before_insert (c, table, pa, pl, passed) class(constraint_splittings), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_array_t), intent(in) :: pa type(pdg_list_t), intent(inout) :: pl logical, intent(out) :: passed logical :: has_massless_vector integer :: i has_massless_vector = .false. do i = 1, pa%get_length () if (is_massless_vector(pa%get(i))) then has_massless_vector = .true. exit end if end do passed = .false. if (has_massless_vector .and. count (is_fermion(pl%a%get ())) == 2) then do i = 1, c%pl_excluded_gauge_splittings%get_size () if (pl .match. c%pl_excluded_gauge_splittings%a(i)) return end do call pl%match_replace (c%pl_match, passed) passed = .true. else call pl%match_replace (c%pl_match, passed) end if end subroutine constraint_splittings_check_before_insert @ %def constrain_splittings @ %def constraint_splittings_check_before_insert @ Specific constraint: The entries in the particle list ready for insertion are matched to a given list of particle patterns. If a match occurs, the entry is replaced by the corresponding pattern. If there is no match, the check fails. <>= type, extends (split_constraint_t) :: constraint_insert private type(pdg_list_t) :: pl_match contains procedure :: check_before_insert => constraint_insert_check_before_insert end type constraint_insert @ %def constraint_insert <>= public :: constrain_insert <>= function constrain_insert (pl_match) result (c) type(pdg_list_t), intent(in) :: pl_match type(constraint_insert) :: c c%pl_match = pl_match end function constrain_insert subroutine constraint_insert_check_before_insert (c, table, pa, pl, passed) class(constraint_insert), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_array_t), intent(in) :: pa type(pdg_list_t), intent(inout) :: pl logical, intent(out) :: passed call pl%match_replace (c%pl_match, passed) end subroutine constraint_insert_check_before_insert @ %def constrain_insert @ %def constraint_insert_check_before_insert @ \subsubsection{Particles required in final state} Specific constraint: The entries in the recorded state must be a superset of the entries in the given list (for instance, the lowest-order state). <>= type, extends (split_constraint_t) :: constraint_require private type(pdg_list_t) :: pl contains procedure :: check_before_record => constraint_require_check_before_record end type constraint_require @ %def constraint_require @ We check the current state by matching all particle entries against the stored particle list, and crossing out the particles in the latter list when a match is found. The constraint passed if all entries have been crossed out. For an [[if_table]] in particular, we check the final state only. <>= public :: constrain_require <>= function constrain_require (pl) result (c) type(pdg_list_t), intent(in) :: pl type(constraint_require) :: c c%pl = pl end function constrain_require subroutine constraint_require_check_before_record & (c, table, pl, n_loop, passed) class(constraint_require), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_loop logical, intent(out) :: passed logical, dimension(:), allocatable :: mask integer :: i, k, n_in select type (table) type is (if_table_t) if (table%proc_type > 0) then select case (table%proc_type) case (PROC_DECAY) n_in = 1 case (PROC_SCATTER) n_in = 2 end select else call msg_fatal ("Neither a decay nor a scattering process") end if class default n_in = 0 end select allocate (mask (c%pl%get_size ()), source = .true.) do i = n_in + 1, pl%get_size () k = c%pl%find_match (pl%get (i), mask) if (k /= 0) mask(k) = .false. end do passed = .not. any (mask) end subroutine constraint_require_check_before_record @ %def constrain_require @ %def constraint_require_check_before_record @ \subsubsection{Radiation} Specific constraint: We have radiation pattern if the original particle matches an entry in the list of particles that should replace it. The constraint prohibits this situation. <>= public :: constrain_radiation <>= type, extends (split_constraint_t) :: constraint_radiation private contains procedure :: check_before_insert => & constraint_radiation_check_before_insert end type constraint_radiation @ %def constraint_radiation <>= function constrain_radiation () result (c) type(constraint_radiation) :: c end function constrain_radiation subroutine constraint_radiation_check_before_insert (c, table, pa, pl, passed) class(constraint_radiation), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_array_t), intent(in) :: pa type(pdg_list_t), intent(inout) :: pl logical, intent(out) :: passed passed = .not. (pl .match. pa) end subroutine constraint_radiation_check_before_insert @ %def constrain_radiation @ %def constraint_radiation_check_before_insert @ \subsubsection{Mass sum} Specific constraint: The sum of masses within the particle list must be smaller than a given limit. For in/out state combinations, we check initial and final state separately. If we specify [[margin]] in the initialization, the sum must be strictly less than the limit minus the given margin (which may be zero). If not, equality is allowed. <>= public :: constrain_mass_sum <>= type, extends (split_constraint_t) :: constraint_mass_sum private real(default) :: mass_limit = 0 logical :: strictly_less = .false. real(default) :: margin = 0 contains procedure :: check_before_record => constraint_mass_sum_check_before_record end type constraint_mass_sum @ %def contraint_mass_sum <>= function constrain_mass_sum (mass_limit, margin) result (c) real(default), intent(in) :: mass_limit real(default), intent(in), optional :: margin type(constraint_mass_sum) :: c c%mass_limit = mass_limit if (present (margin)) then c%strictly_less = .true. c%margin = margin end if end function constrain_mass_sum subroutine constraint_mass_sum_check_before_record & (c, table, pl, n_loop, passed) class(constraint_mass_sum), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_loop logical, intent(out) :: passed real(default) :: limit if (c%strictly_less) then limit = c%mass_limit - c%margin select type (table) type is (if_table_t) passed = mass_sum (pl, 1, 2, table%model) < limit & .and. mass_sum (pl, 3, pl%get_size (), table%model) < limit class default passed = mass_sum (pl, 1, pl%get_size (), table%model) < limit end select else limit = c%mass_limit select type (table) type is (if_table_t) passed = mass_sum (pl, 1, 2, table%model) <= limit & .and. mass_sum (pl, 3, pl%get_size (), table%model) <= limit class default passed = mass_sum (pl, 1, pl%get_size (), table%model) <= limit end select end if end subroutine constraint_mass_sum_check_before_record @ %def constrain_mass_sum @ %def constraint_mass_sum_check_before_record @ \subsubsection{Initial state particles} Specific constraint: The two incoming particles must both match the given particle list. This is checked for the generated particle list, just before it is recorded. <>= public :: constrain_in_state <>= type, extends (split_constraint_t) :: constraint_in_state private type(pdg_list_t) :: pl contains procedure :: check_before_record => constraint_in_state_check_before_record end type constraint_in_state @ %def constraint_in_state <>= function constrain_in_state (pl) result (c) type(pdg_list_t), intent(in) :: pl type(constraint_in_state) :: c c%pl = pl end function constrain_in_state subroutine constraint_in_state_check_before_record & (c, table, pl, n_loop, passed) class(constraint_in_state), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_loop logical, intent(out) :: passed integer :: i select type (table) type is (if_table_t) passed = .false. do i = 1, 2 if (.not. (c%pl .match. pl%get (i))) return end do end select passed = .true. end subroutine constraint_in_state_check_before_record @ %def constrain_in_state @ %def constraint_in_state_check_before_record @ \subsubsection{Photon induced processes} If set, filter out photon induced processes. <>= public :: constrain_photon_induced_processes <>= type, extends (split_constraint_t) :: constraint_photon_induced_processes private integer :: n_in contains procedure :: check_before_record => & constraint_photon_induced_processes_check_before_record end type constraint_photon_induced_processes @ %def constraint_photon_induced_processes <>= function constrain_photon_induced_processes (n_in) result (c) integer, intent(in) :: n_in type(constraint_photon_induced_processes) :: c c%n_in = n_in end function constrain_photon_induced_processes subroutine constraint_photon_induced_processes_check_before_record & (c, table, pl, n_loop, passed) class(constraint_photon_induced_processes), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_loop logical, intent(out) :: passed integer :: i select type (table) type is (if_table_t) passed = .false. do i = 1, c%n_in if (pl%a(i)%get () == 22) return end do end select passed = .true. end subroutine constraint_photon_induced_processes_check_before_record @ %def constrain_photon_induced_processes @ %def constraint_photon_induced_processes_check_before_record @ \subsubsection{Coupling constraint} Filters vertices which do not match the desired NLO pattern. <>= type, extends (split_constraint_t) :: constraint_coupling_t private logical :: qed = .false. logical :: qcd = .true. logical :: ew = .false. integer :: n_nlo_correction_types contains <> end type constraint_coupling_t @ %def constraint_coupling_t @ <>= public :: constrain_couplings <>= function constrain_couplings (qcd, qed, n_nlo_correction_types) result (c) type(constraint_coupling_t) :: c logical, intent(in) :: qcd, qed integer, intent(in) :: n_nlo_correction_types c%qcd = qcd; c%qed = qed c%n_nlo_correction_types = n_nlo_correction_types end function constrain_couplings @ %def constrain_couplings @ <>= procedure :: check_before_insert => constraint_coupling_check_before_insert <>= subroutine constraint_coupling_check_before_insert (c, table, pa, pl, passed) class(constraint_coupling_t), intent(in) :: c class(ps_table_t), intent(in) :: table type(pdg_array_t), intent(in) :: pa type(pdg_list_t), intent(inout) :: pl logical, intent(out) :: passed type(pdg_list_t) :: pl_vertex type(pdg_array_t) :: pdg_gluon, pdg_photon, pdg_W_Z, pdg_gauge_bosons integer :: i, j pdg_gluon = GLUON; pdg_photon = PHOTON pdg_W_Z = [W_BOSON,-W_BOSON, Z_BOSON] if (c%qcd) pdg_gauge_bosons = pdg_gauge_bosons // pdg_gluon if (c%qed) pdg_gauge_bosons = pdg_gauge_bosons // pdg_photon if (c%ew) pdg_gauge_bosons = pdg_gauge_bosons // pdg_W_Z do j = 1, pa%get_length () call pl_vertex%init (pl%get_size () + 1) call pl_vertex%set (1, pa%get(j)) do i = 1, pl%get_size () call pl_vertex%set (i + 1, pl%get(i)) end do if (pl_vertex%get_size () > 3) then passed = .false. cycle end if if (is_massless_vector(pa%get(j))) then if (.not. table%model%check_vertex & (pl_vertex%a(1)%get (), pl_vertex%a(2)%get (), pl_vertex%a(3)%get ())) then passed = .false. cycle end if else if (.not. table%model%check_vertex & (- pl_vertex%a(1)%get (), pl_vertex%a(2)%get (), pl_vertex%a(3)%get ())) then passed = .false. cycle end if if (.not. (pl_vertex .match. pdg_gauge_bosons)) then passed = .false. cycle end if passed = .true. exit end do end subroutine constraint_coupling_check_before_insert @ %def constraint_coupling_check_before_insert @ \subsection{Tables of states} Automatically generate a list of possible process components for a given initial set (a single massive particle or a preset list of states). The set of process components are generated by recursive splitting, applying constraints on the fly that control and limit the process. The generated states are accumulated in a table that we can read out after completion. <>= type, extends (pdg_list_t) :: ps_entry_t integer :: n_loop = 0 integer :: n_rad = 0 type(ps_entry_t), pointer :: previous => null () type(ps_entry_t), pointer :: next => null () end type ps_entry_t @ %def ps_entry_t @ <>= integer, parameter :: PROC_UNDEFINED = 0 integer, parameter :: PROC_DECAY = 1 integer, parameter :: PROC_SCATTER = 2 @ %def auto_components parameters @ This is the wrapper type for the decay tree for the list of final states and the final array. First, an abstract base type: <>= public :: ps_table_t <>= type, abstract :: ps_table_t private class(model_data_t), pointer :: model => null () logical :: loops = .false. type(ps_entry_t), pointer :: first => null () type(ps_entry_t), pointer :: last => null () integer :: proc_type contains <> end type ps_table_t @ %def ps_table_t @ The extensions: one for decay, one for generic final states. The decay-state table stores the initial particle. The final-state table is indifferent, and the initial/final state table treats the first two particles in its list as incoming antiparticles. <>= public :: ds_table_t public :: fs_table_t public :: if_table_t <>= type, extends (ps_table_t) :: ds_table_t private integer :: pdg_in = 0 contains <> end type ds_table_t type, extends (ps_table_t) :: fs_table_t contains <> end type fs_table_t type, extends (fs_table_t) :: if_table_t contains <> end type if_table_t @ %def ds_table_t fs_table_t if_table_t @ Finalizer: we must deallocate the embedded list. <>= procedure :: final => ps_table_final <>= subroutine ps_table_final (object) class(ps_table_t), intent(inout) :: object type(ps_entry_t), pointer :: current do while (associated (object%first)) current => object%first object%first => current%next deallocate (current) end do nullify (object%last) end subroutine ps_table_final @ %def ps_table_final @ Write the table. A base writer for the body and specific writers for the headers. <>= procedure :: base_write => ps_table_base_write procedure (ps_table_write), deferred :: write <>= interface subroutine ps_table_write (object, unit) import class(ps_table_t), intent(in) :: object integer, intent(in), optional :: unit end subroutine ps_table_write end interface <>= procedure :: write => ds_table_write <>= procedure :: write => fs_table_write <>= procedure :: write => if_table_write @ The first [[n_in]] particles will be replaced by antiparticles in the output, and we write an arrow if [[n_in]] is present. <>= subroutine ps_table_base_write (object, unit, n_in) class(ps_table_t), intent(in) :: object integer, intent(in), optional :: unit integer, intent(in), optional :: n_in integer, dimension(:), allocatable :: pdg type(ps_entry_t), pointer :: entry type(field_data_t), pointer :: prt integer :: u, i, j, n0 u = given_output_unit (unit) entry => object%first do while (associated (entry)) write (u, "(2x)", advance = "no") if (present (n_in)) then do i = 1, n_in write (u, "(1x)", advance = "no") pdg = entry%get (i) do j = 1, size (pdg) prt => object%model%get_field_ptr (pdg(j)) if (j > 1) write (u, "(':')", advance = "no") write (u, "(A)", advance = "no") & char (prt%get_name (pdg(j) >= 0)) end do end do write (u, "(1x,A)", advance = "no") "=>" n0 = n_in + 1 else n0 = 1 end if do i = n0, entry%get_size () write (u, "(1x)", advance = "no") pdg = entry%get (i) do j = 1, size (pdg) prt => object%model%get_field_ptr (pdg(j)) if (j > 1) write (u, "(':')", advance = "no") write (u, "(A)", advance = "no") & char (prt%get_name (pdg(j) < 0)) end do end do if (object%loops) then write (u, "(2x,'[',I0,',',I0,']')") entry%n_loop, entry%n_rad else write (u, "(A)") end if entry => entry%next end do end subroutine ps_table_base_write subroutine ds_table_write (object, unit) class(ds_table_t), intent(in) :: object integer, intent(in), optional :: unit type(field_data_t), pointer :: prt integer :: u u = given_output_unit (unit) prt => object%model%get_field_ptr (object%pdg_in) write (u, "(1x,A,1x,A)") "Decays for particle:", & char (prt%get_name (object%pdg_in < 0)) call object%base_write (u) end subroutine ds_table_write subroutine fs_table_write (object, unit) class(fs_table_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Table of final states:" call object%base_write (u) end subroutine fs_table_write subroutine if_table_write (object, unit) class(if_table_t), intent(in) :: object integer, intent(in), optional :: unit integer :: u u = given_output_unit (unit) write (u, "(1x,A)") "Table of in/out states:" select case (object%proc_type) case (PROC_DECAY) call object%base_write (u, n_in = 1) case (PROC_SCATTER) call object%base_write (u, n_in = 2) end select end subroutine if_table_write @ %def ps_table_write ds_table_write fs_table_write @ Obtain a particle string for a given index in the pdg list <>= procedure :: get_particle_string => ps_table_get_particle_string <>= subroutine ps_table_get_particle_string (object, index, prt_in, prt_out) class(ps_table_t), intent(in) :: object integer, intent(in) :: index type(string_t), intent(out), dimension(:), allocatable :: prt_in, prt_out integer :: n_in type(field_data_t), pointer :: prt type(ps_entry_t), pointer :: entry integer, dimension(:), allocatable :: pdg integer :: n0 integer :: i, j entry => object%first i = 1 do while (i < index) if (associated (entry%next)) then entry => entry%next i = i + 1 else call msg_fatal ("ps_table: entry with requested index does not exist!") end if end do if (object%proc_type > 0) then select case (object%proc_type) case (PROC_DECAY) n_in = 1 case (PROC_SCATTER) n_in = 2 end select else call msg_fatal ("Neither decay nor scattering process") end if n0 = n_in + 1 allocate (prt_in (n_in), prt_out (entry%get_size () - n_in)) do i = 1, n_in prt_in(i) = "" pdg = entry%get(i) do j = 1, size (pdg) prt => object%model%get_field_ptr (pdg(j)) prt_in(i) = prt_in(i) // prt%get_name (pdg(j) >= 0) if (j /= size (pdg)) prt_in(i) = prt_in(i) // ":" end do end do do i = n0, entry%get_size () prt_out(i-n_in) = "" pdg = entry%get(i) do j = 1, size (pdg) prt => object%model%get_field_ptr (pdg(j)) prt_out(i-n_in) = prt_out(i-n_in) // prt%get_name (pdg(j) < 0) if (j /= size (pdg)) prt_out(i-n_in) = prt_out(i-n_in) // ":" end do end do end subroutine ps_table_get_particle_string @ %def ps_table_get_particle_string @ Initialize with a predefined set of final states, or in/out state lists. <>= generic :: init => ps_table_init procedure, private :: ps_table_init <>= generic :: init => if_table_init procedure, private :: if_table_init <>= subroutine ps_table_init (table, model, pl, constraints, n_in, do_not_check_regular) class(ps_table_t), intent(out) :: table class(model_data_t), intent(in), target :: model type(pdg_list_t), dimension(:), intent(in) :: pl type(split_constraints_t), intent(in) :: constraints integer, intent(in), optional :: n_in logical, intent(in), optional :: do_not_check_regular logical :: passed integer :: i table%model => model if (present (n_in)) then select case (n_in) case (1) table%proc_type = PROC_DECAY case (2) table%proc_type = PROC_SCATTER case default table%proc_type = PROC_UNDEFINED end select else table%proc_type = PROC_UNDEFINED end if do i = 1, size (pl) call table%record (pl(i), 0, 0, constraints, & do_not_check_regular, passed) if (.not. passed) then call msg_fatal ("ps_table: Registering process components failed") end if end do end subroutine ps_table_init subroutine if_table_init (table, model, pl_in, pl_out, constraints) class(if_table_t), intent(out) :: table class(model_data_t), intent(in), target :: model type(pdg_list_t), dimension(:), intent(in) :: pl_in, pl_out type(split_constraints_t), intent(in) :: constraints integer :: i, j, k, p, n_in, n_out type(pdg_array_t), dimension(:), allocatable :: pa_in type(pdg_list_t), dimension(:), allocatable :: pl allocate (pl (size (pl_in) * size (pl_out))) k = 0 do i = 1, size (pl_in) n_in = pl_in(i)%get_size () allocate (pa_in (n_in)) do p = 1, n_in pa_in(p) = pl_in(i)%get (p) end do do j = 1, size (pl_out) n_out = pl_out(j)%get_size () k = k + 1 call pl(k)%init (n_in + n_out) do p = 1, n_in call pl(k)%set (p, invert_pdg_array (pa_in(p), model)) end do do p = 1, n_out call pl(k)%set (n_in + p, pl_out(j)%get (p)) end do end do deallocate (pa_in) end do n_in = size (pl_in(1)%a) call table%init (model, pl, constraints, n_in, do_not_check_regular = .true.) end subroutine if_table_init @ %def ps_table_init if_table_init @ Enable loops for the table. This affects both splitting and output. <>= procedure :: enable_loops => ps_table_enable_loops <>= subroutine ps_table_enable_loops (table) class(ps_table_t), intent(inout) :: table table%loops = .true. end subroutine ps_table_enable_loops @ %def ps_table_enable_loops @ \subsection{Top-level methods} Create a table for a single-particle decay. Construct all possible final states from a single particle with PDG code [[pdg_in]]. The construction is limited by the given [[constraints]]. <>= procedure :: make => ds_table_make <>= subroutine ds_table_make (table, model, pdg_in, constraints) class(ds_table_t), intent(out) :: table class(model_data_t), intent(in), target :: model integer, intent(in) :: pdg_in type(split_constraints_t), intent(in) :: constraints type(pdg_list_t) :: pl_in type(pdg_list_t), dimension(0) :: pl call table%init (model, pl, constraints) table%pdg_in = pdg_in call pl_in%init (1) call pl_in%set (1, [pdg_in]) call table%split (pl_in, 0, constraints) end subroutine ds_table_make @ %def ds_table_make @ Split all entries in a growing table, starting from a table that may already contain states. Add and record split states on the fly. <>= procedure :: radiate => fs_table_radiate <>= subroutine fs_table_radiate (table, constraints, do_not_check_regular) class(fs_table_t), intent(inout) :: table type(split_constraints_t) :: constraints logical, intent(in), optional :: do_not_check_regular type(ps_entry_t), pointer :: current current => table%first do while (associated (current)) call table%split (current, 0, constraints, record = .true., & do_not_check_regular = do_not_check_regular) current => current%next end do end subroutine fs_table_radiate @ %def fs_table_radiate @ \subsection{Splitting algorithm} Recursive splitting. First of all, we record the current [[pdg_list]] in the table, subject to [[constraints]], if requested. We also record copies of the list marked as loop corrections. When we record a particle list, we sort it first. If there is room for splitting, We take a PDG array list and the index of an element, and split this element in all possible ways. The split entry is inserted into the list, which we split further. The recursion terminates whenever the split array would have a length greater than $n_\text{max}$. <>= procedure :: split => ps_table_split <>= recursive subroutine ps_table_split (table, pl, n_rad, constraints, & record, do_not_check_regular) class(ps_table_t), intent(inout) :: table class(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_rad type(split_constraints_t), intent(in) :: constraints logical, intent(in), optional :: record, do_not_check_regular integer :: n_loop, i logical :: passed, save_pdg_index type(vertex_iterator_t) :: vit integer, dimension(:), allocatable :: pdg1 integer, dimension(:), allocatable :: pdg2 if (present (record)) then if (record) then n_loop = 0 INCR_LOOPS: do call table%record_sorted (pl, n_loop, n_rad, constraints, & do_not_check_regular, passed) if (.not. passed) exit INCR_LOOPS if (.not. table%loops) exit INCR_LOOPS n_loop = n_loop + 1 end do INCR_LOOPS end if end if select type (table) type is (if_table_t) save_pdg_index = .true. class default save_pdg_index = .false. end select do i = 1, pl%get_size () call constraints%check_before_split (table, pl, i, passed) if (passed) then pdg1 = pl%get (i) call vit%init (table%model, pdg1, save_pdg_index) SCAN_VERTICES: do call vit%get_next_match (pdg2) if (allocated (pdg2)) then call table%insert (pl, n_rad, i, pdg2, constraints, & do_not_check_regular = do_not_check_regular) else exit SCAN_VERTICES end if end do SCAN_VERTICES end if end do end subroutine ps_table_split @ %def ps_table_split @ The worker part: insert the list of particles found by vertex matching in place of entry [[i]] in the PDG list. Then split/record further. The [[n_in]] parameter tells the replacement routine to insert the new particles after entry [[n_in]]. Otherwise, they follow index [[i]]. <>= procedure :: insert => ps_table_insert <>= recursive subroutine ps_table_insert & (table, pl, n_rad, i, pdg, constraints, n_in, do_not_check_regular) class(ps_table_t), intent(inout) :: table class(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_rad, i integer, dimension(:), intent(in) :: pdg type(split_constraints_t), intent(in) :: constraints integer, intent(in), optional :: n_in logical, intent(in), optional :: do_not_check_regular type(pdg_list_t) :: pl_insert logical :: passed integer :: k, s s = size (pdg) call pl_insert%init (s) do k = 1, s call pl_insert%set (k, pdg(k)) end do call constraints%check_before_insert (table, pl%get (i), pl_insert, passed) if (passed) then if (.not. is_colored_isr ()) return call table%split (pl%replace (i, pl_insert, n_in), n_rad + s - 1, & constraints, record = .true., do_not_check_regular = .true.) end if contains logical function is_colored_isr () result (ok) type(pdg_list_t) :: pl_replaced ok = .true. if (present (n_in)) then if (i <= n_in) then ok = pl_insert%contains_colored_particles () if (.not. ok) then pl_replaced = pl%replace (i, pl_insert, n_in) associate (size_replaced => pl_replaced%get_pdg_sizes (), & size => pl%get_pdg_sizes ()) ok = all (size_replaced(:n_in) == size(:n_in)) end associate end if end if end if end function is_colored_isr end subroutine ps_table_insert @ %def ps_table_insert @ Special case: If we are splitting an initial particle, there is slightly more to do. We loop over the particles from the vertex match and replace the initial particle by each of them in turn. The remaining particles must be appended after the second initial particle, so they will end up in the out state. This is done by providing the [[n_in]] argument to the base method as an optional argument. Note that we must call the base-method procedure explicitly, so the [[table]] argument keeps its dynamic type as [[if_table]] inside this procedure. <>= procedure :: insert => if_table_insert <>= recursive subroutine if_table_insert & (table, pl, n_rad, i, pdg, constraints, n_in, do_not_check_regular) class(if_table_t), intent(inout) :: table class(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_rad, i integer, dimension(:), intent(in) :: pdg type(split_constraints_t), intent(in) :: constraints integer, intent(in), optional :: n_in logical, intent(in), optional :: do_not_check_regular integer, dimension(:), allocatable :: pdg_work integer :: p if (i > 2) then call ps_table_insert (table, pl, n_rad, i, pdg, constraints, & do_not_check_regular = do_not_check_regular) else allocate (pdg_work (size (pdg))) do p = 1, size (pdg) pdg_work(1) = pdg(p) pdg_work(2:p) = pdg(1:p-1) pdg_work(p+1:) = pdg(p+1:) select case (table%proc_type) case (PROC_DECAY) call ps_table_insert (table, & pl, n_rad, i, pdg_work, constraints, n_in = 1, & do_not_check_regular = do_not_check_regular) case (PROC_SCATTER) call ps_table_insert (table, & pl, n_rad, i, pdg_work, constraints, n_in = 2, & do_not_check_regular = do_not_check_regular) end select end do end if end subroutine if_table_insert @ %def if_table_insert @ Sort before recording. In the case of the [[if_table]], we do not sort the first [[n_in]] particle entries. Instead, we check whether they are allowed in the [[pl_beam]] PDG list, if that is provided. <>= procedure :: record_sorted => ps_table_record_sorted <>= procedure :: record_sorted => if_table_record_sorted <>= subroutine ps_table_record_sorted & (table, pl, n_loop, n_rad, constraints, do_not_check_regular, passed) class(ps_table_t), intent(inout) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_loop, n_rad type(split_constraints_t), intent(in) :: constraints logical, intent(in), optional :: do_not_check_regular logical, intent(out) :: passed call table%record (pl%sort_abs (), n_loop, n_rad, constraints, & do_not_check_regular, passed) end subroutine ps_table_record_sorted subroutine if_table_record_sorted & (table, pl, n_loop, n_rad, constraints, do_not_check_regular, passed) class(if_table_t), intent(inout) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_loop, n_rad type(split_constraints_t), intent(in) :: constraints logical, intent(in), optional :: do_not_check_regular logical, intent(out) :: passed call table%record (pl%sort_abs (2), n_loop, n_rad, constraints, & do_not_check_regular, passed) end subroutine if_table_record_sorted @ %def ps_table_record_sorted if_table_record_sorted @ Record an entry: insert into the list. Check the ordering and insert it at the correct place, unless it is already there. We record an array only if its mass sum is less than the total available energy. This restriction is removed by setting [[constrained]] to false. <>= procedure :: record => ps_table_record <>= subroutine ps_table_record (table, pl, n_loop, n_rad, constraints, & do_not_check_regular, passed) class(ps_table_t), intent(inout) :: table type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n_loop, n_rad type(split_constraints_t), intent(in) :: constraints logical, intent(in), optional :: do_not_check_regular logical, intent(out) :: passed type(ps_entry_t), pointer :: current logical :: needs_check passed = .false. needs_check = .true. if (present (do_not_check_regular)) needs_check = .not. do_not_check_regular if (needs_check .and. .not. pl%is_regular ()) then call msg_warning ("Record ps_table entry: Irregular pdg-list encountered!") return end if call constraints%check_before_record (table, pl, n_loop, passed) if (.not. passed) then return end if current => table%first do while (associated (current)) if (pl == current) then if (n_loop == current%n_loop) return else if (pl < current) then call insert return end if current => current%next end do call insert contains subroutine insert () type(ps_entry_t), pointer :: entry allocate (entry) entry%pdg_list_t = pl entry%n_loop = n_loop entry%n_rad = n_rad if (associated (current)) then if (associated (current%previous)) then current%previous%next => entry entry%previous => current%previous else table%first => entry end if entry%next => current current%previous => entry else if (associated (table%last)) then table%last%next => entry entry%previous => table%last else table%first => entry end if table%last => entry end if end subroutine insert end subroutine ps_table_record @ %def ps_table_record @ \subsection{Tools} Compute the mass sum for a PDG list object, counting the entries with indices between (including) [[n1]] and [[n2]]. Rely on the requirement that if an entry is a PDG array, this array must be degenerate in mass. <>= function mass_sum (pl, n1, n2, model) result (m) type(pdg_list_t), intent(in) :: pl integer, intent(in) :: n1, n2 class(model_data_t), intent(in), target :: model integer, dimension(:), allocatable :: pdg real(default) :: m type(field_data_t), pointer :: prt integer :: i m = 0 do i = n1, n2 pdg = pl%get (i) prt => model%get_field_ptr (pdg(1)) m = m + prt%get_mass () end do end function mass_sum @ %def mass_sum @ Invert a PDG array, replacing particles by antiparticles. This depends on the model. <>= function invert_pdg_array (pa, model) result (pa_inv) type(pdg_array_t), intent(in) :: pa class(model_data_t), intent(in), target :: model type(pdg_array_t) :: pa_inv type(field_data_t), pointer :: prt integer :: i, pdg pa_inv = pa do i = 1, pa_inv%get_length () pdg = pa_inv%get (i) prt => model%get_field_ptr (pdg) if (prt%has_antiparticle ()) call pa_inv%set (i, -pdg) end do end function invert_pdg_array @ %def invert_pdg_array @ \subsection{Access results} Return the number of generated decays. <>= procedure :: get_length => ps_table_get_length <>= function ps_table_get_length (ps_table) result (n) class(ps_table_t), intent(in) :: ps_table integer :: n type(ps_entry_t), pointer :: entry n = 0 entry => ps_table%first do while (associated (entry)) n = n + 1 entry => entry%next end do end function ps_table_get_length @ %def ps_table_get_length @ <>= procedure :: get_emitters => ps_table_get_emitters <>= subroutine ps_table_get_emitters (table, constraints, emitters) class(ps_table_t), intent(in) :: table type(split_constraints_t), intent(in) :: constraints integer, dimension(:), allocatable, intent(out) :: emitters class(pdg_list_t), pointer :: pl integer :: i logical :: passed type(vertex_iterator_t) :: vit integer, dimension(:), allocatable :: pdg1, pdg2 integer :: n_emitters integer, dimension(:), allocatable :: emitters_tmp integer, parameter :: buf0 = 6 n_emitters = 0 pl => table%first allocate (emitters_tmp (buf0)) do i = 1, pl%get_size () call constraints%check_before_split (table, pl, i, passed) if (passed) then pdg1 = pl%get(i) call vit%init (table%model, pdg1, .false.) do call vit%get_next_match(pdg2) if (allocated (pdg2)) then if (n_emitters + 1 > size (emitters_tmp)) & call extend_integer_array (emitters_tmp, 10) emitters_tmp (n_emitters + 1) = pdg1(1) n_emitters = n_emitters + 1 else exit end if end do end if end do allocate (emitters (n_emitters)) emitters = emitters_tmp (1:n_emitters) deallocate (emitters_tmp) end subroutine ps_table_get_emitters @ %def ps_table_get_emitters @ Return an allocated array of decay products (PDG codes). If requested, return also the loop and radiation order count. <>= procedure :: get_pdg_out => ps_table_get_pdg_out <>= subroutine ps_table_get_pdg_out (ps_table, i, pa_out, n_loop, n_rad) class(ps_table_t), intent(in) :: ps_table integer, intent(in) :: i type(pdg_array_t), dimension(:), allocatable, intent(out) :: pa_out integer, intent(out), optional :: n_loop, n_rad type(ps_entry_t), pointer :: entry integer :: n, j n = 0 entry => ps_table%first FIND_ENTRY: do while (associated (entry)) n = n + 1 if (n == i) then allocate (pa_out (entry%get_size ())) do j = 1, entry%get_size () pa_out(j) = entry%get (j) if (present (n_loop)) n_loop = entry%n_loop if (present (n_rad)) n_rad = entry%n_rad end do exit FIND_ENTRY end if entry => entry%next end do FIND_ENTRY end subroutine ps_table_get_pdg_out @ %def ps_table_get_pdg_out @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[auto_components_ut.f90]]>>= <> module auto_components_ut use unit_tests use auto_components_uti <> <> contains <> end module auto_components_ut @ %def auto_components_ut @ <<[[auto_components_uti.f90]]>>= <> module auto_components_uti <> <> use pdg_arrays use model_data use model_testbed, only: prepare_model, cleanup_model use auto_components <> <> contains <> end module auto_components_uti @ %def auto_components_ut @ API: driver for the unit tests below. <>= public :: auto_components_test <>= subroutine auto_components_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine auto_components_test @ %def auto_components_tests @ \subsubsection{Generate Decay Table} Determine all kinematically allowed decay channels for a Higgs boson, using default parameter values. <>= call test (auto_components_1, "auto_components_1", & "generate decay table", & u, results) <>= public :: auto_components_1 <>= subroutine auto_components_1 (u) integer, intent(in) :: u class(model_data_t), pointer :: model type(field_data_t), pointer :: prt type(ds_table_t) :: ds_table type(split_constraints_t) :: constraints write (u, "(A)") "* Test output: auto_components_1" write (u, "(A)") "* Purpose: determine Higgs decay table" write (u, *) write (u, "(A)") "* Read Standard Model" model => null () call prepare_model (model, var_str ("SM")) prt => model%get_field_ptr (25) write (u, *) write (u, "(A)") "* Higgs decays n = 2" write (u, *) call constraints%init (2) call constraints%set (1, constrain_n_tot (2)) call constraints%set (2, constrain_mass_sum (prt%get_mass ())) call ds_table%make (model, 25, constraints) call ds_table%write (u) call ds_table%final () write (u, *) write (u, "(A)") "* Higgs decays n = 3 (w/o radiative)" write (u, *) call constraints%init (3) call constraints%set (1, constrain_n_tot (3)) call constraints%set (2, constrain_mass_sum (prt%get_mass ())) call constraints%set (3, constrain_radiation ()) call ds_table%make (model, 25, constraints) call ds_table%write (u) call ds_table%final () write (u, *) write (u, "(A)") "* Higgs decays n = 3 (w/ radiative)" write (u, *) call constraints%init (2) call constraints%set (1, constrain_n_tot (3)) call constraints%set (2, constrain_mass_sum (prt%get_mass ())) call ds_table%make (model, 25, constraints) call ds_table%write (u) call ds_table%final () write (u, *) write (u, "(A)") "* Cleanup" call cleanup_model (model) deallocate (model) write (u, *) write (u, "(A)") "* Test output end: auto_components_1" end subroutine auto_components_1 @ %def auto_components_1 @ \subsubsection{Generate radiation} Given a final state, add radiation (NLO and NNLO). We provide a list of particles that is allowed to occur in the generated final states. <>= call test (auto_components_2, "auto_components_2", & "generate NLO corrections, final state", & u, results) <>= public :: auto_components_2 <>= subroutine auto_components_2 (u) integer, intent(in) :: u class(model_data_t), pointer :: model type(pdg_list_t), dimension(:), allocatable :: pl, pl_zzh type(pdg_list_t) :: pl_match type(fs_table_t) :: fs_table type(split_constraints_t) :: constraints real(default) :: sqrts integer :: i write (u, "(A)") "* Test output: auto_components_2" write (u, "(A)") "* Purpose: generate radiation (NLO)" write (u, *) write (u, "(A)") "* Read Standard Model" model => null () call prepare_model (model, var_str ("SM")) write (u, *) write (u, "(A)") "* LO final state" write (u, *) allocate (pl (2)) call pl(1)%init (2) call pl(1)%set (1, 1) call pl(1)%set (2, -1) call pl(2)%init (2) call pl(2)%set (1, 21) call pl(2)%set (2, 21) do i = 1, 2 call pl(i)%write (u); write (u, *) end do write (u, *) write (u, "(A)") "* Initialize FS table" write (u, *) call constraints%init (1) call constraints%set (1, constrain_n_tot (3)) call fs_table%init (model, pl, constraints) call fs_table%write (u) write (u, *) write (u, "(A)") "* Generate NLO corrections, unconstrained" write (u, *) call fs_table%radiate (constraints) call fs_table%write (u) call fs_table%final () write (u, *) write (u, "(A)") "* Generate NLO corrections, & &complete but mass-constrained" write (u, *) sqrts = 50 call constraints%init (2) call constraints%set (1, constrain_n_tot (3)) call constraints%set (2, constrain_mass_sum (sqrts)) call fs_table%init (model, pl, constraints) call fs_table%radiate (constraints) call fs_table%write (u) call fs_table%final () write (u, *) write (u, "(A)") "* Generate NLO corrections, restricted" write (u, *) call pl_match%init ([1, -1, 21]) call constraints%init (2) call constraints%set (1, constrain_n_tot (3)) call constraints%set (2, constrain_insert (pl_match)) call fs_table%init (model, pl, constraints) call fs_table%radiate (constraints) call fs_table%write (u) call fs_table%final () write (u, *) write (u, "(A)") "* Generate NNLO corrections, restricted, with one loop" write (u, *) call pl_match%init ([1, -1, 21]) call constraints%init (3) call constraints%set (1, constrain_n_tot (4)) call constraints%set (2, constrain_n_loop (1)) call constraints%set (3, constrain_insert (pl_match)) call fs_table%init (model, pl, constraints) call fs_table%enable_loops () call fs_table%radiate (constraints) call fs_table%write (u) call fs_table%final () write (u, *) write (u, "(A)") "* Generate NNLO corrections, restricted, with loops" write (u, *) call constraints%init (2) call constraints%set (1, constrain_n_tot (4)) call constraints%set (2, constrain_insert (pl_match)) call fs_table%init (model, pl, constraints) call fs_table%enable_loops () call fs_table%radiate (constraints) call fs_table%write (u) call fs_table%final () write (u, *) write (u, "(A)") "* Generate NNLO corrections, restricted, to Z Z H, & &no loops" write (u, *) allocate (pl_zzh (1)) call pl_zzh(1)%init (3) call pl_zzh(1)%set (1, 23) call pl_zzh(1)%set (2, 23) call pl_zzh(1)%set (3, 25) call constraints%init (3) call constraints%set (1, constrain_n_tot (5)) call constraints%set (2, constrain_mass_sum (500._default)) call constraints%set (3, constrain_require (pl_zzh(1))) call fs_table%init (model, pl_zzh, constraints) call fs_table%radiate (constraints) call fs_table%write (u) call fs_table%final () call cleanup_model (model) deallocate (model) write (u, *) write (u, "(A)") "* Test output end: auto_components_2" end subroutine auto_components_2 @ %def auto_components_2 @ \subsubsection{Generate radiation from initial and final state} Given a process, add radiation (NLO and NNLO). We provide a list of particles that is allowed to occur in the generated final states. <>= call test (auto_components_3, "auto_components_3", & "generate NLO corrections, in and out", & u, results) <>= public :: auto_components_3 <>= subroutine auto_components_3 (u) integer, intent(in) :: u class(model_data_t), pointer :: model type(pdg_list_t), dimension(:), allocatable :: pl_in, pl_out type(pdg_list_t) :: pl_match, pl_beam type(if_table_t) :: if_table type(split_constraints_t) :: constraints real(default) :: sqrts integer :: i write (u, "(A)") "* Test output: auto_components_3" write (u, "(A)") "* Purpose: generate radiation (NLO)" write (u, *) write (u, "(A)") "* Read Standard Model" model => null () call prepare_model (model, var_str ("SM")) write (u, *) write (u, "(A)") "* LO initial state" write (u, *) allocate (pl_in (2)) call pl_in(1)%init (2) call pl_in(1)%set (1, 1) call pl_in(1)%set (2, -1) call pl_in(2)%init (2) call pl_in(2)%set (1, -1) call pl_in(2)%set (2, 1) do i = 1, 2 call pl_in(i)%write (u); write (u, *) end do write (u, *) write (u, "(A)") "* LO final state" write (u, *) allocate (pl_out (1)) call pl_out(1)%init (1) call pl_out(1)%set (1, 23) call pl_out(1)%write (u); write (u, *) write (u, *) write (u, "(A)") "* Initialize FS table" write (u, *) call constraints%init (1) call constraints%set (1, constrain_n_tot (4)) call if_table%init (model, pl_in, pl_out, constraints) call if_table%write (u) write (u, *) write (u, "(A)") "* Generate NLO corrections, unconstrained" write (u, *) call if_table%radiate (constraints) call if_table%write (u) call if_table%final () write (u, *) write (u, "(A)") "* Generate NLO corrections, & &complete but mass-constrained" write (u, *) sqrts = 100 call constraints%init (2) call constraints%set (1, constrain_n_tot (4)) call constraints%set (2, constrain_mass_sum (sqrts)) call if_table%init (model, pl_in, pl_out, constraints) call if_table%radiate (constraints) call if_table%write (u) call if_table%final () write (u, *) write (u, "(A)") "* Generate NLO corrections, & &mass-constrained, restricted beams" write (u, *) call pl_beam%init (3) call pl_beam%set (1, 1) call pl_beam%set (2, -1) call pl_beam%set (3, 21) call constraints%init (3) call constraints%set (1, constrain_n_tot (4)) call constraints%set (2, constrain_in_state (pl_beam)) call constraints%set (3, constrain_mass_sum (sqrts)) call if_table%init (model, pl_in, pl_out, constraints) call if_table%radiate (constraints) call if_table%write (u) call if_table%final () write (u, *) write (u, "(A)") "* Generate NLO corrections, restricted" write (u, *) call pl_match%init ([1, -1, 21]) call constraints%init (4) call constraints%set (1, constrain_n_tot (4)) call constraints%set (2, constrain_in_state (pl_beam)) call constraints%set (3, constrain_mass_sum (sqrts)) call constraints%set (4, constrain_insert (pl_match)) call if_table%init (model, pl_in, pl_out, constraints) call if_table%radiate (constraints) call if_table%write (u) call if_table%final () write (u, *) write (u, "(A)") "* Generate NNLO corrections, restricted, Z preserved, & &with loops" write (u, *) call constraints%init (5) call constraints%set (1, constrain_n_tot (5)) call constraints%set (2, constrain_in_state (pl_beam)) call constraints%set (3, constrain_mass_sum (sqrts)) call constraints%set (4, constrain_insert (pl_match)) call constraints%set (5, constrain_require (pl_out(1))) call if_table%init (model, pl_in, pl_out, constraints) call if_table%enable_loops () call if_table%radiate (constraints) call if_table%write (u) call if_table%final () call cleanup_model (model) deallocate (model) write (u, *) write (u, "(A)") "* Test output end: auto_components_3" end subroutine auto_components_3 @ %def auto_components_3 @ %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Creating the real flavor structure} <<[[radiation_generator.f90]]>>= <> module radiation_generator <> <> use diagnostics use io_units use physics_defs, only: PHOTON, GLUON use pdg_arrays use flavors use model_data use auto_components use string_utils, only: split_string, string_contains_word implicit none private <> <> contains <> end module radiation_generator @ %def radiation_generator @ <>= type :: pdg_sorter_t integer :: pdg logical :: checked = .false. integer :: associated_born = 0 end type pdg_sorter_t @ %def pdg_sorter @ <>= type :: pdg_states_t type(pdg_array_t), dimension(:), allocatable :: pdg type(pdg_states_t), pointer :: next integer :: n_particles contains <> end type pdg_states_t @ %def pdg_states_t <>= procedure :: init => pdg_states_init <>= subroutine pdg_states_init (states) class(pdg_states_t), intent(inout) :: states nullify (states%next) end subroutine pdg_states_init @ %def pdg_states_init @ <>= procedure :: add => pdg_states_add <>= subroutine pdg_states_add (states, pdg) class(pdg_states_t), intent(inout), target :: states type(pdg_array_t), dimension(:), intent(in) :: pdg type(pdg_states_t), pointer :: current_state select type (states) type is (pdg_states_t) current_state => states do if (associated (current_state%next)) then current_state => current_state%next else allocate (current_state%next) nullify(current_state%next%next) current_state%pdg = pdg exit end if end do end select end subroutine pdg_states_add @ %def pdg_states_add @ <>= procedure :: get_n_states => pdg_states_get_n_states <>= function pdg_states_get_n_states (states) result (n) class(pdg_states_t), intent(in), target :: states integer :: n type(pdg_states_t), pointer :: current_state n = 0 select type(states) type is (pdg_states_t) current_state => states do if (associated (current_state%next)) then n = n+1 current_state => current_state%next else exit end if end do end select end function pdg_states_get_n_states @ %def pdg_states_get_n_states @ <>= type :: prt_queue_t type(string_t), dimension(:), allocatable :: prt_string type(prt_queue_t), pointer :: next => null () type(prt_queue_t), pointer :: previous => null () type(prt_queue_t), pointer :: front => null () type(prt_queue_t), pointer :: current_prt => null () type(prt_queue_t), pointer :: back => null () integer :: n_lists = 0 contains <> end type prt_queue_t @ %def prt_queue_t @ <>= procedure :: null => prt_queue_null <>= subroutine prt_queue_null (queue) class(prt_queue_t), intent(out) :: queue queue%next => null () queue%previous => null () queue%front => null () queue%current_prt => null () queue%back => null () queue%n_lists = 0 if (allocated (queue%prt_string)) deallocate (queue%prt_string) end subroutine prt_queue_null @ %def prt_queue_null @ <>= procedure :: append => prt_queue_append <>= subroutine prt_queue_append (queue, prt_string) class(prt_queue_t), intent(inout) :: queue type(string_t), intent(in), dimension(:) :: prt_string type(prt_queue_t), pointer :: new_element => null () type(prt_queue_t), pointer :: current_back => null () allocate (new_element) allocate (new_element%prt_string(size (prt_string))) new_element%prt_string = prt_string if (associated (queue%back)) then current_back => queue%back current_back%next => new_element new_element%previous => current_back queue%back => new_element else !!! Initial entry queue%front => new_element queue%back => queue%front queue%current_prt => queue%front end if queue%n_lists = queue%n_lists + 1 end subroutine prt_queue_append @ %def prt_queue_append @ [[gfortran 4.7.4]] does not support allocate-on-assignment for the caller when this is a function. <>= procedure :: get => prt_queue_get <>= subroutine prt_queue_get (queue, prt_string) class(prt_queue_t), intent(inout) :: queue type(string_t), dimension(:), allocatable, intent(out) :: prt_string if (associated (queue%current_prt)) then allocate (prt_string(size (queue%current_prt%prt_string))) prt_string = queue%current_prt%prt_string if (associated (queue%current_prt%next)) & queue%current_prt => queue%current_prt%next else prt_string = " " end if end subroutine prt_queue_get @ %def prt_queue_get @ As above. <>= procedure :: get_last => prt_queue_get_last <>= subroutine prt_queue_get_last (queue, prt_string) class(prt_queue_t), intent(in) :: queue type(string_t), dimension(:), allocatable, intent(out) :: prt_string if (associated (queue%back)) then allocate (prt_string(size (queue%back%prt_string))) prt_string = queue%back%prt_string else prt_string = " " end if end subroutine prt_queue_get_last @ %def prt_queue_get_last @ <>= procedure :: reset => prt_queue_reset <>= subroutine prt_queue_reset (queue) class(prt_queue_t), intent(inout) :: queue queue%current_prt => queue%front end subroutine prt_queue_reset @ %def prt_queue_reset @ <>= procedure :: check_for_same_prt_strings => prt_queue_check_for_same_prt_strings <>= function prt_queue_check_for_same_prt_strings (queue) result (val) class(prt_queue_t), intent(inout) :: queue logical :: val type(string_t), dimension(:), allocatable :: prt_string integer, dimension(:,:), allocatable :: i_particle integer :: n_d, n_dbar, n_u, n_ubar, n_s, n_sbar, n_gl, n_e, n_ep, n_mu, n_mup, n_A integer :: i, j call queue%reset () allocate (i_particle (queue%n_lists, 12)) do i = 1, queue%n_lists call queue%get (prt_string) n_d = count_particle (prt_string, 1) n_dbar = count_particle (prt_string, -1) n_u = count_particle (prt_string, 2) n_ubar = count_particle (prt_string, -2) n_s = count_particle (prt_string, 3) n_sbar = count_particle (prt_string, -3) n_gl = count_particle (prt_string, 21) n_e = count_particle (prt_string, 11) n_ep = count_particle (prt_string, -11) n_mu = count_particle (prt_string, 13) n_mup = count_particle (prt_string, -13) n_A = count_particle (prt_string, 22) i_particle (i, 1) = n_d i_particle (i, 2) = n_dbar i_particle (i, 3) = n_u i_particle (i, 4) = n_ubar i_particle (i, 5) = n_s i_particle (i, 6) = n_sbar i_particle (i, 7) = n_gl i_particle (i, 8) = n_e i_particle (i, 9) = n_ep i_particle (i, 10) = n_mu i_particle (i, 11) = n_mup i_particle (i, 12) = n_A end do val = .false. do i = 1, queue%n_lists do j = 1, queue%n_lists if (i == j) cycle val = val .or. all (i_particle (i,:) == i_particle(j,:)) end do end do contains function count_particle (prt_string, pdg) result (n) type(string_t), dimension(:), intent(in) :: prt_string integer, intent(in) :: pdg integer :: n integer :: i type(string_t) :: prt_ref n = 0 select case (pdg) case (1) prt_ref = "d" case (-1) prt_ref = "dbar" case (2) prt_ref = "u" case (-2) prt_ref = "ubar" case (3) prt_ref = "s" case (-3) prt_ref = "sbar" case (21) prt_ref = "gl" case (11) prt_ref = "e-" case (-11) prt_ref = "e+" case (13) prt_ref = "mu-" case (-13) prt_ref = "mu+" case (22) prt_ref = "A" end select do i = 1, size (prt_string) if (prt_string(i) == prt_ref) n = n+1 end do end function count_particle end function prt_queue_check_for_same_prt_strings @ %def prt_queue_check_for_same_prt_strings @ <>= procedure :: contains => prt_queue_contains <>= function prt_queue_contains (queue, prt_string) result (val) class(prt_queue_t), intent(in) :: queue type(string_t), intent(in), dimension(:) :: prt_string logical :: val type(prt_queue_t), pointer :: current => null() if (associated (queue%front)) then current => queue%front else call msg_fatal ("Trying to access empty particle queue") end if val = .false. do if (size (current%prt_string) == size (prt_string)) then if (all (current%prt_string == prt_string)) then val = .true. exit end if end if if (associated (current%next)) then current => current%next else exit end if end do end function prt_queue_contains @ %def prt_string_list_contains @ <>= procedure :: write => prt_queue_write <>= subroutine prt_queue_write (queue, unit) class(prt_queue_t), intent(in) :: queue integer, optional :: unit type(prt_queue_t), pointer :: current => null () integer :: i, j, u u = given_output_unit (unit) if (associated (queue%front)) then current => queue%front else write (u, "(A)") "[Particle queue is empty]" return end if j = 1 do write (u, "(I2,A,1X)", advance = 'no') j , ":" do i = 1, size (current%prt_string) write (u, "(A,1X)", advance = 'no') char (current%prt_string(i)) end do write (u, "(A)") if (associated (current%next)) then current => current%next j = j+1 else exit end if end do end subroutine prt_queue_write @ %def prt_queue_write @ <>= subroutine sort_prt (prt, model) type(string_t), dimension(:), intent(inout) :: prt class(model_data_t), intent(in), target :: model type(pdg_array_t), dimension(:), allocatable :: pdg type(flavor_t) :: flv integer :: i call create_pdg_array (prt, model, pdg) call sort_pdg (pdg) do i = 1, size (pdg) call flv%init (pdg(i)%get(), model) prt(i) = flv%get_name () end do end subroutine sort_prt subroutine sort_pdg (pdg) type(pdg_array_t), dimension(:), intent(inout) :: pdg integer, dimension(:), allocatable :: i_pdg integer :: i allocate (i_pdg (size (pdg))) do i = 1, size (pdg) i_pdg(i) = pdg(i)%get () end do i_pdg = sort_abs (i_pdg) do i = 1, size (pdg) call pdg(i)%set (1, i_pdg(i)) end do end subroutine sort_pdg subroutine create_pdg_array (prt, model, pdg) type (string_t), dimension(:), intent(in) :: prt class (model_data_t), intent(in), target :: model type(pdg_array_t), dimension(:), allocatable, intent(out) :: pdg type(flavor_t) :: flv integer :: i allocate (pdg (size (prt))) do i = 1, size (prt) call flv%init (prt(i), model) pdg(i) = flv%get_pdg () end do end subroutine create_pdg_array @ %def sort_prt sort_pdg create_pdg_array @ This is used in unit tests: <>= subroutine write_pdg_array (pdg, u) use pdg_arrays type(pdg_array_t), dimension(:), intent(in) :: pdg integer, intent(in) :: u integer :: i do i = 1, size (pdg) call pdg(i)%write (u) end do write (u, "(A)") end subroutine write_pdg_array subroutine write_particle_string (prt, u) <> type(string_t), dimension(:), intent(in) :: prt integer, intent(in) :: u integer :: i do i = 1, size (prt) write (u, "(A,1X)", advance = "no") char (prt(i)) end do write (u, "(A)") end subroutine write_particle_string @ %def write_pdg_array write_particle_string <>= type :: reshuffle_list_t integer, dimension(:), allocatable :: ii type(reshuffle_list_t), pointer :: next => null () contains <> end type reshuffle_list_t @ %def reshuffle_list_t @ <>= procedure :: write => reshuffle_list_write <>= subroutine reshuffle_list_write (rlist) class(reshuffle_list_t), intent(in) :: rlist type(reshuffle_list_t), pointer :: current => null () integer :: i print *, 'Content of reshuffling list: ' if (associated (rlist%next)) then current => rlist%next i = 1 do print *, 'i: ', i, 'list: ', current%ii i = i + 1 if (associated (current%next)) then current => current%next else exit end if end do else print *, '[EMPTY]' end if end subroutine reshuffle_list_write @ %def reshuffle_list_write @ <>= procedure :: append => reshuffle_list_append <>= subroutine reshuffle_list_append (rlist, ii) class(reshuffle_list_t), intent(inout) :: rlist integer, dimension(:), allocatable, intent(in) :: ii type(reshuffle_list_t), pointer :: current if (associated (rlist%next)) then current => rlist%next do if (associated (current%next)) then current => current%next else allocate (current%next) allocate (current%next%ii (size (ii))) current%next%ii = ii exit end if end do else allocate (rlist%next) allocate (rlist%next%ii (size (ii))) rlist%next%ii = ii end if end subroutine reshuffle_list_append @ %def reshuffle_list_append @ <>= procedure :: is_empty => reshuffle_list_is_empty <>= elemental function reshuffle_list_is_empty (rlist) result (is_empty) logical :: is_empty class(reshuffle_list_t), intent(in) :: rlist is_empty = .not. associated (rlist%next) end function reshuffle_list_is_empty @ %def reshuffle_list_is_empty @ <>= procedure :: get => reshuffle_list_get <>= function reshuffle_list_get (rlist, index) result (ii) integer, dimension(:), allocatable :: ii class(reshuffle_list_t), intent(inout) :: rlist integer, intent(in) :: index type(reshuffle_list_t), pointer :: current => null () integer :: i current => rlist%next do i = 1, index - 1 if (associated (current%next)) then current => current%next else call msg_fatal ("Index exceeds size of reshuffling list") end if end do allocate (ii (size (current%ii))) ii = current%ii end function reshuffle_list_get @ %def reshuffle_list_get @ We need to reset the [[reshuffle_list]] in order to deal with subsequent usages of the [[radiation_generator]]. Below is obviously the lazy and dirty solution. Otherwise, we would have to equip this auxiliary type with additional information about [[last]] and [[previous]] pointers. Considering that at most $n_{\rm{legs}}$ integers are saved in the lists, and that the subroutine is only called during the initialization phase (more precisely: at the moment only in the [[radiation_generator]] unit tests), I think this quick fix is justified. <>= procedure :: reset => reshuffle_list_reset <>= subroutine reshuffle_list_reset (rlist) class(reshuffle_list_t), intent(inout) :: rlist rlist%next => null () end subroutine reshuffle_list_reset @ %def reshuffle_list_reset @ <>= public :: radiation_generator_t <>= type :: radiation_generator_t logical :: qcd_enabled = .false. logical :: qed_enabled = .false. logical :: is_gluon = .false. logical :: fs_gluon = .false. logical :: is_photon = .false. logical :: fs_photon = .false. logical :: only_final_state = .true. type(pdg_list_t) :: pl_in, pl_out type(pdg_list_t) :: pl_excluded_gauge_splittings type(split_constraints_t) :: constraints integer :: n_tot integer :: n_in, n_out integer :: n_loops integer :: n_light_quarks real(default) :: mass_sum type(prt_queue_t) :: prt_queue type(pdg_states_t) :: pdg_raw type(pdg_array_t), dimension(:), allocatable :: pdg_in_born, pdg_out_born type(if_table_t) :: if_table type(reshuffle_list_t) :: reshuffle_list contains <> end type radiation_generator_t @ @ %def radiation_generator_t <>= generic :: init => init_pdg_list, init_pdg_array procedure :: init_pdg_list => radiation_generator_init_pdg_list procedure :: init_pdg_array => radiation_generator_init_pdg_array <>= subroutine radiation_generator_init_pdg_list & (generator, pl_in, pl_out, pl_excluded_gauge_splittings, qcd, qed) class(radiation_generator_t), intent(inout) :: generator type(pdg_list_t), intent(in) :: pl_in, pl_out type(pdg_list_t), intent(in) :: pl_excluded_gauge_splittings logical, intent(in), optional :: qcd, qed if (present (qcd)) generator%qcd_enabled = qcd if (present (qed)) generator%qed_enabled = qed generator%pl_in = pl_in generator%pl_out = pl_out generator%pl_excluded_gauge_splittings = pl_excluded_gauge_splittings generator%is_gluon = pl_in%search_for_particle (GLUON) generator%fs_gluon = pl_out%search_for_particle (GLUON) generator%is_photon = pl_in%search_for_particle (PHOTON) generator%fs_photon = pl_out%search_for_particle (PHOTON) generator%mass_sum = 0._default call generator%pdg_raw%init () end subroutine radiation_generator_init_pdg_list subroutine radiation_generator_init_pdg_array & (generator, pdg_in, pdg_out, pdg_excluded_gauge_splittings, qcd, qed) class(radiation_generator_t), intent(inout) :: generator type(pdg_array_t), intent(in), dimension(:) :: pdg_in, pdg_out type(pdg_array_t), intent(in), dimension(:) :: pdg_excluded_gauge_splittings logical, intent(in), optional :: qcd, qed type(pdg_list_t) :: pl_in, pl_out type(pdg_list_t) :: pl_excluded_gauge_splittings integer :: i call pl_in%init(size (pdg_in)) call pl_out%init(size (pdg_out)) do i = 1, size (pdg_in) call pl_in%set (i, pdg_in(i)) end do do i = 1, size (pdg_out) call pl_out%set (i, pdg_out(i)) end do call pl_excluded_gauge_splittings%init(size (pdg_excluded_gauge_splittings)) do i = 1, size (pdg_excluded_gauge_splittings) call pl_excluded_gauge_splittings%set & (i, pdg_excluded_gauge_splittings(i)) end do call generator%init (pl_in, pl_out, pl_excluded_gauge_splittings, qcd, qed) end subroutine radiation_generator_init_pdg_array @ %def radiation_generator_init_pdg_list radiation_generator_init_pdg_array @ <>= procedure :: set_initial_state_emissions => & radiation_generator_set_initial_state_emissions <>= subroutine radiation_generator_set_initial_state_emissions (generator) class(radiation_generator_t), intent(inout) :: generator generator%only_final_state = .false. end subroutine radiation_generator_set_initial_state_emissions @ %def radiation_generator_set_initial_state_emissions @ <>= procedure :: setup_if_table => radiation_generator_setup_if_table <>= subroutine radiation_generator_setup_if_table (generator, model) class(radiation_generator_t), intent(inout) :: generator class(model_data_t), intent(in), target :: model type(pdg_list_t), dimension(:), allocatable :: pl_in, pl_out allocate (pl_in(1), pl_out(1)) pl_in(1) = generator%pl_in pl_out(1) = generator%pl_out call generator%if_table%init & (model, pl_in, pl_out, generator%constraints) end subroutine radiation_generator_setup_if_table @ %def radiation_generator_setup_if_table @ <>= generic :: reset_particle_content => reset_particle_content_pdg_array, & reset_particle_content_pdg_list procedure :: reset_particle_content_pdg_list => & radiation_generator_reset_particle_content_pdg_list procedure :: reset_particle_content_pdg_array => & radiation_generator_reset_particle_content_pdg_array <>= subroutine radiation_generator_reset_particle_content_pdg_list (generator, pl) class(radiation_generator_t), intent(inout) :: generator type(pdg_list_t), intent(in) :: pl generator%pl_out = pl generator%fs_gluon = pl%search_for_particle (GLUON) generator%fs_photon = pl%search_for_particle (PHOTON) end subroutine radiation_generator_reset_particle_content_pdg_list subroutine radiation_generator_reset_particle_content_pdg_array (generator, pdg) class(radiation_generator_t), intent(inout) :: generator type(pdg_array_t), intent(in), dimension(:) :: pdg type(pdg_list_t) :: pl integer :: i call pl%init (size (pdg)) do i = 1, size (pdg) call pl%set (i, pdg(i)) end do call generator%reset_particle_content (pl) end subroutine radiation_generator_reset_particle_content_pdg_array @ %def radiation_generator_reset_particle_content @ <>= procedure :: reset_reshuffle_list=> radiation_generator_reset_reshuffle_list <>= subroutine radiation_generator_reset_reshuffle_list (generator) class(radiation_generator_t), intent(inout) :: generator call generator%reshuffle_list%reset () end subroutine radiation_generator_reset_reshuffle_list @ %def radiation_generator_reset_reshuffle_list @ <>= procedure :: set_n => radiation_generator_set_n <>= subroutine radiation_generator_set_n (generator, n_in, n_out, n_loops) class(radiation_generator_t), intent(inout) :: generator integer, intent(in) :: n_in, n_out, n_loops generator%n_tot = n_in + n_out + 1 generator%n_in = n_in generator%n_out = n_out generator%n_loops = n_loops end subroutine radiation_generator_set_n @ %def radiation_generator_set_n @ <>= procedure :: set_constraints => radiation_generator_set_constraints <>= subroutine radiation_generator_set_constraints & (generator, set_n_loop, set_mass_sum, & set_selected_particles, set_required_particles) class(radiation_generator_t), intent(inout), target :: generator logical, intent(in) :: set_n_loop logical, intent(in) :: set_mass_sum logical, intent(in) :: set_selected_particles logical, intent(in) :: set_required_particles logical :: set_no_photon_induced = .true. integer :: i, j, n, n_constraints type(pdg_list_t) :: pl_req, pl_insert type(pdg_list_t) :: pl_antiparticles type(pdg_array_t) :: pdg_gluon, pdg_photon type(pdg_array_t) :: pdg_add, pdg_tmp integer :: last_index integer :: n_new_particles, n_skip integer, dimension(:), allocatable :: i_skip integer :: n_nlo_correction_types n_nlo_correction_types = count ([generator%qcd_enabled, generator%qed_enabled]) if (generator%is_photon) set_no_photon_induced = .false. allocate (i_skip (generator%n_tot)) i_skip = -1 n_constraints = 2 + count([set_n_loop, set_mass_sum, & set_selected_particles, set_required_particles, set_no_photon_induced]) associate (constraints => generator%constraints) n = 1 call constraints%init (n_constraints) call constraints%set (n, constrain_n_tot (generator%n_tot)) n = 2 call constraints%set (n, constrain_couplings (generator%qcd_enabled, & generator%qed_enabled, n_nlo_correction_types)) n = n + 1 if (set_no_photon_induced) then call constraints%set (n, constrain_photon_induced_processes (generator%n_in)) n = n + 1 end if if (set_n_loop) then call constraints%set (n, constrain_n_loop(generator%n_loops)) n = n + 1 end if if (set_mass_sum) then call constraints%set (n, constrain_mass_sum(generator%mass_sum)) n = n + 1 end if if (set_required_particles) then if (generator%fs_gluon .or. generator%fs_photon) then do i = 1, generator%n_out pdg_tmp = generator%pl_out%get(i) if (pdg_tmp%search_for_particle (GLUON) & .or. pdg_tmp%search_for_particle (PHOTON)) then i_skip(i) = i end if end do n_skip = count (i_skip > 0) call pl_req%init (generator%n_out-n_skip) else call pl_req%init (generator%n_out) end if j = 1 do i = 1, generator%n_out if (any (i == i_skip)) cycle call pl_req%set (j, generator%pl_out%get(i)) j = j + 1 end do call constraints%set (n, constrain_require (pl_req)) n = n + 1 end if if (set_selected_particles) then if (generator%only_final_state ) then call pl_insert%init (generator%n_out + n_nlo_correction_types) do i = 1, generator%n_out call pl_insert%set(i, generator%pl_out%get(i)) end do last_index = generator%n_out + 1 else call generator%pl_in%create_antiparticles (pl_antiparticles, n_new_particles) call pl_insert%init (generator%n_tot + n_new_particles & + n_nlo_correction_types) do i = 1, generator%n_in call pl_insert%set(i, generator%pl_in%get(i)) end do do i = 1, generator%n_out j = i + generator%n_in call pl_insert%set(j, generator%pl_out%get(i)) end do do i = 1, n_new_particles j = i + generator%n_in + generator%n_out call pl_insert%set(j, pl_antiparticles%get(i)) end do last_index = generator%n_tot + n_new_particles + 1 end if pdg_gluon = GLUON; pdg_photon = PHOTON if (generator%qcd_enabled) then pdg_add = pdg_gluon call pl_insert%set (last_index, pdg_add) last_index = last_index + 1 end if if (generator%qed_enabled) then pdg_add = pdg_photon call pl_insert%set (last_index, pdg_add) end if call constraints%set (n, constrain_splittings (pl_insert, & generator%pl_excluded_gauge_splittings)) end if end associate end subroutine radiation_generator_set_constraints @ %def radiation_generator_set_constraints @ <>= procedure :: find_splittings => radiation_generator_find_splittings <>= subroutine radiation_generator_find_splittings (generator) class(radiation_generator_t), intent(inout) :: generator integer :: i type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out, pdg_tmp integer, dimension(:), allocatable :: reshuffle_list call generator%pl_in%create_pdg_array (pdg_in) call generator%pl_out%create_pdg_array (pdg_out) associate (if_table => generator%if_table) call if_table%radiate (generator%constraints, do_not_check_regular = .true.) do i = 1, if_table%get_length () call if_table%get_pdg_out (i, pdg_tmp) if (size (pdg_tmp) == generator%n_tot) then call pdg_reshuffle (pdg_out, pdg_tmp, reshuffle_list) call generator%reshuffle_list%append (reshuffle_list) end if end do end associate contains subroutine pdg_reshuffle (pdg_born, pdg_real, list) type(pdg_array_t), intent(in), dimension(:) :: pdg_born, pdg_real integer, intent(out), dimension(:), allocatable :: list type(pdg_sorter_t), dimension(:), allocatable :: sort_born type(pdg_sorter_t), dimension(:), allocatable :: sort_real integer :: i_min, n_in, n_born, n_real integer :: ib, ir n_in = generator%n_in n_born = size (pdg_born) n_real = size (pdg_real) allocate (list (n_real - n_in)) allocate (sort_born (n_born)) allocate (sort_real (n_real - n_in)) sort_born%pdg = pdg_born%get () sort_real%pdg = pdg_real(n_in + 1 : n_real)%get() do ib = 1, n_born if (any (sort_born(ib)%pdg == sort_real%pdg)) & call associate_born_indices (sort_born(ib), sort_real, ib, n_real) end do i_min = maxval (sort_real%associated_born) + 1 do ir = 1, n_real - n_in if (sort_real(ir)%associated_born == 0) then sort_real(ir)%associated_born = i_min i_min = i_min + 1 end if end do list = sort_real%associated_born end subroutine pdg_reshuffle subroutine associate_born_indices (sort_born, sort_real, ib, n_real) type(pdg_sorter_t), intent(in) :: sort_born type(pdg_sorter_t), intent(inout), dimension(:) :: sort_real integer, intent(in) :: ib, n_real integer :: ir do ir = 1, n_real - generator%n_in if (sort_born%pdg == sort_real(ir)%pdg & .and..not. sort_real(ir)%checked) then sort_real(ir)%associated_born = ib sort_real(ir)%checked = .true. exit end if end do end subroutine associate_born_indices end subroutine radiation_generator_find_splittings @ %def radiation_generator_find_splittings @ <>= procedure :: generate_real_particle_strings & => radiation_generator_generate_real_particle_strings <>= subroutine radiation_generator_generate_real_particle_strings & (generator, prt_tot_in, prt_tot_out) type :: prt_array_t type(string_t), dimension(:), allocatable :: prt end type integer, parameter :: n_flv_max = 10 class(radiation_generator_t), intent(inout) :: generator type(string_t), intent(out), dimension(:), allocatable :: prt_tot_in, prt_tot_out type(prt_array_t), dimension(n_flv_max) :: prt_in, prt_out type(prt_array_t), dimension(n_flv_max) :: prt_out0, prt_in0 type(pdg_array_t), dimension(:), allocatable :: pdg_tmp, pdg_out, pdg_in type(pdg_list_t), dimension(:), allocatable :: pl_in, pl_out integer :: i, j integer, dimension(:), allocatable :: reshuffle_list_local type(reshuffle_list_t) :: reshuffle_list integer :: flv type(string_t), dimension(:), allocatable :: buf integer :: i_buf flv = 0 associate (if_table => generator%if_table) do i = 1, if_table%get_length () call if_table%get_pdg_out (i, pdg_tmp) if (size (pdg_tmp) == generator%n_tot) then call if_table%get_particle_string (i, & prt_in0(flv + 1)%prt, prt_out0(flv + 1)%prt) flv = flv + 1 end if end do end associate do i = 1, flv allocate (prt_in(i)%prt (generator%n_in)) allocate (prt_out(i)%prt (generator%n_tot - generator%n_in)) end do allocate (prt_tot_in (generator%n_in)) allocate (prt_tot_out (generator%n_tot - generator%n_in)) allocate (buf (generator%n_tot)) buf = "" do j = 1, flv do i = 1, generator%n_in prt_in(j)%prt(i) = prt_in0(j)%prt(i) call fill_buffer (buf(i), prt_in0(j)%prt(i)) end do end do prt_tot_in = buf(1 : generator%n_in) do j = 1, flv allocate (reshuffle_list_local (size (generator%reshuffle_list%get(j)))) reshuffle_list_local = generator%reshuffle_list%get(j) do i = 1, size (reshuffle_list_local) prt_out(j)%prt(reshuffle_list_local(i)) = prt_out0(j)%prt(i) i_buf = reshuffle_list_local(i) + generator%n_in call fill_buffer (buf(i_buf), & prt_out(j)%prt(reshuffle_list_local(i))) end do !!! Need to deallocate here because in the next iteration the reshuffling !!! list can have a different size deallocate (reshuffle_list_local) end do prt_tot_out = buf(generator%n_in + 1 : generator%n_tot) if (debug2_active (D_CORE)) then print *, 'Generated initial state: ' do i = 1, size (prt_tot_in) print *, char (prt_tot_in(i)) end do print *, 'Generated final state: ' do i = 1, size (prt_tot_out) print *, char (prt_tot_out(i)) end do end if contains subroutine fill_buffer (buffer, particle) type(string_t), intent(inout) :: buffer type(string_t), intent(in) :: particle logical :: particle_present if (len (buffer) > 0) then particle_present = check_for_substring (char(buffer), particle) if (.not. particle_present) buffer = buffer // ":" // particle else buffer = buffer // particle end if end subroutine fill_buffer function check_for_substring (buffer, substring) result (exist) character(len=*), intent(in) :: buffer type(string_t), intent(in) :: substring character(len=50) :: buffer_internal logical :: exist integer :: i_first, i_last exist = .false. i_first = 1; i_last = 1 do if (buffer(i_last:i_last) == ":") then buffer_internal = buffer (i_first : i_last - 1) if (buffer_internal == char (substring)) then exist = .true. exit end if i_first = i_last + 1; i_last = i_first + 1 if (i_last > len(buffer)) exit else if (i_last == len(buffer)) then buffer_internal = buffer (i_first : i_last) exist = buffer_internal == char (substring) exit else i_last = i_last + 1 if (i_last > len(buffer)) exit end if end do end function check_for_substring end subroutine radiation_generator_generate_real_particle_strings @ %def radiation_generator_generate_real_particle_strings @ <>= procedure :: contains_emissions => radiation_generator_contains_emissions <>= function radiation_generator_contains_emissions (generator) result (has_em) logical :: has_em class(radiation_generator_t), intent(in) :: generator has_em = .not. generator%reshuffle_list%is_empty () end function radiation_generator_contains_emissions @ %def radiation_generator_contains_emissions @ <>= procedure :: generate => radiation_generator_generate <>= subroutine radiation_generator_generate (generator, prt_in, prt_out) class(radiation_generator_t), intent(inout) :: generator type(string_t), intent(out), dimension(:), allocatable :: prt_in, prt_out call generator%find_splittings () call generator%generate_real_particle_strings (prt_in, prt_out) end subroutine radiation_generator_generate @ %def radiation_generator_generate @ <>= procedure :: generate_multiple => radiation_generator_generate_multiple <>= subroutine radiation_generator_generate_multiple (generator, max_multiplicity, model) class(radiation_generator_t), intent(inout) :: generator integer, intent(in) :: max_multiplicity class(model_data_t), intent(in), target :: model if (max_multiplicity <= generator%n_out) & call msg_fatal ("GKS states: Multiplicity is not large enough!") call generator%first_emission (model) call generator%reset_reshuffle_list () if (max_multiplicity - generator%n_out > 1) & call generator%append_emissions (max_multiplicity, model) end subroutine radiation_generator_generate_multiple @ %def radiation_generator_generate_multiple @ <>= procedure :: first_emission => radiation_generator_first_emission <>= subroutine radiation_generator_first_emission (generator, model) class(radiation_generator_t), intent(inout) :: generator class(model_data_t), intent(in), target :: model type(string_t), dimension(:), allocatable :: prt_in, prt_out call generator%setup_if_table (model) call generator%generate (prt_in, prt_out) call generator%prt_queue%null () call generator%prt_queue%append (prt_out) end subroutine radiation_generator_first_emission @ %def radiation_generator_first_emission @ <>= procedure :: append_emissions => radiation_generator_append_emissions <>= subroutine radiation_generator_append_emissions (generator, max_multiplicity, model) class(radiation_generator_t), intent(inout) :: generator integer, intent(in) :: max_multiplicity class(model_data_t), intent(in), target :: model type(string_t), dimension(:), allocatable :: prt_fetched type(string_t), dimension(:), allocatable :: prt_in type(string_t), dimension(:), allocatable :: prt_out type(pdg_array_t), dimension(:), allocatable :: pdg_new_out integer :: current_multiplicity, i, j, n_longest_length type :: prt_table_t type(string_t), dimension(:), allocatable :: prt end type prt_table_t type(prt_table_t), dimension(:), allocatable :: prt_table_out do call generator%prt_queue%get (prt_fetched) current_multiplicity = size (prt_fetched) if (current_multiplicity == max_multiplicity) exit call create_pdg_array (prt_fetched, model, & pdg_new_out) call generator%reset_particle_content (pdg_new_out) call generator%set_n (2, current_multiplicity, 0) call generator%set_constraints (.false., .false., .true., .true.) call generator%setup_if_table (model) call generator%generate (prt_in, prt_out) n_longest_length = get_length_of_longest_tuple (prt_out) call separate_particles (prt_out, prt_table_out) do i = 1, n_longest_length if (.not. any (prt_table_out(i)%prt == " ")) then call sort_prt (prt_table_out(i)%prt, model) if (.not. generator%prt_queue%contains (prt_table_out(i)%prt)) then call generator%prt_queue%append (prt_table_out(i)%prt) end if end if end do call generator%reset_reshuffle_list () end do contains subroutine separate_particles (prt, prt_table) type(string_t), intent(in), dimension(:) :: prt type(string_t), dimension(:), allocatable :: prt_tmp type(prt_table_t), intent(out), dimension(:), allocatable :: prt_table integer :: i, j logical, dimension(:), allocatable :: tuples_occured allocate (prt_table (n_longest_length)) do i = 1, n_longest_length allocate (prt_table(i)%prt (size (prt))) end do allocate (tuples_occured (size (prt))) do j = 1, size (prt) call split_string (prt(j), var_str (":"), prt_tmp) do i = 1, n_longest_length if (i <= size (prt_tmp)) then prt_table(i)%prt(j) = prt_tmp(i) else prt_table(i)%prt(j) = " " end if end do if (n_longest_length > 1) & tuples_occured(j) = prt_table(1)%prt(j) /= " " & .and. prt_table(2)%prt(j) /= " " end do if (any (tuples_occured)) then do j = 1, size (tuples_occured) if (.not. tuples_occured(j)) then do i = 2, n_longest_length prt_table(i)%prt(j) = prt_table(1)%prt(j) end do end if end do end if end subroutine separate_particles function get_length_of_longest_tuple (prt) result (longest_length) type(string_t), intent(in), dimension(:) :: prt integer :: longest_length, i type(prt_table_t), dimension(:), allocatable :: prt_table allocate (prt_table (size (prt))) longest_length = 0 do i = 1, size (prt) call split_string (prt(i), var_str (":"), prt_table(i)%prt) if (size (prt_table(i)%prt) > longest_length) & longest_length = size (prt_table(i)%prt) end do end function get_length_of_longest_tuple end subroutine radiation_generator_append_emissions @ %def radiation_generator_append_emissions @ <>= procedure :: reset_queue => radiation_generator_reset_queue <>= subroutine radiation_generator_reset_queue (generator) class(radiation_generator_t), intent(inout) :: generator call generator%prt_queue%reset () end subroutine radiation_generator_reset_queue @ %def radiation_generator_reset_queue @ <>= procedure :: get_n_gks_states => radiation_generator_get_n_gks_states <>= function radiation_generator_get_n_gks_states (generator) result (n) class(radiation_generator_t), intent(in) :: generator integer :: n n = generator%prt_queue%n_lists end function radiation_generator_get_n_gks_states @ %def radiation_generator_get_n_fks_states @ <>= procedure :: get_next_state => radiation_generator_get_next_state <>= function radiation_generator_get_next_state (generator) result (prt_string) class(radiation_generator_t), intent(inout) :: generator type(string_t), dimension(:), allocatable :: prt_string call generator%prt_queue%get (prt_string) end function radiation_generator_get_next_state @ %def radiation_generator_get_next_state @ <>= procedure :: get_emitter_indices => radiation_generator_get_emitter_indices <>= subroutine radiation_generator_get_emitter_indices (generator, indices) class(radiation_generator_t), intent(in) :: generator integer, dimension(:), allocatable, intent(out) :: indices type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out integer, dimension(:), allocatable :: flv_in, flv_out integer, dimension(:), allocatable :: emitters integer :: i, j integer :: n_in, n_out call generator%pl_in%create_pdg_array (pdg_in) call generator%pl_out%create_pdg_array (pdg_out) n_in = size (pdg_in); n_out = size (pdg_out) allocate (flv_in (n_in), flv_out (n_out)) forall (i=1:n_in) flv_in(i) = pdg_in(i)%get() forall (i=1:n_out) flv_out(i) = pdg_out(i)%get() call generator%if_table%get_emitters (generator%constraints, emitters) allocate (indices (size (emitters))) j = 1 do i = 1, n_in + n_out if (i <= n_in) then if (any (flv_in(i) == emitters)) then indices (j) = i j = j + 1 end if else if (any (flv_out(i-n_in) == emitters)) then indices (j) = i j = j + 1 end if end if end do end subroutine radiation_generator_get_emitter_indices @ %def radiation_generator_get_emitter_indices @ <>= procedure :: get_raw_states => radiation_generator_get_raw_states <>= function radiation_generator_get_raw_states (generator) result (raw_states) class(radiation_generator_t), intent(in), target :: generator integer, dimension(:,:), allocatable :: raw_states type(pdg_states_t), pointer :: state integer :: n_states, n_particles integer :: i_state integer :: j state => generator%pdg_raw n_states = generator%pdg_raw%get_n_states () n_particles = size (generator%pdg_raw%pdg) allocate (raw_states (n_particles, n_states)) do i_state = 1, n_states do j = 1, n_particles raw_states (j, i_state) = state%pdg(j)%get () end do state => state%next end do end function radiation_generator_get_raw_states @ %def radiation_generator_get_raw_states @ <>= procedure :: save_born_raw => radiation_generator_save_born_raw <>= subroutine radiation_generator_save_born_raw (generator, pdg_in, pdg_out) class(radiation_generator_t), intent(inout) :: generator type(pdg_array_t), dimension(:), allocatable, intent(in) :: pdg_in, pdg_out integer :: i !!! !!! !!! Explicit allocation due to gfortran 4.7.4 allocate (generator%pdg_in_born (size (pdg_in))) do i = 1, size (pdg_in) generator%pdg_in_born(i) = pdg_in(i) end do allocate (generator%pdg_out_born (size (pdg_out))) do i = 1, size (pdg_out) generator%pdg_out_born(i) = pdg_out(i) end do end subroutine radiation_generator_save_born_raw @ %def radiation_generator_save_born_raw @ <>= procedure :: get_born_raw => radiation_generator_get_born_raw <>= function radiation_generator_get_born_raw (generator) result (flv_born) class(radiation_generator_t), intent(in) :: generator integer, dimension(:,:), allocatable :: flv_born integer :: i_part, n_particles n_particles = size (generator%pdg_in_born) + size (generator%pdg_out_born) allocate (flv_born (n_particles, 1)) flv_born(1,1) = generator%pdg_in_born(1)%get () flv_born(2,1) = generator%pdg_in_born(2)%get () do i_part = 3, n_particles flv_born(i_part, 1) = generator%pdg_out_born(i_part-2)%get () end do end function radiation_generator_get_born_raw @ %def radiation_generator_get_born_raw @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[radiation_generator_ut.f90]]>>= <> module radiation_generator_ut use unit_tests use radiation_generator_uti <> <> contains <> end module radiation_generator_ut @ %def radiation_generator_ut @ <<[[radiation_generator_uti.f90]]>>= <> module radiation_generator_uti <> use format_utils, only: write_separator use os_interface use pdg_arrays use models use kinds, only: default use radiation_generator <> <> contains <> <> end module radiation_generator_uti @ %def radiation_generator_ut @ API: driver for the unit tests below. <>= public :: radiation_generator_test <>= subroutine radiation_generator_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results call test(radiation_generator_1, "radiation_generator_1", & "Test the generator of N+1-particle flavor structures in QCD", & u, results) call test(radiation_generator_2, "radiation_generator_2", & "Test multiple splittings in QCD", & u, results) call test(radiation_generator_3, "radiation_generator_3", & "Test the generator of N+1-particle flavor structures in QED", & u, results) call test(radiation_generator_4, "radiation_generator_4", & "Test multiple splittings in QED", & u, results) end subroutine radiation_generator_test @ %def radiation_generator_test @ <>= public :: radiation_generator_1 <>= subroutine radiation_generator_1 (u) integer, intent(in) :: u type(radiation_generator_t) :: generator type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out type(os_data_t) :: os_data type(model_list_t) :: model_list type(model_t), pointer :: model => null () write (u, "(A)") "* Test output: radiation_generator_1" write (u, "(A)") "* Purpose: Create N+1-particle flavor structures & &from predefined N-particle flavor structures" write (u, "(A)") "* One additional strong coupling, no additional electroweak coupling" write (u, "(A)") write (u, "(A)") "* Loading radiation model: SM.mdl" call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Success" allocate (pdg_in (2)) pdg_in(1) = 11; pdg_in(2) = -11 write (u, "(A)") "* Start checking processes" call write_separator (u) write (u, "(A)") "* Process 1: Top pair-production with additional gluon" allocate (pdg_out(3)) pdg_out(1) = 6; pdg_out(2) = -6; pdg_out(3) = 21 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 2: Top pair-production with additional jet" allocate (pdg_out(3)) pdg_out(1) = 6; pdg_out(2) = -6; pdg_out(3) = [-1,1,-2,2,-3,3,-4,4,-5,5,21] call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 3: Quark-antiquark production" allocate (pdg_out(2)) pdg_out(1) = 2; pdg_out(2) = -2 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 4: Quark-antiquark production with additional gluon" allocate (pdg_out(3)) pdg_out(1) = 2; pdg_out(2) = -2; pdg_out(3) = 21 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 5: Z + jets" allocate (pdg_out(3)) pdg_out(1) = 2; pdg_out(2) = -2; pdg_out(3) = 23 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 6: Top Decay" allocate (pdg_out(4)) pdg_out(1) = 24; pdg_out(2) = -24 pdg_out(3) = 5; pdg_out(4) = -5 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 7: Production of four quarks" allocate (pdg_out(4)) pdg_out(1) = 2; pdg_out(2) = -2; pdg_out(3) = 2; pdg_out(4) = -2 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out); deallocate (pdg_in) write (u, "(A)") "* Process 8: Drell-Yan lepto-production" allocate (pdg_in (2)); allocate (pdg_out (2)) pdg_in(1) = 2; pdg_in(2) = -2 pdg_out(1) = 11; pdg_out(2) = -11 call test_process (generator, pdg_in, pdg_out, u, .true.) deallocate (pdg_out); deallocate (pdg_in) write (u, "(A)") "* Process 9: WZ production at hadron-colliders" allocate (pdg_in (2)); allocate (pdg_out (2)) pdg_in(1) = 1; pdg_in(2) = -2 pdg_out(1) = -24; pdg_out(2) = 23 call test_process (generator, pdg_in, pdg_out, u, .true.) deallocate (pdg_out); deallocate (pdg_in) contains subroutine test_process (generator, pdg_in, pdg_out, u, include_initial_state) type(radiation_generator_t), intent(inout) :: generator type(pdg_array_t), dimension(:), intent(in) :: pdg_in, pdg_out integer, intent(in) :: u logical, intent(in), optional :: include_initial_state type(string_t), dimension(:), allocatable :: prt_strings_in type(string_t), dimension(:), allocatable :: prt_strings_out type(pdg_array_t), dimension(10) :: pdg_excluded logical :: yorn yorn = .false. pdg_excluded = [-4, 4, 5, -5, 6, -6, 13, -13, 15, -15] if (present (include_initial_state)) yorn = include_initial_state write (u, "(A)") "* Leading order: " write (u, "(A)", advance = 'no') '* Incoming: ' call write_pdg_array (pdg_in, u) write (u, "(A)", advance = 'no') '* Outgoing: ' call write_pdg_array (pdg_out, u) call generator%init (pdg_in, pdg_out, & pdg_excluded_gauge_splittings = pdg_excluded, qcd = .true., qed = .false.) call generator%set_n (2, size(pdg_out), 0) if (yorn) call generator%set_initial_state_emissions () call generator%set_constraints (.false., .false., .true., .true.) call generator%setup_if_table (model) call generator%generate (prt_strings_in, prt_strings_out) write (u, "(A)") "* Additional radiation: " write (u, "(A)") "* Incoming: " call write_particle_string (prt_strings_in, u) write (u, "(A)") "* Outgoing: " call write_particle_string (prt_strings_out, u) call write_separator(u) call generator%reset_reshuffle_list () end subroutine test_process end subroutine radiation_generator_1 @ %def radiation_generator_1 @ <>= public :: radiation_generator_2 <>= subroutine radiation_generator_2 (u) integer, intent(in) :: u type(radiation_generator_t) :: generator type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out type(pdg_array_t), dimension(:), allocatable :: pdg_excluded type(os_data_t) :: os_data type(model_list_t) :: model_list type(model_t), pointer :: model => null () integer, parameter :: max_multiplicity = 10 type(string_t), dimension(:), allocatable :: prt_last write (u, "(A)") "* Test output: radiation_generator_2" write (u, "(A)") "* Purpose: Test the repeated application of & &a radiation generator splitting in QCD" write (u, "(A)") "* Only Final state emissions! " write (u, "(A)") write (u, "(A)") "* Loading radiation model: SM.mdl" call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Success" allocate (pdg_in (2)) pdg_in(1) = 11; pdg_in(2) = -11 allocate (pdg_out(2)) pdg_out(1) = 2; pdg_out(2) = -2 allocate (pdg_excluded (10)) pdg_excluded = [-4, 4, 5, -5, 6, -6, 13, -13, 15, -15] write (u, "(A)") "* Leading order" write (u, "(A)", advance = 'no') "* Incoming: " call write_pdg_array (pdg_in, u) write (u, "(A)", advance = 'no') "* Outgoing: " call write_pdg_array (pdg_out, u) call generator%init (pdg_in, pdg_out, & pdg_excluded_gauge_splittings = pdg_excluded, qcd = .true., qed = .false.) call generator%set_n (2, 2, 0) call generator%set_constraints (.false., .false., .true., .true.) call write_separator (u) write (u, "(A)") "Generate higher-multiplicity states" write (u, "(A,I0)") "Desired multiplicity: ", max_multiplicity call generator%generate_multiple (max_multiplicity, model) call generator%prt_queue%write (u) call write_separator (u) write (u, "(A,I0)") "Number of higher-multiplicity states: ", generator%prt_queue%n_lists write (u, "(A)") "Check that no particle state occurs twice or more" if (.not. generator%prt_queue%check_for_same_prt_strings()) then write (u, "(A)") "SUCCESS" else write (u, "(A)") "FAIL" end if call write_separator (u) write (u, "(A,I0,A)") "Check that there are ", max_multiplicity, " particles in the last entry:" call generator%prt_queue%get_last (prt_last) if (size (prt_last) == max_multiplicity) then write (u, "(A)") "SUCCESS" else write (u, "(A)") "FAIL" end if end subroutine radiation_generator_2 @ %def radiation_generator_2 @ <>= public :: radiation_generator_3 <>= subroutine radiation_generator_3 (u) integer, intent(in) :: u type(radiation_generator_t) :: generator type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out type(os_data_t) :: os_data type(model_list_t) :: model_list type(model_t), pointer :: model => null () write (u, "(A)") "* Test output: radiation_generator_3" write (u, "(A)") "* Purpose: Create N+1-particle flavor structures & &from predefined N-particle flavor structures" write (u, "(A)") "* One additional electroweak coupling, no additional strong coupling" write (u, "(A)") write (u, "(A)") "* Loading radiation model: SM.mdl" call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Success" allocate (pdg_in (2)) pdg_in(1) = 11; pdg_in(2) = -11 write (u, "(A)") "* Start checking processes" call write_separator (u) write (u, "(A)") "* Process 1: Tau pair-production with additional photon" allocate (pdg_out(3)) pdg_out(1) = 15; pdg_out(2) = -15; pdg_out(3) = 22 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 2: Tau pair-production with additional leptons or photon" allocate (pdg_out(3)) pdg_out(1) = 15; pdg_out(2) = -15; pdg_out(3) = [-13, 13, 22] call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 3: Electron-positron production" allocate (pdg_out(2)) pdg_out(1) = 11; pdg_out(2) = -11 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 4: Quark-antiquark production with additional photon" allocate (pdg_out(3)) pdg_out(1) = 2; pdg_out(2) = -2; pdg_out(3) = 22 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 5: Z + jets " allocate (pdg_out(3)) pdg_out(1) = 2; pdg_out(2) = -2; pdg_out(3) = 23 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 6: W + jets" allocate (pdg_out(3)) pdg_out(1) = 1; pdg_out(2) = -2; pdg_out(3) = -24 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 7: Top Decay" allocate (pdg_out(4)) pdg_out(1) = 24; pdg_out(2) = -24 pdg_out(3) = 5; pdg_out(4) = -5 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 8: Production of four quarks" allocate (pdg_out(4)) pdg_out(1) = 2; pdg_out(2) = -2; pdg_out(3) = 2; pdg_out(4) = -2 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out) write (u, "(A)") "* Process 9: Neutrino pair-production" allocate (pdg_out(2)) pdg_out(1) = 12; pdg_out(2) = -12 call test_process (generator, pdg_in, pdg_out, u, .true.) deallocate (pdg_out); deallocate (pdg_in) write (u, "(A)") "* Process 10: Drell-Yan lepto-production" allocate (pdg_in (2)); allocate (pdg_out (2)) pdg_in(1) = 2; pdg_in(2) = -2 pdg_out(1) = 11; pdg_out(2) = -11 call test_process (generator, pdg_in, pdg_out, u, .true.) deallocate (pdg_out); deallocate (pdg_in) write (u, "(A)") "* Process 11: WZ production at hadron-colliders" allocate (pdg_in (2)); allocate (pdg_out (2)) pdg_in(1) = 1; pdg_in(2) = -2 pdg_out(1) = -24; pdg_out(2) = 23 call test_process (generator, pdg_in, pdg_out, u, .true.) deallocate (pdg_out); deallocate (pdg_in) write (u, "(A)") "* Process 12: Positron-neutrino production" allocate (pdg_in (2)); allocate (pdg_out (2)) pdg_in(1) = -1; pdg_in(2) = 2 pdg_out(1) = -11; pdg_out(2) = 12 call test_process (generator, pdg_in, pdg_out, u) deallocate (pdg_out); deallocate (pdg_in) contains subroutine test_process (generator, pdg_in, pdg_out, u, include_initial_state) type(radiation_generator_t), intent(inout) :: generator type(pdg_array_t), dimension(:), intent(in) :: pdg_in, pdg_out integer, intent(in) :: u logical, intent(in), optional :: include_initial_state type(string_t), dimension(:), allocatable :: prt_strings_in type(string_t), dimension(:), allocatable :: prt_strings_out type(pdg_array_t), dimension(10) :: pdg_excluded logical :: yorn yorn = .false. pdg_excluded = [-4, 4, 5, -5, 6, -6, 13, -13, 15, -15] if (present (include_initial_state)) yorn = include_initial_state write (u, "(A)") "* Leading order: " write (u, "(A)", advance = 'no') '* Incoming: ' call write_pdg_array (pdg_in, u) write (u, "(A)", advance = 'no') '* Outgoing: ' call write_pdg_array (pdg_out, u) call generator%init (pdg_in, pdg_out, & pdg_excluded_gauge_splittings = pdg_excluded, qcd = .false., qed = .true.) call generator%set_n (2, size(pdg_out), 0) if (yorn) call generator%set_initial_state_emissions () call generator%set_constraints (.false., .false., .true., .true.) call generator%setup_if_table (model) call generator%generate (prt_strings_in, prt_strings_out) write (u, "(A)") "* Additional radiation: " write (u, "(A)") "* Incoming: " call write_particle_string (prt_strings_in, u) write (u, "(A)") "* Outgoing: " call write_particle_string (prt_strings_out, u) call write_separator(u) call generator%reset_reshuffle_list () end subroutine test_process end subroutine radiation_generator_3 @ %def radiation_generator_3 @ <>= public :: radiation_generator_4 <>= subroutine radiation_generator_4 (u) integer, intent(in) :: u type(radiation_generator_t) :: generator type(pdg_array_t), dimension(:), allocatable :: pdg_in, pdg_out type(pdg_array_t), dimension(:), allocatable :: pdg_excluded type(os_data_t) :: os_data type(model_list_t) :: model_list type(model_t), pointer :: model => null () integer, parameter :: max_multiplicity = 10 type(string_t), dimension(:), allocatable :: prt_last write (u, "(A)") "* Test output: radiation_generator_4" write (u, "(A)") "* Purpose: Test the repeated application of & &a radiation generator splitting in QED" write (u, "(A)") "* Only Final state emissions! " write (u, "(A)") write (u, "(A)") "* Loading radiation model: SM.mdl" call syntax_model_file_init () call os_data%init () call model_list%read_model & (var_str ("SM"), var_str ("SM.mdl"), & os_data, model) write (u, "(A)") "* Success" allocate (pdg_in (2)) pdg_in(1) = 2; pdg_in(2) = -2 allocate (pdg_out(2)) pdg_out(1) = 11; pdg_out(2) = -11 allocate ( pdg_excluded (14)) pdg_excluded = [1, -1, 2, -2, 3, -3, 4, -4, 5, -5, 6, -6, 15, -15] write (u, "(A)") "* Leading order" write (u, "(A)", advance = 'no') "* Incoming: " call write_pdg_array (pdg_in, u) write (u, "(A)", advance = 'no') "* Outgoing: " call write_pdg_array (pdg_out, u) call generator%init (pdg_in, pdg_out, & pdg_excluded_gauge_splittings = pdg_excluded, qcd = .false., qed = .true.) call generator%set_n (2, 2, 0) call generator%set_constraints (.false., .false., .true., .true.) call write_separator (u) write (u, "(A)") "Generate higher-multiplicity states" write (u, "(A,I0)") "Desired multiplicity: ", max_multiplicity call generator%generate_multiple (max_multiplicity, model) call generator%prt_queue%write (u) call write_separator (u) write (u, "(A,I0)") "Number of higher-multiplicity states: ", generator%prt_queue%n_lists write (u, "(A)") "Check that no particle state occurs twice or more" if (.not. generator%prt_queue%check_for_same_prt_strings()) then write (u, "(A)") "SUCCESS" else write (u, "(A)") "FAIL" end if call write_separator (u) write (u, "(A,I0,A)") "Check that there are ", max_multiplicity, " particles in the last entry:" call generator%prt_queue%get_last (prt_last) if (size (prt_last) == max_multiplicity) then write (u, "(A)") "SUCCESS" else write (u, "(A)") "FAIL" end if end subroutine radiation_generator_4 @ %def radiation_generator_4 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Sindarin Expression Implementation} This module defines expressions of all kinds, represented in a tree structure, for repeated evaluation. This provides an implementation of the [[expr_base]] abstract type. We have two flavors of expressions: one with particles and one without particles. The latter version is used for defining cut/selection criteria and for online analysis. <<[[eval_trees.f90]]>>= <> module eval_trees use, intrinsic :: iso_c_binding !NODEP! <> <> use io_units use constants, only: DEGREE, IMAGO, PI use format_defs, only: FMT_19 use diagnostics use lorentz use md5 use formats use sorting use ifiles use lexers use syntax_rules use parser use analysis use jets use pdg_arrays use subevents use user_code_interface use var_base use expr_base use variables use observables <> <> <> <> <> contains <> end module eval_trees @ %def eval_trees @ \subsection{Tree nodes} The evaluation tree consists of branch nodes (unary and binary) and of leaf nodes, originating from a common root. The node object should be polymorphic. For the time being, polymorphism is emulated here. This means that we have to maintain all possibilities that the node may hold, including associated procedures as pointers. The following parameter values characterize the node. Unary and binary operators have sub-nodes. The other are leaf nodes. Possible leafs are literal constants or named-parameter references. <>= integer, parameter :: EN_UNKNOWN = 0, EN_UNARY = 1, EN_BINARY = 2 integer, parameter :: EN_CONSTANT = 3, EN_VARIABLE = 4 integer, parameter :: EN_CONDITIONAL = 5, EN_BLOCK = 6 integer, parameter :: EN_RECORD_CMD = 7 integer, parameter :: EN_OBS1_INT = 11, EN_OBS2_INT = 12 integer, parameter :: EN_OBS1_REAL = 21, EN_OBS2_REAL = 22 integer, parameter :: EN_UOBS1_INT = 31, EN_UOBS2_INT = 32 integer, parameter :: EN_UOBS1_REAL = 41, EN_UOBS2_REAL = 42 integer, parameter :: EN_PRT_FUN_UNARY = 101, EN_PRT_FUN_BINARY = 102 integer, parameter :: EN_EVAL_FUN_UNARY = 111, EN_EVAL_FUN_BINARY = 112 integer, parameter :: EN_LOG_FUN_UNARY = 121, EN_LOG_FUN_BINARY = 122 integer, parameter :: EN_INT_FUN_UNARY = 131, EN_INT_FUN_BINARY = 132 integer, parameter :: EN_REAL_FUN_UNARY = 141, EN_REAL_FUN_BINARY = 142 integer, parameter :: EN_FORMAT_STR = 161 @ %def EN_UNKNOWN EN_UNARY EN_BINARY EN_CONSTANT EN_VARIABLE EN_CONDITIONAL @ %def EN_RECORD_CMD @ %def EN_OBS1_INT EN_OBS2_INT EN_OBS1_REAL EN_OBS2_REAL @ %def EN_UOBS1_INT EN_UOBS2_INT EN_UOBS1_REAL EN_UOBS2_REAL @ %def EN_PRT_FUN_UNARY EN_PRT_FUN_BINARY @ %def EN_EVAL_FUN_UNARY EN_EVAL_FUN_BINARY @ %def EN_LOG_FUN_UNARY EN_LOG_FUN_BINARY @ %def EN_INT_FUN_UNARY EN_INT_FUN_BINARY @ %def EN_REAL_FUN_UNARY EN_REAL_FUN_BINARY @ %def EN_FORMAT_STR @ This is exported only for use within unit tests. <>= public :: eval_node_t <>= type :: eval_node_t private type(string_t) :: tag integer :: type = EN_UNKNOWN integer :: result_type = V_NONE type(var_list_t), pointer :: var_list => null () type(string_t) :: var_name logical, pointer :: value_is_known => null () logical, pointer :: lval => null () integer, pointer :: ival => null () real(default), pointer :: rval => null () complex(default), pointer :: cval => null () type(subevt_t), pointer :: pval => null () type(pdg_array_t), pointer :: aval => null () type(string_t), pointer :: sval => null () type(eval_node_t), pointer :: arg0 => null () type(eval_node_t), pointer :: arg1 => null () type(eval_node_t), pointer :: arg2 => null () type(eval_node_t), pointer :: arg3 => null () type(eval_node_t), pointer :: arg4 => null () procedure(obs_unary_int), nopass, pointer :: obs1_int => null () procedure(obs_unary_real), nopass, pointer :: obs1_real => null () procedure(obs_binary_int), nopass, pointer :: obs2_int => null () procedure(obs_binary_real), nopass, pointer :: obs2_real => null () integer, pointer :: prt_type => null () integer, pointer :: index => null () real(default), pointer :: tolerance => null () integer, pointer :: jet_algorithm => null () real(default), pointer :: jet_r => null () real(default), pointer :: jet_p => null () real(default), pointer :: jet_ycut => null () type(prt_t), pointer :: prt1 => null () type(prt_t), pointer :: prt2 => null () procedure(unary_log), nopass, pointer :: op1_log => null () procedure(unary_int), nopass, pointer :: op1_int => null () procedure(unary_real), nopass, pointer :: op1_real => null () procedure(unary_cmplx), nopass, pointer :: op1_cmplx => null () procedure(unary_pdg), nopass, pointer :: op1_pdg => null () procedure(unary_sev), nopass, pointer :: op1_sev => null () procedure(unary_str), nopass, pointer :: op1_str => null () procedure(unary_cut), nopass, pointer :: op1_cut => null () procedure(unary_evi), nopass, pointer :: op1_evi => null () procedure(unary_evr), nopass, pointer :: op1_evr => null () procedure(binary_log), nopass, pointer :: op2_log => null () procedure(binary_int), nopass, pointer :: op2_int => null () procedure(binary_real), nopass, pointer :: op2_real => null () procedure(binary_cmplx), nopass, pointer :: op2_cmplx => null () procedure(binary_pdg), nopass, pointer :: op2_pdg => null () procedure(binary_sev), nopass, pointer :: op2_sev => null () procedure(binary_str), nopass, pointer :: op2_str => null () procedure(binary_cut), nopass, pointer :: op2_cut => null () procedure(binary_evi), nopass, pointer :: op2_evi => null () procedure(binary_evr), nopass, pointer :: op2_evr => null () contains <> end type eval_node_t @ %def eval_node_t @ Finalize a node recursively. Allocated constants are deleted, pointers are ignored. <>= procedure :: final_rec => eval_node_final_rec <>= recursive subroutine eval_node_final_rec (node) class(eval_node_t), intent(inout) :: node select case (node%type) case (EN_UNARY) call eval_node_final_rec (node%arg1) case (EN_BINARY) call eval_node_final_rec (node%arg1) call eval_node_final_rec (node%arg2) case (EN_CONDITIONAL) call eval_node_final_rec (node%arg0) call eval_node_final_rec (node%arg1) call eval_node_final_rec (node%arg2) case (EN_BLOCK) call eval_node_final_rec (node%arg0) call eval_node_final_rec (node%arg1) case (EN_PRT_FUN_UNARY, EN_EVAL_FUN_UNARY, & EN_LOG_FUN_UNARY, EN_INT_FUN_UNARY, EN_REAL_FUN_UNARY) if (associated (node%arg0)) call eval_node_final_rec (node%arg0) call eval_node_final_rec (node%arg1) deallocate (node%index) deallocate (node%prt1) case (EN_PRT_FUN_BINARY, EN_EVAL_FUN_BINARY, & EN_LOG_FUN_BINARY, EN_INT_FUN_BINARY, EN_REAL_FUN_BINARY) if (associated (node%arg0)) call eval_node_final_rec (node%arg0) call eval_node_final_rec (node%arg1) call eval_node_final_rec (node%arg2) deallocate (node%index) deallocate (node%prt1) deallocate (node%prt2) case (EN_FORMAT_STR) if (associated (node%arg0)) call eval_node_final_rec (node%arg0) if (associated (node%arg1)) call eval_node_final_rec (node%arg1) deallocate (node%ival) case (EN_RECORD_CMD) if (associated (node%arg0)) call eval_node_final_rec (node%arg0) if (associated (node%arg1)) call eval_node_final_rec (node%arg1) if (associated (node%arg2)) call eval_node_final_rec (node%arg2) if (associated (node%arg3)) call eval_node_final_rec (node%arg3) if (associated (node%arg4)) call eval_node_final_rec (node%arg4) end select select case (node%type) case (EN_UNARY, EN_BINARY, EN_CONDITIONAL, EN_CONSTANT, EN_BLOCK, & EN_PRT_FUN_UNARY, EN_PRT_FUN_BINARY, & EN_EVAL_FUN_UNARY, EN_EVAL_FUN_BINARY, & EN_LOG_FUN_UNARY, EN_LOG_FUN_BINARY, & EN_INT_FUN_UNARY, EN_INT_FUN_BINARY, & EN_REAL_FUN_UNARY, EN_REAL_FUN_BINARY, & EN_FORMAT_STR, EN_RECORD_CMD) select case (node%result_type) case (V_LOG); deallocate (node%lval) case (V_INT); deallocate (node%ival) case (V_REAL); deallocate (node%rval) case (V_CMPLX); deallocate (node%cval) case (V_SEV); deallocate (node%pval) case (V_PDG); deallocate (node%aval) case (V_STR); deallocate (node%sval) end select deallocate (node%value_is_known) end select end subroutine eval_node_final_rec @ %def eval_node_final_rec @ \subsubsection{Leaf nodes} Initialize a leaf node with a literal constant. <>= subroutine eval_node_init_log (node, lval) type(eval_node_t), intent(out) :: node logical, intent(in) :: lval node%type = EN_CONSTANT node%result_type = V_LOG allocate (node%lval, node%value_is_known) node%lval = lval node%value_is_known = .true. end subroutine eval_node_init_log subroutine eval_node_init_int (node, ival) type(eval_node_t), intent(out) :: node integer, intent(in) :: ival node%type = EN_CONSTANT node%result_type = V_INT allocate (node%ival, node%value_is_known) node%ival = ival node%value_is_known = .true. end subroutine eval_node_init_int subroutine eval_node_init_real (node, rval) type(eval_node_t), intent(out) :: node real(default), intent(in) :: rval node%type = EN_CONSTANT node%result_type = V_REAL allocate (node%rval, node%value_is_known) node%rval = rval node%value_is_known = .true. end subroutine eval_node_init_real subroutine eval_node_init_cmplx (node, cval) type(eval_node_t), intent(out) :: node complex(default), intent(in) :: cval node%type = EN_CONSTANT node%result_type = V_CMPLX allocate (node%cval, node%value_is_known) node%cval = cval node%value_is_known = .true. end subroutine eval_node_init_cmplx subroutine eval_node_init_subevt (node, pval) type(eval_node_t), intent(out) :: node type(subevt_t), intent(in) :: pval node%type = EN_CONSTANT node%result_type = V_SEV allocate (node%pval, node%value_is_known) node%pval = pval node%value_is_known = .true. end subroutine eval_node_init_subevt subroutine eval_node_init_pdg_array (node, aval) type(eval_node_t), intent(out) :: node type(pdg_array_t), intent(in) :: aval node%type = EN_CONSTANT node%result_type = V_PDG allocate (node%aval, node%value_is_known) node%aval = aval node%value_is_known = .true. end subroutine eval_node_init_pdg_array subroutine eval_node_init_string (node, sval) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: sval node%type = EN_CONSTANT node%result_type = V_STR allocate (node%sval, node%value_is_known) node%sval = sval node%value_is_known = .true. end subroutine eval_node_init_string @ %def eval_node_init_log eval_node_init_int eval_node_init_real @ %def eval_node_init_cmplx eval_node_init_prt eval_node_init_subevt @ %def eval_node_init_pdg_array eval_node_init_string @ Initialize a leaf node with a pointer to a named parameter <>= subroutine eval_node_init_log_ptr (node, name, lval, is_known) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name logical, intent(in), target :: lval logical, intent(in), target :: is_known node%type = EN_VARIABLE node%tag = name node%result_type = V_LOG node%lval => lval node%value_is_known => is_known end subroutine eval_node_init_log_ptr subroutine eval_node_init_int_ptr (node, name, ival, is_known) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name integer, intent(in), target :: ival logical, intent(in), target :: is_known node%type = EN_VARIABLE node%tag = name node%result_type = V_INT node%ival => ival node%value_is_known => is_known end subroutine eval_node_init_int_ptr subroutine eval_node_init_real_ptr (node, name, rval, is_known) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name real(default), intent(in), target :: rval logical, intent(in), target :: is_known node%type = EN_VARIABLE node%tag = name node%result_type = V_REAL node%rval => rval node%value_is_known => is_known end subroutine eval_node_init_real_ptr subroutine eval_node_init_cmplx_ptr (node, name, cval, is_known) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name complex(default), intent(in), target :: cval logical, intent(in), target :: is_known node%type = EN_VARIABLE node%tag = name node%result_type = V_CMPLX node%cval => cval node%value_is_known => is_known end subroutine eval_node_init_cmplx_ptr subroutine eval_node_init_subevt_ptr (node, name, pval, is_known) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name type(subevt_t), intent(in), target :: pval logical, intent(in), target :: is_known node%type = EN_VARIABLE node%tag = name node%result_type = V_SEV node%pval => pval node%value_is_known => is_known end subroutine eval_node_init_subevt_ptr subroutine eval_node_init_pdg_array_ptr (node, name, aval, is_known) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name type(pdg_array_t), intent(in), target :: aval logical, intent(in), target :: is_known node%type = EN_VARIABLE node%tag = name node%result_type = V_PDG node%aval => aval node%value_is_known => is_known end subroutine eval_node_init_pdg_array_ptr subroutine eval_node_init_string_ptr (node, name, sval, is_known) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name type(string_t), intent(in), target :: sval logical, intent(in), target :: is_known node%type = EN_VARIABLE node%tag = name node%result_type = V_STR node%sval => sval node%value_is_known => is_known end subroutine eval_node_init_string_ptr @ %def eval_node_init_log_ptr eval_node_init_int_ptr @ %def eval_node_init_real_ptr eval_node_init_cmplx_ptr @ %def eval_node_init_subevt_ptr eval_node_init_string_ptr @ The procedure-pointer cases: <>= subroutine eval_node_init_obs1_int_ptr (node, name, obs1_iptr, p1) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name procedure(obs_unary_int), intent(in), pointer :: obs1_iptr type(prt_t), intent(in), target :: p1 node%type = EN_OBS1_INT node%tag = name node%result_type = V_INT node%obs1_int => obs1_iptr node%prt1 => p1 allocate (node%ival, node%value_is_known) node%value_is_known = .false. end subroutine eval_node_init_obs1_int_ptr subroutine eval_node_init_obs2_int_ptr (node, name, obs2_iptr, p1, p2) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name procedure(obs_binary_int), intent(in), pointer :: obs2_iptr type(prt_t), intent(in), target :: p1, p2 node%type = EN_OBS2_INT node%tag = name node%result_type = V_INT node%obs2_int => obs2_iptr node%prt1 => p1 node%prt2 => p2 allocate (node%ival, node%value_is_known) node%value_is_known = .false. end subroutine eval_node_init_obs2_int_ptr subroutine eval_node_init_obs1_real_ptr (node, name, obs1_rptr, p1) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name procedure(obs_unary_real), intent(in), pointer :: obs1_rptr type(prt_t), intent(in), target :: p1 node%type = EN_OBS1_REAL node%tag = name node%result_type = V_REAL node%obs1_real => obs1_rptr node%prt1 => p1 allocate (node%rval, node%value_is_known) node%value_is_known = .false. end subroutine eval_node_init_obs1_real_ptr subroutine eval_node_init_obs2_real_ptr (node, name, obs2_rptr, p1, p2) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name procedure(obs_binary_real), intent(in), pointer :: obs2_rptr type(prt_t), intent(in), target :: p1, p2 node%type = EN_OBS2_REAL node%tag = name node%result_type = V_REAL node%obs2_real => obs2_rptr node%prt1 => p1 node%prt2 => p2 allocate (node%rval, node%value_is_known) node%value_is_known = .false. end subroutine eval_node_init_obs2_real_ptr @ %def eval_node_init_obs1_int_ptr @ %def eval_node_init_obs2_int_ptr @ %def eval_node_init_obs1_real_ptr @ %def eval_node_init_obs2_real_ptr @ These nodes refer to user-defined procedures. <>= subroutine eval_node_init_uobs1_int (node, name, arg) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name type(eval_node_t), intent(in), target :: arg node%type = EN_UOBS1_INT node%tag = name node%result_type = V_INT allocate (node%ival, node%value_is_known) node%value_is_known = .false. node%arg0 => arg end subroutine eval_node_init_uobs1_int subroutine eval_node_init_uobs2_int (node, name, arg) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name type(eval_node_t), intent(in), target :: arg node%type = EN_UOBS2_INT node%tag = name node%result_type = V_INT allocate (node%ival, node%value_is_known) node%value_is_known = .false. node%arg0 => arg end subroutine eval_node_init_uobs2_int subroutine eval_node_init_uobs1_real (node, name, arg) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name type(eval_node_t), intent(in), target :: arg node%type = EN_UOBS1_REAL node%tag = name node%result_type = V_REAL allocate (node%rval, node%value_is_known) node%value_is_known = .false. node%arg0 => arg end subroutine eval_node_init_uobs1_real subroutine eval_node_init_uobs2_real (node, name, arg) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: name type(eval_node_t), intent(in), target :: arg node%type = EN_UOBS2_REAL node%tag = name node%result_type = V_REAL allocate (node%rval, node%value_is_known) node%value_is_known = .false. node%arg0 => arg end subroutine eval_node_init_uobs2_real @ %def eval_node_init_uobs1_int @ %def eval_node_init_uobs2_int @ %def eval_node_init_uobs1_real @ %def eval_node_init_uobs2_real @ \subsubsection{Branch nodes} Initialize a branch node, sub-nodes are given. <>= subroutine eval_node_init_branch (node, tag, result_type, arg1, arg2) type(eval_node_t), intent(out) :: node type(string_t), intent(in) :: tag integer, intent(in) :: result_type type(eval_node_t), intent(in), target :: arg1 type(eval_node_t), intent(in), target, optional :: arg2 if (present (arg2)) then node%type = EN_BINARY else node%type = EN_UNARY end if node%tag = tag node%result_type = result_type call eval_node_allocate_value (node) node%arg1 => arg1 if (present (arg2)) node%arg2 => arg2 end subroutine eval_node_init_branch @ %def eval_node_init_branch @ Allocate the node value according to the result type. <>= subroutine eval_node_allocate_value (node) type(eval_node_t), intent(inout) :: node select case (node%result_type) case (V_LOG); allocate (node%lval) case (V_INT); allocate (node%ival) case (V_REAL); allocate (node%rval) case (V_CMPLX); allocate (node%cval) case (V_PDG); allocate (node%aval) case (V_SEV); allocate (node%pval) call subevt_init (node%pval) case (V_STR); allocate (node%sval) end select allocate (node%value_is_known) node%value_is_known = .false. end subroutine eval_node_allocate_value @ %def eval_node_allocate_value @ Initialize a block node which contains, in addition to the expression to be evaluated, a variable definition. The result type is not yet assigned, because we can compile the enclosed expression only after the var list is set up. Note that the node always allocates a new variable list and appends it to the current one. Thus, if the variable redefines an existing one, it only shadows it but does not reset it. Any side-effects are therefore absent and need not be undone outside the block. If the flag [[new]] is set, a variable is (re)declared. This must not be done for intrinsic variables. Vice versa, if the variable is not existent, the [[new]] flag is required. <>= subroutine eval_node_init_block (node, name, type, var_def, var_list) type(eval_node_t), intent(out), target :: node type(string_t), intent(in) :: name integer, intent(in) :: type type(eval_node_t), intent(in), target :: var_def type(var_list_t), intent(in), target :: var_list node%type = EN_BLOCK node%tag = "var_def" node%var_name = name node%arg1 => var_def allocate (node%var_list) call node%var_list%link (var_list) if (var_def%type == EN_CONSTANT) then select case (type) case (V_LOG) call var_list_append_log (node%var_list, name, var_def%lval) case (V_INT) call var_list_append_int (node%var_list, name, var_def%ival) case (V_REAL) call var_list_append_real (node%var_list, name, var_def%rval) case (V_CMPLX) call var_list_append_cmplx (node%var_list, name, var_def%cval) case (V_PDG) call var_list_append_pdg_array & (node%var_list, name, var_def%aval) case (V_SEV) call var_list_append_subevt & (node%var_list, name, var_def%pval) case (V_STR) call var_list_append_string (node%var_list, name, var_def%sval) end select else select case (type) case (V_LOG); call var_list_append_log_ptr & (node%var_list, name, var_def%lval, var_def%value_is_known) case (V_INT); call var_list_append_int_ptr & (node%var_list, name, var_def%ival, var_def%value_is_known) case (V_REAL); call var_list_append_real_ptr & (node%var_list, name, var_def%rval, var_def%value_is_known) case (V_CMPLX); call var_list_append_cmplx_ptr & (node%var_list, name, var_def%cval, var_def%value_is_known) case (V_PDG); call var_list_append_pdg_array_ptr & (node%var_list, name, var_def%aval, var_def%value_is_known) case (V_SEV); call var_list_append_subevt_ptr & (node%var_list, name, var_def%pval, var_def%value_is_known) case (V_STR); call var_list_append_string_ptr & (node%var_list, name, var_def%sval, var_def%value_is_known) end select end if end subroutine eval_node_init_block @ %def eval_node_init_block @ Complete block initialization by assigning the expression to evaluate to [[arg0]]. <>= subroutine eval_node_set_expr (node, arg, result_type) type(eval_node_t), intent(inout) :: node type(eval_node_t), intent(in), target :: arg integer, intent(in), optional :: result_type if (present (result_type)) then node%result_type = result_type else node%result_type = arg%result_type end if call eval_node_allocate_value (node) node%arg0 => arg end subroutine eval_node_set_expr @ %def eval_node_set_block_expr @ Initialize a conditional. There are three branches: the condition (evaluates to logical) and the two alternatives (evaluate both to the same arbitrary type). <>= subroutine eval_node_init_conditional (node, result_type, cond, arg1, arg2) type(eval_node_t), intent(out) :: node integer, intent(in) :: result_type type(eval_node_t), intent(in), target :: cond, arg1, arg2 node%type = EN_CONDITIONAL node%tag = "cond" node%result_type = result_type call eval_node_allocate_value (node) node%arg0 => cond node%arg1 => arg1 node%arg2 => arg2 end subroutine eval_node_init_conditional @ %def eval_node_init_conditional @ Initialize a recording command (which evaluates to a logical constant). The first branch is the ID of the analysis object to be filled, the optional branches 1 to 4 are the values to be recorded. If the event-weight pointer is null, we record values with unit weight. Otherwise, we use the value pointed to as event weight. There can be up to four arguments which represent $x$, $y$, $\Delta y$, $\Delta x$. Therefore, this is the only node type that may fill four sub-nodes. <>= subroutine eval_node_init_record_cmd & (node, event_weight, id, arg1, arg2, arg3, arg4) type(eval_node_t), intent(out) :: node real(default), pointer :: event_weight type(eval_node_t), intent(in), target :: id type(eval_node_t), intent(in), optional, target :: arg1, arg2, arg3, arg4 call eval_node_init_log (node, .true.) node%type = EN_RECORD_CMD node%rval => event_weight node%tag = "record_cmd" node%arg0 => id if (present (arg1)) then node%arg1 => arg1 if (present (arg2)) then node%arg2 => arg2 if (present (arg3)) then node%arg3 => arg3 if (present (arg4)) then node%arg4 => arg4 end if end if end if end if end subroutine eval_node_init_record_cmd @ %def eval_node_init_record_cmd @ Initialize a node for operations on subevents. The particle lists (one or two) are inserted as [[arg1]] and [[arg2]]. We allocated particle pointers as temporaries for iterating over particle lists. The procedure pointer which holds the function to evaluate for the subevents (e.g., combine, select) is also initialized. <>= subroutine eval_node_init_prt_fun_unary (node, arg1, name, proc) type(eval_node_t), intent(out) :: node type(eval_node_t), intent(in), target :: arg1 type(string_t), intent(in) :: name procedure(unary_sev) :: proc node%type = EN_PRT_FUN_UNARY node%tag = name node%result_type = V_SEV call eval_node_allocate_value (node) node%arg1 => arg1 allocate (node%index, source = 0) allocate (node%prt1) node%op1_sev => proc end subroutine eval_node_init_prt_fun_unary subroutine eval_node_init_prt_fun_binary (node, arg1, arg2, name, proc) type(eval_node_t), intent(out) :: node type(eval_node_t), intent(in), target :: arg1, arg2 type(string_t), intent(in) :: name procedure(binary_sev) :: proc node%type = EN_PRT_FUN_BINARY node%tag = name node%result_type = V_SEV call eval_node_allocate_value (node) node%arg1 => arg1 node%arg2 => arg2 allocate (node%index, source = 0) allocate (node%prt1) allocate (node%prt2) node%op2_sev => proc end subroutine eval_node_init_prt_fun_binary @ %def eval_node_init_prt_fun_unary eval_node_init_prt_fun_binary @ Similar, but for particle-list functions that evaluate to a real value. <>= subroutine eval_node_init_eval_fun_unary (node, arg1, name) type(eval_node_t), intent(out) :: node type(eval_node_t), intent(in), target :: arg1 type(string_t), intent(in) :: name node%type = EN_EVAL_FUN_UNARY node%tag = name node%result_type = V_REAL call eval_node_allocate_value (node) node%arg1 => arg1 allocate (node%index, source = 0) allocate (node%prt1) end subroutine eval_node_init_eval_fun_unary subroutine eval_node_init_eval_fun_binary (node, arg1, arg2, name) type(eval_node_t), intent(out) :: node type(eval_node_t), intent(in), target :: arg1, arg2 type(string_t), intent(in) :: name node%type = EN_EVAL_FUN_BINARY node%tag = name node%result_type = V_REAL call eval_node_allocate_value (node) node%arg1 => arg1 node%arg2 => arg2 allocate (node%index, source = 0) allocate (node%prt1) allocate (node%prt2) end subroutine eval_node_init_eval_fun_binary @ %def eval_node_init_eval_fun_unary eval_node_init_eval_fun_binary @ These are for particle-list functions that evaluate to a logical value. <>= subroutine eval_node_init_log_fun_unary (node, arg1, name, proc) type(eval_node_t), intent(out) :: node type(eval_node_t), intent(in), target :: arg1 type(string_t), intent(in) :: name procedure(unary_cut) :: proc node%type = EN_LOG_FUN_UNARY node%tag = name node%result_type = V_LOG call eval_node_allocate_value (node) node%arg1 => arg1 allocate (node%index, source = 0) allocate (node%prt1) node%op1_cut => proc end subroutine eval_node_init_log_fun_unary subroutine eval_node_init_log_fun_binary (node, arg1, arg2, name, proc) type(eval_node_t), intent(out) :: node type(eval_node_t), intent(in), target :: arg1, arg2 type(string_t), intent(in) :: name procedure(binary_cut) :: proc node%type = EN_LOG_FUN_BINARY node%tag = name node%result_type = V_LOG call eval_node_allocate_value (node) node%arg1 => arg1 node%arg2 => arg2 allocate (node%index, source = 0) allocate (node%prt1) allocate (node%prt2) node%op2_cut => proc end subroutine eval_node_init_log_fun_binary @ %def eval_node_init_log_fun_unary eval_node_init_log_fun_binary @ These are for particle-list functions that evaluate to an integer value. <>= subroutine eval_node_init_int_fun_unary (node, arg1, name, proc) type(eval_node_t), intent(out) :: node type(eval_node_t), intent(in), target :: arg1 type(string_t), intent(in) :: name procedure(unary_evi) :: proc node%type = EN_INT_FUN_UNARY node%tag = name node%result_type = V_INT call eval_node_allocate_value (node) node%arg1 => arg1 allocate (node%index, source = 0) allocate (node%prt1) node%op1_evi => proc end subroutine eval_node_init_int_fun_unary subroutine eval_node_init_int_fun_binary (node, arg1, arg2, name, proc) type(eval_node_t), intent(out) :: node type(eval_node_t), intent(in), target :: arg1, arg2 type(string_t), intent(in) :: name procedure(binary_evi) :: proc node%type = EN_INT_FUN_BINARY node%tag = name node%result_type = V_INT call eval_node_allocate_value (node) node%arg1 => arg1 node%arg2 => arg2 allocate (node%index, source = 0) allocate (node%prt1) allocate (node%prt2) node%op2_evi => proc end subroutine eval_node_init_int_fun_binary @ %def eval_node_init_int_fun_unary eval_node_init_int_fun_binary @ These are for particle-list functions that evaluate to a real value. <>= subroutine eval_node_init_real_fun_unary (node, arg1, name, proc) type(eval_node_t), intent(out) :: node type(eval_node_t), intent(in), target :: arg1 type(string_t), intent(in) :: name procedure(unary_evr) :: proc node%type = EN_REAL_FUN_UNARY node%tag = name node%result_type = V_INT call eval_node_allocate_value (node) node%arg1 => arg1 allocate (node%index, source = 0) allocate (node%prt1) node%op1_evr => proc end subroutine eval_node_init_real_fun_unary subroutine eval_node_init_real_fun_binary (node, arg1, arg2, name, proc) type(eval_node_t), intent(out) :: node type(eval_node_t), intent(in), target :: arg1, arg2 type(string_t), intent(in) :: name procedure(binary_evr) :: proc node%type = EN_REAL_FUN_BINARY node%tag = name node%result_type = V_INT call eval_node_allocate_value (node) node%arg1 => arg1 node%arg2 => arg2 allocate (node%index, source = 0) allocate (node%prt1) allocate (node%prt2) node%op2_evr => proc end subroutine eval_node_init_real_fun_binary @ %def eval_node_init_real_fun_unary eval_node_init_real_fun_binary @ Initialize a node for a string formatting function (sprintf). <>= subroutine eval_node_init_format_string (node, fmt, arg, name, n_args) type(eval_node_t), intent(out) :: node type(eval_node_t), pointer :: fmt, arg type(string_t), intent(in) :: name integer, intent(in) :: n_args node%type = EN_FORMAT_STR node%tag = name node%result_type = V_STR call eval_node_allocate_value (node) node%arg0 => fmt node%arg1 => arg allocate (node%ival) node%ival = n_args end subroutine eval_node_init_format_string @ %def eval_node_init_format_string @ If particle functions depend upon a condition (or an expression is evaluated), the observables that can be evaluated for the given particles have to be thrown on the local variable stack. This is done here. Each observable is initialized with the particle pointers which have been allocated for the node. The integer variable that is referred to by the [[Index]] pseudo-observable is always known when it is referred to. <>= subroutine eval_node_set_observables (node, var_list) type(eval_node_t), intent(inout) :: node type(var_list_t), intent(in), target :: var_list logical, save, target :: known = .true. allocate (node%var_list) call node%var_list%link (var_list) allocate (node%index, source = 0) call var_list_append_int_ptr & (node%var_list, var_str ("Index"), node%index, known, intrinsic=.true.) if (.not. associated (node%prt2)) then call var_list_set_observables_unary & (node%var_list, node%prt1) else call var_list_set_observables_binary & (node%var_list, node%prt1, node%prt2) end if end subroutine eval_node_set_observables @ %def eval_node_set_observables @ \subsubsection{Output} <>= procedure :: write => eval_node_write <>= subroutine eval_node_write (node, unit, indent) class(eval_node_t), intent(in) :: node integer, intent(in), optional :: unit integer, intent(in), optional :: indent integer :: u, ind u = given_output_unit (unit); if (u < 0) return ind = 0; if (present (indent)) ind = indent write (u, "(A)", advance="no") repeat ("| ", ind) // "o " select case (node%type) case (EN_UNARY, EN_BINARY, EN_CONDITIONAL, & EN_PRT_FUN_UNARY, EN_PRT_FUN_BINARY, & EN_EVAL_FUN_UNARY, EN_EVAL_FUN_BINARY, & EN_LOG_FUN_UNARY, EN_LOG_FUN_BINARY, & EN_INT_FUN_UNARY, EN_INT_FUN_BINARY, & EN_REAL_FUN_UNARY, EN_REAL_FUN_BINARY) write (u, "(A)", advance="no") "[" // char (node%tag) // "] =" case (EN_CONSTANT) write (u, "(A)", advance="no") "[const] =" case (EN_VARIABLE) write (u, "(A)", advance="no") char (node%tag) // " =>" case (EN_OBS1_INT, EN_OBS2_INT, EN_OBS1_REAL, EN_OBS2_REAL, & EN_UOBS1_INT, EN_UOBS2_INT, EN_UOBS1_REAL, EN_UOBS2_REAL) write (u, "(A)", advance="no") char (node%tag) // " =" case (EN_BLOCK) write (u, "(A)", advance="no") "[" // char (node%tag) // "]" // & char (node%var_name) // " [expr] = " case default write (u, "(A)", advance="no") "[???] =" end select select case (node%result_type) case (V_LOG) if (node%value_is_known) then if (node%lval) then write (u, "(1x,A)") "true" else write (u, "(1x,A)") "false" end if else write (u, "(1x,A)") "[unknown logical]" end if case (V_INT) if (node%value_is_known) then write (u, "(1x,I0)") node%ival else write (u, "(1x,A)") "[unknown integer]" end if case (V_REAL) if (node%value_is_known) then write (u, "(1x," // FMT_19 // ")") node%rval else write (u, "(1x,A)") "[unknown real]" end if case (V_CMPLX) if (node%value_is_known) then write (u, "(1x,'('," // FMT_19 // ",','," // & FMT_19 // ",')')") node%cval else write (u, "(1x,A)") "[unknown complex]" end if case (V_SEV) if (char (node%tag) == "@evt") then write (u, "(1x,A)") "[event subevent]" else if (node%value_is_known) then call subevt_write & (node%pval, unit, prefix = repeat ("| ", ind + 1)) else write (u, "(1x,A)") "[unknown subevent]" end if case (V_PDG) write (u, "(1x)", advance="no") call pdg_array_write (node%aval, u); write (u, *) case (V_STR) if (node%value_is_known) then write (u, "(A)") '"' // char (node%sval) // '"' else write (u, "(1x,A)") "[unknown string]" end if case default write (u, "(1x,A)") "[empty]" end select select case (node%type) case (EN_OBS1_INT, EN_OBS1_REAL, EN_UOBS1_INT, EN_UOBS1_REAL) write (u, "(A,6x,A)", advance="no") repeat ("| ", ind), "prt1 =" call prt_write (node%prt1, unit) case (EN_OBS2_INT, EN_OBS2_REAL, EN_UOBS2_INT, EN_UOBS2_REAL) write (u, "(A,6x,A)", advance="no") repeat ("| ", ind), "prt1 =" call prt_write (node%prt1, unit) write (u, "(A,6x,A)", advance="no") repeat ("| ", ind), "prt2 =" call prt_write (node%prt2, unit) end select end subroutine eval_node_write recursive subroutine eval_node_write_rec (node, unit, indent) type(eval_node_t), intent(in) :: node integer, intent(in), optional :: unit integer, intent(in), optional :: indent integer :: u, ind u = given_output_unit (unit); if (u < 0) return ind = 0; if (present (indent)) ind = indent call eval_node_write (node, unit, indent) select case (node%type) case (EN_UNARY) if (associated (node%arg0)) & call eval_node_write_rec (node%arg0, unit, ind+1) call eval_node_write_rec (node%arg1, unit, ind+1) case (EN_BINARY) if (associated (node%arg0)) & call eval_node_write_rec (node%arg0, unit, ind+1) call eval_node_write_rec (node%arg1, unit, ind+1) call eval_node_write_rec (node%arg2, unit, ind+1) case (EN_BLOCK) call eval_node_write_rec (node%arg1, unit, ind+1) call eval_node_write_rec (node%arg0, unit, ind+1) case (EN_CONDITIONAL) call eval_node_write_rec (node%arg0, unit, ind+1) call eval_node_write_rec (node%arg1, unit, ind+1) call eval_node_write_rec (node%arg2, unit, ind+1) case (EN_PRT_FUN_UNARY, EN_EVAL_FUN_UNARY, & EN_LOG_FUN_UNARY, EN_INT_FUN_UNARY, EN_REAL_FUN_UNARY) if (associated (node%arg0)) & call eval_node_write_rec (node%arg0, unit, ind+1) call eval_node_write_rec (node%arg1, unit, ind+1) case (EN_PRT_FUN_BINARY, EN_EVAL_FUN_BINARY, & EN_LOG_FUN_BINARY, EN_INT_FUN_BINARY, EN_REAL_FUN_BINARY) if (associated (node%arg0)) & call eval_node_write_rec (node%arg0, unit, ind+1) call eval_node_write_rec (node%arg1, unit, ind+1) call eval_node_write_rec (node%arg2, unit, ind+1) case (EN_RECORD_CMD) if (associated (node%arg1)) then call eval_node_write_rec (node%arg1, unit, ind+1) if (associated (node%arg2)) then call eval_node_write_rec (node%arg2, unit, ind+1) if (associated (node%arg3)) then call eval_node_write_rec (node%arg3, unit, ind+1) if (associated (node%arg4)) then call eval_node_write_rec (node%arg4, unit, ind+1) end if end if end if end if end select end subroutine eval_node_write_rec @ %def eval_node_write eval_node_write_rec @ \subsection{Operation types} For the operations associated to evaluation tree nodes, we define abstract interfaces for all cases. Particles/subevents are transferred by-reference, to avoid unnecessary copying. Therefore, subroutines instead of functions. (Furthermore, the function version of [[unary_prt]] triggers an obscure bug in nagfor 5.2(649) [invalid C code].) <>= abstract interface logical function unary_log (arg) import eval_node_t type(eval_node_t), intent(in) :: arg end function unary_log end interface abstract interface integer function unary_int (arg) import eval_node_t type(eval_node_t), intent(in) :: arg end function unary_int end interface abstract interface real(default) function unary_real (arg) import default import eval_node_t type(eval_node_t), intent(in) :: arg end function unary_real end interface abstract interface complex(default) function unary_cmplx (arg) import default import eval_node_t type(eval_node_t), intent(in) :: arg end function unary_cmplx end interface abstract interface subroutine unary_pdg (pdg_array, arg) import pdg_array_t import eval_node_t type(pdg_array_t), intent(out) :: pdg_array type(eval_node_t), intent(in) :: arg end subroutine unary_pdg end interface abstract interface subroutine unary_sev (subevt, arg, arg0) import subevt_t import eval_node_t type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: arg type(eval_node_t), intent(inout), optional :: arg0 end subroutine unary_sev end interface abstract interface subroutine unary_str (string, arg) import string_t import eval_node_t type(string_t), intent(out) :: string type(eval_node_t), intent(in) :: arg end subroutine unary_str end interface abstract interface logical function unary_cut (arg1, arg0) import eval_node_t type(eval_node_t), intent(in) :: arg1 type(eval_node_t), intent(inout) :: arg0 end function unary_cut end interface abstract interface subroutine unary_evi (ival, arg1, arg0) import eval_node_t integer, intent(out) :: ival type(eval_node_t), intent(in) :: arg1 type(eval_node_t), intent(inout), optional :: arg0 end subroutine unary_evi end interface abstract interface subroutine unary_evr (rval, arg1, arg0) import eval_node_t, default real(default), intent(out) :: rval type(eval_node_t), intent(in) :: arg1 type(eval_node_t), intent(inout), optional :: arg0 end subroutine unary_evr end interface abstract interface logical function binary_log (arg1, arg2) import eval_node_t type(eval_node_t), intent(in) :: arg1, arg2 end function binary_log end interface abstract interface integer function binary_int (arg1, arg2) import eval_node_t type(eval_node_t), intent(in) :: arg1, arg2 end function binary_int end interface abstract interface real(default) function binary_real (arg1, arg2) import default import eval_node_t type(eval_node_t), intent(in) :: arg1, arg2 end function binary_real end interface abstract interface complex(default) function binary_cmplx (arg1, arg2) import default import eval_node_t type(eval_node_t), intent(in) :: arg1, arg2 end function binary_cmplx end interface abstract interface subroutine binary_pdg (pdg_array, arg1, arg2) import pdg_array_t import eval_node_t type(pdg_array_t), intent(out) :: pdg_array type(eval_node_t), intent(in) :: arg1, arg2 end subroutine binary_pdg end interface abstract interface subroutine binary_sev (subevt, arg1, arg2, arg0) import subevt_t import eval_node_t type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: arg1, arg2 type(eval_node_t), intent(inout), optional :: arg0 end subroutine binary_sev end interface abstract interface subroutine binary_str (string, arg1, arg2) import string_t import eval_node_t type(string_t), intent(out) :: string type(eval_node_t), intent(in) :: arg1, arg2 end subroutine binary_str end interface abstract interface logical function binary_cut (arg1, arg2, arg0) import eval_node_t type(eval_node_t), intent(in) :: arg1, arg2 type(eval_node_t), intent(inout) :: arg0 end function binary_cut end interface abstract interface subroutine binary_evi (ival, arg1, arg2, arg0) import eval_node_t integer, intent(out) :: ival type(eval_node_t), intent(in) :: arg1, arg2 type(eval_node_t), intent(inout), optional :: arg0 end subroutine binary_evi end interface abstract interface subroutine binary_evr (rval, arg1, arg2, arg0) import eval_node_t, default real(default), intent(out) :: rval type(eval_node_t), intent(in) :: arg1, arg2 type(eval_node_t), intent(inout), optional :: arg0 end subroutine binary_evr end interface @ The following subroutines set the procedure pointer: <>= subroutine eval_node_set_op1_log (en, op) type(eval_node_t), intent(inout) :: en procedure(unary_log) :: op en%op1_log => op end subroutine eval_node_set_op1_log subroutine eval_node_set_op1_int (en, op) type(eval_node_t), intent(inout) :: en procedure(unary_int) :: op en%op1_int => op end subroutine eval_node_set_op1_int subroutine eval_node_set_op1_real (en, op) type(eval_node_t), intent(inout) :: en procedure(unary_real) :: op en%op1_real => op end subroutine eval_node_set_op1_real subroutine eval_node_set_op1_cmplx (en, op) type(eval_node_t), intent(inout) :: en procedure(unary_cmplx) :: op en%op1_cmplx => op end subroutine eval_node_set_op1_cmplx subroutine eval_node_set_op1_pdg (en, op) type(eval_node_t), intent(inout) :: en procedure(unary_pdg) :: op en%op1_pdg => op end subroutine eval_node_set_op1_pdg subroutine eval_node_set_op1_sev (en, op) type(eval_node_t), intent(inout) :: en procedure(unary_sev) :: op en%op1_sev => op end subroutine eval_node_set_op1_sev subroutine eval_node_set_op1_str (en, op) type(eval_node_t), intent(inout) :: en procedure(unary_str) :: op en%op1_str => op end subroutine eval_node_set_op1_str subroutine eval_node_set_op2_log (en, op) type(eval_node_t), intent(inout) :: en procedure(binary_log) :: op en%op2_log => op end subroutine eval_node_set_op2_log subroutine eval_node_set_op2_int (en, op) type(eval_node_t), intent(inout) :: en procedure(binary_int) :: op en%op2_int => op end subroutine eval_node_set_op2_int subroutine eval_node_set_op2_real (en, op) type(eval_node_t), intent(inout) :: en procedure(binary_real) :: op en%op2_real => op end subroutine eval_node_set_op2_real subroutine eval_node_set_op2_cmplx (en, op) type(eval_node_t), intent(inout) :: en procedure(binary_cmplx) :: op en%op2_cmplx => op end subroutine eval_node_set_op2_cmplx subroutine eval_node_set_op2_pdg (en, op) type(eval_node_t), intent(inout) :: en procedure(binary_pdg) :: op en%op2_pdg => op end subroutine eval_node_set_op2_pdg subroutine eval_node_set_op2_sev (en, op) type(eval_node_t), intent(inout) :: en procedure(binary_sev) :: op en%op2_sev => op end subroutine eval_node_set_op2_sev subroutine eval_node_set_op2_str (en, op) type(eval_node_t), intent(inout) :: en procedure(binary_str) :: op en%op2_str => op end subroutine eval_node_set_op2_str @ %def eval_node_set_operator @ \subsection{Specific operators} Our expression syntax contains all Fortran functions that make sense. These functions have to be provided in a form that they can be used in procedures pointers, and have the abstract interfaces above. For some intrinsic functions, we could use specific versions provided by Fortran directly. However, this has two drawbacks: (i) We should work with the values instead of the eval-nodes as argument, which complicates the interface; (ii) more importantly, the [[default]] real type need not be equivalent to double precision. This would, at least, introduce system dependencies. Finally, for operators there are no specific versions. Therefore, we write wrappers for all possible functions, at the expense of some overhead. \subsubsection{Binary numerical functions} <>= integer function add_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival + en2%ival end function add_ii real(default) function add_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival + en2%rval end function add_ir complex(default) function add_ic (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival + en2%cval end function add_ic real(default) function add_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval + en2%ival end function add_ri complex(default) function add_ci (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval + en2%ival end function add_ci complex(default) function add_cr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval + en2%rval end function add_cr complex(default) function add_rc (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval + en2%cval end function add_rc real(default) function add_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval + en2%rval end function add_rr complex(default) function add_cc (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval + en2%cval end function add_cc integer function sub_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival - en2%ival end function sub_ii real(default) function sub_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival - en2%rval end function sub_ir real(default) function sub_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval - en2%ival end function sub_ri complex(default) function sub_ic (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival - en2%cval end function sub_ic complex(default) function sub_ci (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval - en2%ival end function sub_ci complex(default) function sub_cr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval - en2%rval end function sub_cr complex(default) function sub_rc (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval - en2%cval end function sub_rc real(default) function sub_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval - en2%rval end function sub_rr complex(default) function sub_cc (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval - en2%cval end function sub_cc integer function mul_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival * en2%ival end function mul_ii real(default) function mul_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival * en2%rval end function mul_ir real(default) function mul_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval * en2%ival end function mul_ri complex(default) function mul_ic (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival * en2%cval end function mul_ic complex(default) function mul_ci (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval * en2%ival end function mul_ci complex(default) function mul_rc (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval * en2%cval end function mul_rc complex(default) function mul_cr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval * en2%rval end function mul_cr real(default) function mul_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval * en2%rval end function mul_rr complex(default) function mul_cc (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval * en2%cval end function mul_cc integer function div_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (en2%ival == 0) then if (en1%ival >= 0) then call msg_warning ("division by zero: " // int2char (en1%ival) // & " / 0 ; result set to 0") else call msg_warning ("division by zero: (" // int2char (en1%ival) // & ") / 0 ; result set to 0") end if y = 0 return end if y = en1%ival / en2%ival end function div_ii real(default) function div_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival / en2%rval end function div_ir real(default) function div_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval / en2%ival end function div_ri complex(default) function div_ic (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival / en2%cval end function div_ic complex(default) function div_ci (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval / en2%ival end function div_ci complex(default) function div_rc (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval / en2%cval end function div_rc complex(default) function div_cr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval / en2%rval end function div_cr real(default) function div_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval / en2%rval end function div_rr complex(default) function div_cc (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval / en2%cval end function div_cc integer function pow_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 integer :: a, b real(default) :: rres a = en1%ival b = en2%ival if ((a == 0) .and. (b < 0)) then call msg_warning ("division by zero: " // int2char (a) // & " ^ (" // int2char (b) // ") ; result set to 0") y = 0 return end if rres = real(a, default) ** b y = rres if (real(y, default) /= rres) then if (b < 0) then call msg_warning ("result of all-integer operation " // & int2char (a) // " ^ (" // int2char (b) // & ") has been trucated to "// int2char (y), & [ var_str ("Chances are that you want to use " // & "reals instead of integers at this point.") ]) else call msg_warning ("integer overflow in " // int2char (a) // & " ^ " // int2char (b) // " ; result is " // int2char (y), & [ var_str ("Using reals instead of integers might help.")]) end if end if end function pow_ii real(default) function pow_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval ** en2%ival end function pow_ri complex(default) function pow_ci (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval ** en2%ival end function pow_ci real(default) function pow_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival ** en2%rval end function pow_ir real(default) function pow_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval ** en2%rval end function pow_rr complex(default) function pow_cr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval ** en2%rval end function pow_cr complex(default) function pow_ic (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival ** en2%cval end function pow_ic complex(default) function pow_rc (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval ** en2%cval end function pow_rc complex(default) function pow_cc (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%cval ** en2%cval end function pow_cc integer function max_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = max (en1%ival, en2%ival) end function max_ii real(default) function max_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = max (real (en1%ival, default), en2%rval) end function max_ir real(default) function max_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = max (en1%rval, real (en2%ival, default)) end function max_ri real(default) function max_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = max (en1%rval, en2%rval) end function max_rr integer function min_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = min (en1%ival, en2%ival) end function min_ii real(default) function min_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = min (real (en1%ival, default), en2%rval) end function min_ir real(default) function min_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = min (en1%rval, real (en2%ival, default)) end function min_ri real(default) function min_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = min (en1%rval, en2%rval) end function min_rr integer function mod_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = mod (en1%ival, en2%ival) end function mod_ii real(default) function mod_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = mod (real (en1%ival, default), en2%rval) end function mod_ir real(default) function mod_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = mod (en1%rval, real (en2%ival, default)) end function mod_ri real(default) function mod_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = mod (en1%rval, en2%rval) end function mod_rr integer function modulo_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = modulo (en1%ival, en2%ival) end function modulo_ii real(default) function modulo_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = modulo (real (en1%ival, default), en2%rval) end function modulo_ir real(default) function modulo_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = modulo (en1%rval, real (en2%ival, default)) end function modulo_ri real(default) function modulo_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = modulo (en1%rval, en2%rval) end function modulo_rr @ \subsubsection{Unary numeric functions} <>= real(default) function real_i (en) result (y) type(eval_node_t), intent(in) :: en y = en%ival end function real_i real(default) function real_c (en) result (y) type(eval_node_t), intent(in) :: en y = en%cval end function real_c integer function int_r (en) result (y) type(eval_node_t), intent(in) :: en y = en%rval end function int_r complex(default) function cmplx_i (en) result (y) type(eval_node_t), intent(in) :: en y = en%ival end function cmplx_i integer function int_c (en) result (y) type(eval_node_t), intent(in) :: en y = en%cval end function int_c complex(default) function cmplx_r (en) result (y) type(eval_node_t), intent(in) :: en y = en%rval end function cmplx_r integer function nint_r (en) result (y) type(eval_node_t), intent(in) :: en y = nint (en%rval) end function nint_r integer function floor_r (en) result (y) type(eval_node_t), intent(in) :: en y = floor (en%rval) end function floor_r integer function ceiling_r (en) result (y) type(eval_node_t), intent(in) :: en y = ceiling (en%rval) end function ceiling_r integer function neg_i (en) result (y) type(eval_node_t), intent(in) :: en y = - en%ival end function neg_i real(default) function neg_r (en) result (y) type(eval_node_t), intent(in) :: en y = - en%rval end function neg_r complex(default) function neg_c (en) result (y) type(eval_node_t), intent(in) :: en y = - en%cval end function neg_c integer function abs_i (en) result (y) type(eval_node_t), intent(in) :: en y = abs (en%ival) end function abs_i real(default) function abs_r (en) result (y) type(eval_node_t), intent(in) :: en y = abs (en%rval) end function abs_r real(default) function abs_c (en) result (y) type(eval_node_t), intent(in) :: en y = abs (en%cval) end function abs_c integer function conjg_i (en) result (y) type(eval_node_t), intent(in) :: en y = en%ival end function conjg_i real(default) function conjg_r (en) result (y) type(eval_node_t), intent(in) :: en y = en%rval end function conjg_r complex(default) function conjg_c (en) result (y) type(eval_node_t), intent(in) :: en y = conjg (en%cval) end function conjg_c integer function sgn_i (en) result (y) type(eval_node_t), intent(in) :: en y = sign (1, en%ival) end function sgn_i real(default) function sgn_r (en) result (y) type(eval_node_t), intent(in) :: en y = sign (1._default, en%rval) end function sgn_r real(default) function sqrt_r (en) result (y) type(eval_node_t), intent(in) :: en y = sqrt (en%rval) end function sqrt_r real(default) function exp_r (en) result (y) type(eval_node_t), intent(in) :: en y = exp (en%rval) end function exp_r real(default) function log_r (en) result (y) type(eval_node_t), intent(in) :: en y = log (en%rval) end function log_r real(default) function log10_r (en) result (y) type(eval_node_t), intent(in) :: en y = log10 (en%rval) end function log10_r complex(default) function sqrt_c (en) result (y) type(eval_node_t), intent(in) :: en y = sqrt (en%cval) end function sqrt_c complex(default) function exp_c (en) result (y) type(eval_node_t), intent(in) :: en y = exp (en%cval) end function exp_c complex(default) function log_c (en) result (y) type(eval_node_t), intent(in) :: en y = log (en%cval) end function log_c real(default) function sin_r (en) result (y) type(eval_node_t), intent(in) :: en y = sin (en%rval) end function sin_r real(default) function cos_r (en) result (y) type(eval_node_t), intent(in) :: en y = cos (en%rval) end function cos_r real(default) function tan_r (en) result (y) type(eval_node_t), intent(in) :: en y = tan (en%rval) end function tan_r real(default) function asin_r (en) result (y) type(eval_node_t), intent(in) :: en y = asin (en%rval) end function asin_r real(default) function acos_r (en) result (y) type(eval_node_t), intent(in) :: en y = acos (en%rval) end function acos_r real(default) function atan_r (en) result (y) type(eval_node_t), intent(in) :: en y = atan (en%rval) end function atan_r complex(default) function sin_c (en) result (y) type(eval_node_t), intent(in) :: en y = sin (en%cval) end function sin_c complex(default) function cos_c (en) result (y) type(eval_node_t), intent(in) :: en y = cos (en%cval) end function cos_c real(default) function sinh_r (en) result (y) type(eval_node_t), intent(in) :: en y = sinh (en%rval) end function sinh_r real(default) function cosh_r (en) result (y) type(eval_node_t), intent(in) :: en y = cosh (en%rval) end function cosh_r real(default) function tanh_r (en) result (y) type(eval_node_t), intent(in) :: en y = tanh (en%rval) end function tanh_r !!! These are F2008 additions but accepted by nagfor 5.3 and gfortran 4.6+ !!! Currently not used. ! real(default) function asinh_r (en) result (y) ! type(eval_node_t), intent(in) :: en ! y = asinh (en%rval) ! end function asinh_r ! real(default) function acosh_r (en) result (y) ! type(eval_node_t), intent(in) :: en ! y = acosh (en%rval) ! end function acosh_r ! real(default) function atanh_r (en) result (y) ! type(eval_node_t), intent(in) :: en ! y = atanh (en%rval) ! end function atanh_r @ \subsubsection{Binary logical functions} Logical expressions: <>= logical function ignore_first_ll (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en2%lval end function ignore_first_ll logical function or_ll (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%lval .or. en2%lval end function or_ll logical function and_ll (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%lval .and. en2%lval end function and_ll @ Comparisons: <>= logical function comp_lt_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival < en2%ival end function comp_lt_ii logical function comp_lt_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival < en2%rval end function comp_lt_ir logical function comp_lt_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval < en2%ival end function comp_lt_ri logical function comp_lt_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval < en2%rval end function comp_lt_rr logical function comp_gt_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival > en2%ival end function comp_gt_ii logical function comp_gt_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival > en2%rval end function comp_gt_ir logical function comp_gt_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval > en2%ival end function comp_gt_ri logical function comp_gt_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval > en2%rval end function comp_gt_rr logical function comp_le_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival <= en2%ival end function comp_le_ii logical function comp_le_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival <= en2%rval end function comp_le_ir logical function comp_le_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval <= en2%ival end function comp_le_ri logical function comp_le_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval <= en2%rval end function comp_le_rr logical function comp_ge_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival >= en2%ival end function comp_ge_ii logical function comp_ge_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival >= en2%rval end function comp_ge_ir logical function comp_ge_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval >= en2%ival end function comp_ge_ri logical function comp_ge_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval >= en2%rval end function comp_ge_rr logical function comp_eq_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival == en2%ival end function comp_eq_ii logical function comp_eq_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival == en2%rval end function comp_eq_ir logical function comp_eq_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval == en2%ival end function comp_eq_ri logical function comp_eq_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval == en2%rval end function comp_eq_rr logical function comp_eq_ss (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%sval == en2%sval end function comp_eq_ss logical function comp_ne_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival /= en2%ival end function comp_ne_ii logical function comp_ne_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%ival /= en2%rval end function comp_ne_ir logical function comp_ne_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval /= en2%ival end function comp_ne_ri logical function comp_ne_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%rval /= en2%rval end function comp_ne_rr logical function comp_ne_ss (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 y = en1%sval /= en2%sval end function comp_ne_ss @ Comparisons with tolerance: <>= logical function comp_se_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = abs (en1%ival - en2%ival) <= en1%tolerance else y = en1%ival == en2%ival end if end function comp_se_ii logical function comp_se_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = abs (en1%rval - en2%ival) <= en1%tolerance else y = en1%rval == en2%ival end if end function comp_se_ri logical function comp_se_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = abs (en1%ival - en2%rval) <= en1%tolerance else y = en1%ival == en2%rval end if end function comp_se_ir logical function comp_se_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = abs (en1%rval - en2%rval) <= en1%tolerance else y = en1%rval == en2%rval end if end function comp_se_rr logical function comp_ns_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = abs (en1%ival - en2%ival) > en1%tolerance else y = en1%ival /= en2%ival end if end function comp_ns_ii logical function comp_ns_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = abs (en1%rval - en2%ival) > en1%tolerance else y = en1%rval /= en2%ival end if end function comp_ns_ri logical function comp_ns_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = abs (en1%ival - en2%rval) > en1%tolerance else y = en1%ival /= en2%rval end if end function comp_ns_ir logical function comp_ns_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = abs (en1%rval - en2%rval) > en1%tolerance else y = en1%rval /= en2%rval end if end function comp_ns_rr logical function comp_ls_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%ival <= en2%ival + en1%tolerance else y = en1%ival <= en2%ival end if end function comp_ls_ii logical function comp_ls_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%rval <= en2%ival + en1%tolerance else y = en1%rval <= en2%ival end if end function comp_ls_ri logical function comp_ls_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%ival <= en2%rval + en1%tolerance else y = en1%ival <= en2%rval end if end function comp_ls_ir logical function comp_ls_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%rval <= en2%rval + en1%tolerance else y = en1%rval <= en2%rval end if end function comp_ls_rr logical function comp_ll_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%ival < en2%ival - en1%tolerance else y = en1%ival < en2%ival end if end function comp_ll_ii logical function comp_ll_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%rval < en2%ival - en1%tolerance else y = en1%rval < en2%ival end if end function comp_ll_ri logical function comp_ll_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%ival < en2%rval - en1%tolerance else y = en1%ival < en2%rval end if end function comp_ll_ir logical function comp_ll_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%rval < en2%rval - en1%tolerance else y = en1%rval < en2%rval end if end function comp_ll_rr logical function comp_gs_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%ival >= en2%ival - en1%tolerance else y = en1%ival >= en2%ival end if end function comp_gs_ii logical function comp_gs_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%rval >= en2%ival - en1%tolerance else y = en1%rval >= en2%ival end if end function comp_gs_ri logical function comp_gs_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%ival >= en2%rval - en1%tolerance else y = en1%ival >= en2%rval end if end function comp_gs_ir logical function comp_gs_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%rval >= en2%rval - en1%tolerance else y = en1%rval >= en2%rval end if end function comp_gs_rr logical function comp_gg_ii (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%ival > en2%ival + en1%tolerance else y = en1%ival > en2%ival end if end function comp_gg_ii logical function comp_gg_ri (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%rval > en2%ival + en1%tolerance else y = en1%rval > en2%ival end if end function comp_gg_ri logical function comp_gg_ir (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%ival > en2%rval + en1%tolerance else y = en1%ival > en2%rval end if end function comp_gg_ir logical function comp_gg_rr (en1, en2) result (y) type(eval_node_t), intent(in) :: en1, en2 if (associated (en1%tolerance)) then y = en1%rval > en2%rval + en1%tolerance else y = en1%rval > en2%rval end if end function comp_gg_rr @ \subsubsection{Unary logical functions} <>= logical function not_l (en) result (y) type(eval_node_t), intent(in) :: en y = .not. en%lval end function not_l @ \subsubsection{Unary PDG-array functions} Make a PDG-array object from an integer. <>= subroutine pdg_i (pdg_array, en) type(pdg_array_t), intent(out) :: pdg_array type(eval_node_t), intent(in) :: en pdg_array = en%ival end subroutine pdg_i @ \subsubsection{Binary PDG-array functions} Concatenate two PDG-array objects. <>= subroutine concat_cc (pdg_array, en1, en2) type(pdg_array_t), intent(out) :: pdg_array type(eval_node_t), intent(in) :: en1, en2 pdg_array = en1%aval // en2%aval end subroutine concat_cc @ \subsubsection{Unary particle-list functions} Combine all particles of the first argument. If [[en0]] is present, create a mask which is true only for those particles that pass the test. <>= subroutine collect_p (subevt, en1, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout), optional :: en0 logical, dimension(:), allocatable :: mask1 integer :: n, i n = subevt_get_length (en1%pval) allocate (mask1 (n)) if (present (en0)) then do i = 1, n en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) call eval_node_evaluate (en0) mask1(i) = en0%lval end do else mask1 = .true. end if call subevt_collect (subevt, en1%pval, mask1) end subroutine collect_p @ %def collect_p @ Cluster the particles of the first argument. If [[en0]] is present, create a mask which is true only for those particles that pass the test. <>= subroutine cluster_p (subevt, en1, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout), optional :: en0 logical, dimension(:), allocatable :: mask1 integer :: n, i !!! Should not be initialized for every event type(jet_definition_t) :: jet_def logical :: keep_jets call jet_def%init (en1%jet_algorithm, en1%jet_r, en1%jet_p, en1%jet_ycut) n = subevt_get_length (en1%pval) allocate (mask1 (n)) if (present (en0)) then do i = 1, n en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) call eval_node_evaluate (en0) mask1(i) = en0%lval end do else mask1 = .true. end if if (associated (en1%var_list)) then keep_jets = en1%var_list%get_lval (var_str("?keep_flavors_when_clustering")) else keep_jets = .false. end if call subevt_cluster (subevt, en1%pval, mask1, jet_def, keep_jets) call jet_def%final () end subroutine cluster_p @ %def cluster_p @ Select all particles of the first argument. If [[en0]] is present, create a mask which is true only for those particles that pass the test. <>= subroutine select_p (subevt, en1, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout), optional :: en0 logical, dimension(:), allocatable :: mask1 integer :: n, i n = subevt_get_length (en1%pval) allocate (mask1 (n)) if (present (en0)) then do i = 1, subevt_get_length (en1%pval) en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) call eval_node_evaluate (en0) mask1(i) = en0%lval end do else mask1 = .true. end if call subevt_select (subevt, en1%pval, mask1) end subroutine select_p @ %def select_p @ Extract the particle with index given by [[en0]] from the argument list. Negative indices count from the end. If [[en0]] is absent, extract the first particle. The result is a list with a single entry, or no entries if the original list was empty or if the index is out of range. This function has no counterpart with two arguments. <>= subroutine extract_p (subevt, en1, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout), optional :: en0 integer :: index if (present (en0)) then call eval_node_evaluate (en0) select case (en0%result_type) case (V_INT); index = en0%ival case default call eval_node_write (en0) call msg_fatal (" Index parameter of 'extract' must be integer.") end select else index = 1 end if call subevt_extract (subevt, en1%pval, index) end subroutine extract_p @ %def extract_p @ Sort the subevent according to the result of evaluating [[en0]]. If [[en0]] is absent, sort by default method (PDG code, particles before antiparticles). <>= subroutine sort_p (subevt, en1, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout), optional :: en0 integer, dimension(:), allocatable :: ival real(default), dimension(:), allocatable :: rval integer :: i, n n = subevt_get_length (en1%pval) if (present (en0)) then select case (en0%result_type) case (V_INT); allocate (ival (n)) case (V_REAL); allocate (rval (n)) end select do i = 1, n en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) call eval_node_evaluate (en0) select case (en0%result_type) case (V_INT); ival(i) = en0%ival case (V_REAL); rval(i) = en0%rval end select end do select case (en0%result_type) case (V_INT); call subevt_sort (subevt, en1%pval, ival) case (V_REAL); call subevt_sort (subevt, en1%pval, rval) end select else call subevt_sort (subevt, en1%pval) end if end subroutine sort_p @ %def sort_p @ The following functions return a logical value. [[all]] evaluates to true if the condition [[en0]] is true for all elements of the subevent. [[any]] and [[no]] are analogous. <>= function all_p (en1, en0) result (lval) logical :: lval type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout) :: en0 integer :: i, n n = subevt_get_length (en1%pval) lval = .true. do i = 1, n en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) call eval_node_evaluate (en0) lval = en0%lval if (.not. lval) exit end do end function all_p function any_p (en1, en0) result (lval) logical :: lval type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout) :: en0 integer :: i, n n = subevt_get_length (en1%pval) lval = .false. do i = 1, n en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) call eval_node_evaluate (en0) lval = en0%lval if (lval) exit end do end function any_p function no_p (en1, en0) result (lval) logical :: lval type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout) :: en0 integer :: i, n n = subevt_get_length (en1%pval) lval = .true. do i = 1, n en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) call eval_node_evaluate (en0) lval = .not. en0%lval if (lval) exit end do end function no_p @ %def all_p any_p no_p @ This is the interface to user-supplied observables. The node [[en0]] evaluates to a string that indicates the procedure name. We search for the procedure in the dynamic library and load it into the procedure pointer which is then called. [[en1]] is the subevent on which the external code operates. The external function returns a [[c_int]], which we translate into a real value. <>= function user_obs_int_p (en0, prt1) result (ival) integer :: ival type(eval_node_t), intent(inout) :: en0 type(prt_t), intent(in) :: prt1 type(string_t) :: name procedure(user_obs_int_unary), pointer :: user_obs call eval_node_evaluate (en0) if (en0%value_is_known) then select case (en0%result_type) case (V_STR); name = en0%sval case default call msg_bug ("user_obs: procedure name must be a string") name = "" end select call c_f_procpointer (user_code_find_proc (name), user_obs) ival = user_obs (c_prt (prt1)) else call eval_node_write_rec (en0) call msg_fatal ("User observable name is undefined") end if end function user_obs_int_p function user_obs_real_p (en0, prt1) result (rval) real(default) :: rval type(eval_node_t), intent(inout) :: en0 type(prt_t), intent(in) :: prt1 type(string_t) :: name procedure(user_obs_real_unary), pointer :: user_obs call eval_node_evaluate (en0) if (en0%value_is_known) then select case (en0%result_type) case (V_STR); name = en0%sval case default call msg_bug ("user_obs: procedure name must be a string") name = "" end select call c_f_procpointer (user_code_find_proc (name), user_obs) rval = user_obs (c_prt (prt1)) else call eval_node_write_rec (en0) call msg_fatal ("User observable name is undefined") end if end function user_obs_real_p @ %def user_obs_int_p @ %def user_obs_real_p @ This is the interface to user-supplied cut code. The node [[en0]] evaluates to a string that indicates the procedure name. <>= function user_cut_p (en1, en0) result (lval) logical :: lval type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout) :: en0 type(string_t) :: name procedure(user_cut_fun), pointer :: user_cut call eval_node_evaluate (en0) select case (en0%result_type) case (V_STR); name = en0%sval case default call msg_bug ("user_cut: procedure name must be a string") name = "" end select call c_f_procpointer (user_code_find_proc (name), user_cut) lval = user_cut (c_prt (en1%pval), & int (subevt_get_length (en1%pval), kind=c_int)) & /= 0 end function user_cut_p @ %def user_cut_p @ The following function returns an integer value, namely the number of particles for which the condition is true. If there is no condition, it returns simply the length of the subevent. A function would be more natural. Making it a subroutine avoids another compiler bug (internal error in nagfor 5.2 (649)). (See the interface [[unary_evi]].) <>= subroutine count_a (ival, en1, en0) integer, intent(out) :: ival type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout), optional :: en0 integer :: i, n, count n = subevt_get_length (en1%pval) if (present (en0)) then count = 0 do i = 1, n en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) call eval_node_evaluate (en0) if (en0%lval) count = count + 1 end do ival = count else ival = n end if end subroutine count_a @ %def count_a @ This evaluates a user-defined event-shape observable for the current subevent. <>= subroutine user_event_shape_a (rval, en1, en0) real(default), intent(out) :: rval type(eval_node_t), intent(in) :: en1 type(eval_node_t), intent(inout), optional :: en0 type(string_t) :: name procedure(user_event_shape_fun), pointer :: user_event_shape if (.not. present (en0)) call msg_bug & ("user_event_shape called without procedure name") call eval_node_evaluate (en0) select case (en0%result_type) case (V_STR); name = en0%sval case default call msg_bug ("user_event_shape: procedure name must be a string") name = "" end select call c_f_procpointer (user_code_find_proc (name), user_event_shape) rval = user_event_shape (c_prt (en1%pval), & int (subevt_get_length (en1%pval), kind=c_int)) end subroutine user_event_shape_a @ %def user_event_shape_a @ \subsubsection{Binary particle-list functions} This joins two subevents, stored in the evaluation nodes [[en1]] and [[en2]]. If [[en0]] is also present, it amounts to a logical test returning true or false for every pair of particles. A particle of the second list gets a mask entry only if it passes the test for all particles of the first list. <>= subroutine join_pp (subevt, en1, en2, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout), optional :: en0 logical, dimension(:), allocatable :: mask2 integer :: i, j, n1, n2 n1 = subevt_get_length (en1%pval) n2 = subevt_get_length (en2%pval) allocate (mask2 (n2)) mask2 = .true. if (present (en0)) then do i = 1, n1 en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) do j = 1, n2 en0%prt2 = subevt_get_prt (en2%pval, j) call eval_node_evaluate (en0) mask2(j) = mask2(j) .and. en0%lval end do end do end if call subevt_join (subevt, en1%pval, en2%pval, mask2) end subroutine join_pp @ %def join_pp @ Combine two subevents, i.e., make a list of composite particles built from all possible particle pairs from the two lists. If [[en0]] is present, create a mask which is true only for those pairs that pass the test. <>= subroutine combine_pp (subevt, en1, en2, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout), optional :: en0 logical, dimension(:,:), allocatable :: mask12 integer :: i, j, n1, n2 n1 = subevt_get_length (en1%pval) n2 = subevt_get_length (en2%pval) if (present (en0)) then allocate (mask12 (n1, n2)) do i = 1, n1 en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) do j = 1, n2 en0%prt2 = subevt_get_prt (en2%pval, j) call eval_node_evaluate (en0) mask12(i,j) = en0%lval end do end do call subevt_combine (subevt, en1%pval, en2%pval, mask12) else call subevt_combine (subevt, en1%pval, en2%pval) end if end subroutine combine_pp @ %def combine_pp @ Combine all particles of the first argument. If [[en0]] is present, create a mask which is true only for those particles that pass the test w.r.t. all particles in the second argument. If [[en0]] is absent, the second argument is ignored. <>= subroutine collect_pp (subevt, en1, en2, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout), optional :: en0 logical, dimension(:), allocatable :: mask1 integer :: i, j, n1, n2 n1 = subevt_get_length (en1%pval) n2 = subevt_get_length (en2%pval) allocate (mask1 (n1)) mask1 = .true. if (present (en0)) then do i = 1, n1 en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) do j = 1, n2 en0%prt2 = subevt_get_prt (en2%pval, j) call eval_node_evaluate (en0) mask1(i) = mask1(i) .and. en0%lval end do end do end if call subevt_collect (subevt, en1%pval, mask1) end subroutine collect_pp @ %def collect_pp @ Select all particles of the first argument. If [[en0]] is present, create a mask which is true only for those particles that pass the test w.r.t. all particles in the second argument. If [[en0]] is absent, the second argument is ignored, and the first argument is transferred unchanged. (This case is not very useful, of course.) <>= subroutine select_pp (subevt, en1, en2, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout), optional :: en0 logical, dimension(:), allocatable :: mask1 integer :: i, j, n1, n2 n1 = subevt_get_length (en1%pval) n2 = subevt_get_length (en2%pval) allocate (mask1 (n1)) mask1 = .true. if (present (en0)) then do i = 1, n1 en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) do j = 1, n2 en0%prt2 = subevt_get_prt (en2%pval, j) call eval_node_evaluate (en0) mask1(i) = mask1(i) .and. en0%lval end do end do end if call subevt_select (subevt, en1%pval, mask1) end subroutine select_pp @ %def select_pp @ Sort the first subevent according to the result of evaluating [[en0]]. From the second subevent, only the first element is taken as reference. If [[en0]] is absent, we sort by default method (PDG code, particles before antiparticles). <>= subroutine sort_pp (subevt, en1, en2, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout), optional :: en0 integer, dimension(:), allocatable :: ival real(default), dimension(:), allocatable :: rval integer :: i, n1 n1 = subevt_get_length (en1%pval) if (present (en0)) then select case (en0%result_type) case (V_INT); allocate (ival (n1)) case (V_REAL); allocate (rval (n1)) end select do i = 1, n1 en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) en0%prt2 = subevt_get_prt (en2%pval, 1) call eval_node_evaluate (en0) select case (en0%result_type) case (V_INT); ival(i) = en0%ival case (V_REAL); rval(i) = en0%rval end select end do select case (en0%result_type) case (V_INT); call subevt_sort (subevt, en1%pval, ival) case (V_REAL); call subevt_sort (subevt, en1%pval, rval) end select else call subevt_sort (subevt, en1%pval) end if end subroutine sort_pp @ %def sort_pp @ The following functions return a logical value. [[all]] evaluates to true if the condition [[en0]] is true for all valid element pairs of both subevents. Invalid pairs (with common [[src]] entry) are ignored. [[any]] and [[no]] are analogous. <>= function all_pp (en1, en2, en0) result (lval) logical :: lval type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout) :: en0 integer :: i, j, n1, n2 n1 = subevt_get_length (en1%pval) n2 = subevt_get_length (en2%pval) lval = .true. LOOP1: do i = 1, n1 en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) do j = 1, n2 en0%prt2 = subevt_get_prt (en2%pval, j) if (are_disjoint (en0%prt1, en0%prt2)) then call eval_node_evaluate (en0) lval = en0%lval if (.not. lval) exit LOOP1 end if end do end do LOOP1 end function all_pp function any_pp (en1, en2, en0) result (lval) logical :: lval type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout) :: en0 integer :: i, j, n1, n2 n1 = subevt_get_length (en1%pval) n2 = subevt_get_length (en2%pval) lval = .false. LOOP1: do i = 1, n1 en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) do j = 1, n2 en0%prt2 = subevt_get_prt (en2%pval, j) if (are_disjoint (en0%prt1, en0%prt2)) then call eval_node_evaluate (en0) lval = en0%lval if (lval) exit LOOP1 end if end do end do LOOP1 end function any_pp function no_pp (en1, en2, en0) result (lval) logical :: lval type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout) :: en0 integer :: i, j, n1, n2 n1 = subevt_get_length (en1%pval) n2 = subevt_get_length (en2%pval) lval = .true. LOOP1: do i = 1, n1 en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) do j = 1, n2 en0%prt2 = subevt_get_prt (en2%pval, j) if (are_disjoint (en0%prt1, en0%prt2)) then call eval_node_evaluate (en0) lval = .not. en0%lval if (lval) exit LOOP1 end if end do end do LOOP1 end function no_pp @ %def all_pp any_pp no_pp @ This function evaluates an observable for a pair of particles. From the two particle lists, we take the first pair without [[src]] overlap. If there is no valid pair, we revert the status of the value to unknown. <>= subroutine eval_pp (en1, en2, en0, rval, is_known) type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout) :: en0 real(default), intent(out) :: rval logical, intent(out) :: is_known integer :: i, j, n1, n2 n1 = subevt_get_length (en1%pval) n2 = subevt_get_length (en2%pval) rval = 0 is_known = .false. LOOP1: do i = 1, n1 en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) do j = 1, n2 en0%prt2 = subevt_get_prt (en2%pval, j) if (are_disjoint (en0%prt1, en0%prt2)) then call eval_node_evaluate (en0) rval = en0%rval is_known = .true. exit LOOP1 end if end do end do LOOP1 end subroutine eval_pp @ %def eval_pp @ This is the interface to user-supplied observables. The node [[en0]] evaluates to a string that indicates the procedure name. We search for the procedure in the dynamic library and load it into the procedure pointer which is then called. [[en1]] is the subevent on which the external code operates. The external function returns a [[c_int]], which we translate into a real value. <>= function user_obs_int_pp (en0, prt1, prt2) result (ival) integer :: ival type(eval_node_t), intent(inout) :: en0 type(prt_t), intent(in) :: prt1, prt2 type(string_t) :: name procedure(user_obs_int_binary), pointer :: user_obs call eval_node_evaluate (en0) if (en0%value_is_known) then select case (en0%result_type) case (V_STR); name = en0%sval case default call msg_bug ("user_obs: procedure name must be a string") name = "" end select call c_f_procpointer (user_code_find_proc (name), user_obs) ival = user_obs (c_prt (prt1), c_prt (prt2)) else call eval_node_write_rec (en0) call msg_fatal ("User observable name is undefined") end if end function user_obs_int_pp function user_obs_real_pp (en0, prt1, prt2) result (rval) real(default) :: rval type(eval_node_t), intent(inout) :: en0 type(prt_t), intent(in) :: prt1, prt2 type(string_t) :: name procedure(user_obs_real_binary), pointer :: user_obs call eval_node_evaluate (en0) if (en0%value_is_known) then select case (en0%result_type) case (V_STR); name = en0%sval case default call msg_bug ("user_obs: procedure name must be a string") name = "" end select call c_f_procpointer (user_code_find_proc (name), user_obs) rval = user_obs (c_prt (prt1), c_prt (prt2)) else call eval_node_write_rec (en0) call msg_fatal ("User observable name is undefined") end if end function user_obs_real_pp @ %def user_obs_int_pp @ %def user_obs_real_pp @ The following function returns an integer value, namely the number of valid particle-pairs from both lists for which the condition is true. Invalid pairs (with common [[src]] entry) are ignored. If there is no condition, it returns the number of valid particle pairs. A function would be more natural. Making it a subroutine avoids another compiler bug (internal error in nagfor 5.2 (649)). (See the interface [[binary_num]].) <>= subroutine count_pp (ival, en1, en2, en0) integer, intent(out) :: ival type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout), optional :: en0 integer :: i, j, n1, n2, count n1 = subevt_get_length (en1%pval) n2 = subevt_get_length (en2%pval) if (present (en0)) then count = 0 do i = 1, n1 en0%index = i en0%prt1 = subevt_get_prt (en1%pval, i) do j = 1, n2 en0%prt2 = subevt_get_prt (en2%pval, j) if (are_disjoint (en0%prt1, en0%prt2)) then call eval_node_evaluate (en0) if (en0%lval) count = count + 1 end if end do end do else count = 0 do i = 1, n1 do j = 1, n2 if (are_disjoint (subevt_get_prt (en1%pval, i), & subevt_get_prt (en2%pval, j))) then count = count + 1 end if end do end do end if ival = count end subroutine count_pp @ %def count_pp @ This function makes up a subevent from the second argument which consists only of particles which match the PDG code array (first argument). <>= subroutine select_pdg_ca (subevt, en1, en2, en0) type(subevt_t), intent(inout) :: subevt type(eval_node_t), intent(in) :: en1, en2 type(eval_node_t), intent(inout), optional :: en0 if (present (en0)) then call subevt_select_pdg_code (subevt, en1%aval, en2%pval, en0%ival) else call subevt_select_pdg_code (subevt, en1%aval, en2%pval) end if end subroutine select_pdg_ca @ %def select_pdg_ca @ \subsubsection{Binary string functions} Currently, the only string operation is concatenation. <>= subroutine concat_ss (string, en1, en2) type(string_t), intent(out) :: string type(eval_node_t), intent(in) :: en1, en2 string = en1%sval // en2%sval end subroutine concat_ss @ %def concat_ss @ \subsection{Compiling the parse tree} The evaluation tree is built recursively by following a parse tree. Evaluate an expression. The requested type is given as an optional argument; default is numeric (integer or real). <>= recursive subroutine eval_node_compile_genexpr & (en, pn, var_list, result_type) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list integer, intent(in), optional :: result_type if (debug_active (D_MODEL_F)) then print *, "read genexpr"; call parse_node_write (pn) end if if (present (result_type)) then select case (result_type) case (V_INT, V_REAL, V_CMPLX) call eval_node_compile_expr (en, pn, var_list) case (V_LOG) call eval_node_compile_lexpr (en, pn, var_list) case (V_SEV) call eval_node_compile_pexpr (en, pn, var_list) case (V_PDG) call eval_node_compile_cexpr (en, pn, var_list) case (V_STR) call eval_node_compile_sexpr (en, pn, var_list) end select else call eval_node_compile_expr (en, pn, var_list) end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done genexpr" end if end subroutine eval_node_compile_genexpr @ %def eval_node_compile_genexpr @ \subsubsection{Numeric expressions} This procedure compiles a numerical expression. This is a single term or a sum or difference of terms. We have to account for all combinations of integer and real arguments. If both are constant, we immediately do the calculation and allocate a constant node. <>= recursive subroutine eval_node_compile_expr (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_term, pn_addition, pn_op, pn_arg type(eval_node_t), pointer :: en1, en2 type(string_t) :: key integer :: t1, t2, t if (debug_active (D_MODEL_F)) then print *, "read expr"; call parse_node_write (pn) end if pn_term => parse_node_get_sub_ptr (pn) select case (char (parse_node_get_rule_key (pn_term))) case ("term") call eval_node_compile_term (en, pn_term, var_list) pn_addition => parse_node_get_next_ptr (pn_term, tag="addition") case ("addition") en => null () pn_addition => pn_term case default call parse_node_mismatch ("term|addition", pn) end select do while (associated (pn_addition)) pn_op => parse_node_get_sub_ptr (pn_addition) pn_arg => parse_node_get_next_ptr (pn_op, tag="term") call eval_node_compile_term (en2, pn_arg, var_list) t2 = en2%result_type if (associated (en)) then en1 => en t1 = en1%result_type else allocate (en1) select case (t2) case (V_INT); call eval_node_init_int (en1, 0) case (V_REAL); call eval_node_init_real (en1, 0._default) case (V_CMPLX); call eval_node_init_cmplx (en1, cmplx & (0._default, 0._default, kind=default)) end select t1 = t2 end if t = numeric_result_type (t1, t2) allocate (en) key = parse_node_get_key (pn_op) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then select case (char (key)) case ("+") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_int (en, add_ii (en1, en2)) case (V_REAL); call eval_node_init_real (en, add_ir (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, add_ic (en1, en2)) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_real (en, add_ri (en1, en2)) case (V_REAL); call eval_node_init_real (en, add_rr (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, add_rc (en1, en2)) end select case (V_CMPLX) select case (t2) case (V_INT); call eval_node_init_cmplx (en, add_ci (en1, en2)) case (V_REAL); call eval_node_init_cmplx (en, add_cr (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, add_cc (en1, en2)) end select end select case ("-") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_int (en, sub_ii (en1, en2)) case (V_REAL); call eval_node_init_real (en, sub_ir (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, sub_ic (en1, en2)) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_real (en, sub_ri (en1, en2)) case (V_REAL); call eval_node_init_real (en, sub_rr (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, sub_rc (en1, en2)) end select case (V_CMPLX) select case (t2) case (V_INT); call eval_node_init_cmplx (en, sub_ci (en1, en2)) case (V_REAL); call eval_node_init_cmplx (en, sub_cr (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, sub_cc (en1, en2)) end select end select end select call eval_node_final_rec (en1) call eval_node_final_rec (en2) deallocate (en1, en2) else call eval_node_init_branch (en, key, t, en1, en2) select case (char (key)) case ("+") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_int (en, add_ii) case (V_REAL); call eval_node_set_op2_real (en, add_ir) case (V_CMPLX); call eval_node_set_op2_cmplx (en, add_ic) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_real (en, add_ri) case (V_REAL); call eval_node_set_op2_real (en, add_rr) case (V_CMPLX); call eval_node_set_op2_cmplx (en, add_rc) end select case (V_CMPLX) select case (t2) case (V_INT); call eval_node_set_op2_cmplx (en, add_ci) case (V_REAL); call eval_node_set_op2_cmplx (en, add_cr) case (V_CMPLX); call eval_node_set_op2_cmplx (en, add_cc) end select end select case ("-") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_int (en, sub_ii) case (V_REAL); call eval_node_set_op2_real (en, sub_ir) case (V_CMPLX); call eval_node_set_op2_cmplx (en, sub_ic) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_real (en, sub_ri) case (V_REAL); call eval_node_set_op2_real (en, sub_rr) case (V_CMPLX); call eval_node_set_op2_cmplx (en, sub_rc) end select case (V_CMPLX) select case (t2) case (V_INT); call eval_node_set_op2_cmplx (en, sub_ci) case (V_REAL); call eval_node_set_op2_cmplx (en, sub_cr) case (V_CMPLX); call eval_node_set_op2_cmplx (en, sub_cc) end select end select end select end if pn_addition => parse_node_get_next_ptr (pn_addition) end do if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done expr" end if end subroutine eval_node_compile_expr @ %def eval_node_compile_expr <>= recursive subroutine eval_node_compile_term (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_factor, pn_multiplication, pn_op, pn_arg type(eval_node_t), pointer :: en1, en2 type(string_t) :: key integer :: t1, t2, t if (debug_active (D_MODEL_F)) then print *, "read term"; call parse_node_write (pn) end if pn_factor => parse_node_get_sub_ptr (pn, tag="factor") call eval_node_compile_factor (en, pn_factor, var_list) pn_multiplication => & parse_node_get_next_ptr (pn_factor, tag="multiplication") do while (associated (pn_multiplication)) pn_op => parse_node_get_sub_ptr (pn_multiplication) pn_arg => parse_node_get_next_ptr (pn_op, tag="factor") en1 => en call eval_node_compile_factor (en2, pn_arg, var_list) t1 = en1%result_type t2 = en2%result_type t = numeric_result_type (t1, t2) allocate (en) key = parse_node_get_key (pn_op) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then select case (char (key)) case ("*") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_int (en, mul_ii (en1, en2)) case (V_REAL); call eval_node_init_real (en, mul_ir (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, mul_ic (en1, en2)) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_real (en, mul_ri (en1, en2)) case (V_REAL); call eval_node_init_real (en, mul_rr (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, mul_rc (en1, en2)) end select case (V_CMPLX) select case (t2) case (V_INT); call eval_node_init_cmplx (en, mul_ci (en1, en2)) case (V_REAL); call eval_node_init_cmplx (en, mul_cr (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, mul_cc (en1, en2)) end select end select case ("/") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_int (en, div_ii (en1, en2)) case (V_REAL); call eval_node_init_real (en, div_ir (en1, en2)) case (V_CMPLX); call eval_node_init_real (en, div_ir (en1, en2)) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_real (en, div_ri (en1, en2)) case (V_REAL); call eval_node_init_real (en, div_rr (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, div_rc (en1, en2)) end select case (V_CMPLX) select case (t2) case (V_INT); call eval_node_init_cmplx (en, div_ci (en1, en2)) case (V_REAL); call eval_node_init_cmplx (en, div_cr (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, div_cc (en1, en2)) end select end select end select call eval_node_final_rec (en1) call eval_node_final_rec (en2) deallocate (en1, en2) else call eval_node_init_branch (en, key, t, en1, en2) select case (char (key)) case ("*") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_int (en, mul_ii) case (V_REAL); call eval_node_set_op2_real (en, mul_ir) case (V_CMPLX); call eval_node_set_op2_cmplx (en, mul_ic) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_real (en, mul_ri) case (V_REAL); call eval_node_set_op2_real (en, mul_rr) case (V_CMPLX); call eval_node_set_op2_cmplx (en, mul_rc) end select case (V_CMPLX) select case (t2) case (V_INT); call eval_node_set_op2_cmplx (en, mul_ci) case (V_REAL); call eval_node_set_op2_cmplx (en, mul_cr) case (V_CMPLX); call eval_node_set_op2_cmplx (en, mul_cc) end select end select case ("/") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_int (en, div_ii) case (V_REAL); call eval_node_set_op2_real (en, div_ir) case (V_CMPLX); call eval_node_set_op2_cmplx (en, div_ic) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_real (en, div_ri) case (V_REAL); call eval_node_set_op2_real (en, div_rr) case (V_CMPLX); call eval_node_set_op2_cmplx (en, div_rc) end select case (V_CMPLX) select case (t2) case (V_INT); call eval_node_set_op2_cmplx (en, div_ci) case (V_REAL); call eval_node_set_op2_cmplx (en, div_cr) case (V_CMPLX); call eval_node_set_op2_cmplx (en, div_cc) end select end select end select end if pn_multiplication => parse_node_get_next_ptr (pn_multiplication) end do if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done term" end if end subroutine eval_node_compile_term @ %def eval_node_compile_term <>= recursive subroutine eval_node_compile_factor (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_value, pn_exponentiation, pn_op, pn_arg type(eval_node_t), pointer :: en1, en2 type(string_t) :: key integer :: t1, t2, t if (debug_active (D_MODEL_F)) then print *, "read factor"; call parse_node_write (pn) end if pn_value => parse_node_get_sub_ptr (pn) call eval_node_compile_signed_value (en, pn_value, var_list) pn_exponentiation => & parse_node_get_next_ptr (pn_value, tag="exponentiation") if (associated (pn_exponentiation)) then pn_op => parse_node_get_sub_ptr (pn_exponentiation) pn_arg => parse_node_get_next_ptr (pn_op) en1 => en call eval_node_compile_signed_value (en2, pn_arg, var_list) t1 = en1%result_type t2 = en2%result_type t = numeric_result_type (t1, t2) allocate (en) key = parse_node_get_key (pn_op) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_int (en, pow_ii (en1, en2)) case (V_REAL); call eval_node_init_real (en, pow_ir (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, pow_ic (en1, en2)) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_real (en, pow_ri (en1, en2)) case (V_REAL); call eval_node_init_real (en, pow_rr (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, pow_rc (en1, en2)) end select case (V_CMPLX) select case (t2) case (V_INT); call eval_node_init_cmplx (en, pow_ci (en1, en2)) case (V_REAL); call eval_node_init_cmplx (en, pow_cr (en1, en2)) case (V_CMPLX); call eval_node_init_cmplx (en, pow_cc (en1, en2)) end select end select call eval_node_final_rec (en1) call eval_node_final_rec (en2) deallocate (en1, en2) else call eval_node_init_branch (en, key, t, en1, en2) select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_int (en, pow_ii) case (V_REAL,V_CMPLX); call eval_type_error (pn, "exponentiation", t1) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_real (en, pow_ri) case (V_REAL); call eval_node_set_op2_real (en, pow_rr) case (V_CMPLX); call eval_type_error (pn, "exponentiation", t1) end select case (V_CMPLX) select case (t2) case (V_INT); call eval_node_set_op2_cmplx (en, pow_ci) case (V_REAL); call eval_node_set_op2_cmplx (en, pow_cr) case (V_CMPLX); call eval_node_set_op2_cmplx (en, pow_cc) end select end select end if end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done factor" end if end subroutine eval_node_compile_factor @ %def eval_node_compile_factor <>= recursive subroutine eval_node_compile_signed_value (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_arg type(eval_node_t), pointer :: en1 integer :: t if (debug_active (D_MODEL_F)) then print *, "read signed value"; call parse_node_write (pn) end if select case (char (parse_node_get_rule_key (pn))) case ("signed_value") pn_arg => parse_node_get_sub_ptr (pn, 2) call eval_node_compile_value (en1, pn_arg, var_list) t = en1%result_type allocate (en) if (en1%type == EN_CONSTANT) then select case (t) case (V_INT); call eval_node_init_int (en, neg_i (en1)) case (V_REAL); call eval_node_init_real (en, neg_r (en1)) case (V_CMPLX); call eval_node_init_cmplx (en, neg_c (en1)) end select call eval_node_final_rec (en1) deallocate (en1) else call eval_node_init_branch (en, var_str ("-"), t, en1) select case (t) case (V_INT); call eval_node_set_op1_int (en, neg_i) case (V_REAL); call eval_node_set_op1_real (en, neg_r) case (V_CMPLX); call eval_node_set_op1_cmplx (en, neg_c) end select end if case default call eval_node_compile_value (en, pn, var_list) end select if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done signed value" end if end subroutine eval_node_compile_signed_value @ %def eval_node_compile_signed_value @ Integer, real and complex values have an optional unit. The unit is extracted and applied immediately. An integer with unit evaluates to a real constant. <>= recursive subroutine eval_node_compile_value (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list if (debug_active (D_MODEL_F)) then print *, "read value"; call parse_node_write (pn) end if select case (char (parse_node_get_rule_key (pn))) case ("integer_value", "real_value", "complex_value") call eval_node_compile_numeric_value (en, pn) case ("pi") call eval_node_compile_constant (en, pn) case ("I") call eval_node_compile_constant (en, pn) case ("variable") call eval_node_compile_variable (en, pn, var_list) case ("result") call eval_node_compile_result (en, pn, var_list) case ("user_observable") call eval_node_compile_user_observable (en, pn, var_list) case ("expr") call eval_node_compile_expr (en, pn, var_list) case ("block_expr") call eval_node_compile_block_expr (en, pn, var_list) case ("conditional_expr") call eval_node_compile_conditional (en, pn, var_list) case ("unary_function") call eval_node_compile_unary_function (en, pn, var_list) case ("binary_function") call eval_node_compile_binary_function (en, pn, var_list) case ("eval_fun") call eval_node_compile_eval_function (en, pn, var_list) case ("count_fun", "user_event_fun") call eval_node_compile_numeric_function (en, pn, var_list) case default call parse_node_mismatch & ("integer|real|complex|constant|variable|" // & "expr|block_expr|conditional_expr|" // & "unary_function|binary_function|numeric_pexpr", pn) end select if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done value" end if end subroutine eval_node_compile_value @ %def eval_node_compile_value @ Real, complex and integer values are numeric literals with an optional unit attached. In case of an integer, the unit actually makes it a real value in disguise. The signed version of real values is not possible in generic expressions; it is a special case for numeric constants in model files (see below). We do not introduce signed versions of complex values. <>= subroutine eval_node_compile_numeric_value (en, pn) type(eval_node_t), pointer :: en type(parse_node_t), intent(in), target :: pn type(parse_node_t), pointer :: pn_val, pn_unit allocate (en) pn_val => parse_node_get_sub_ptr (pn) pn_unit => parse_node_get_next_ptr (pn_val) select case (char (parse_node_get_rule_key (pn))) case ("integer_value") if (associated (pn_unit)) then call eval_node_init_real (en, & parse_node_get_integer (pn_val) * parse_node_get_unit (pn_unit)) else call eval_node_init_int (en, parse_node_get_integer (pn_val)) end if case ("real_value") if (associated (pn_unit)) then call eval_node_init_real (en, & parse_node_get_real (pn_val) * parse_node_get_unit (pn_unit)) else call eval_node_init_real (en, parse_node_get_real (pn_val)) end if case ("complex_value") if (associated (pn_unit)) then call eval_node_init_cmplx (en, & parse_node_get_cmplx (pn_val) * parse_node_get_unit (pn_unit)) else call eval_node_init_cmplx (en, parse_node_get_cmplx (pn_val)) end if case ("neg_real_value") pn_val => parse_node_get_sub_ptr (parse_node_get_sub_ptr (pn, 2)) pn_unit => parse_node_get_next_ptr (pn_val) if (associated (pn_unit)) then call eval_node_init_real (en, & - parse_node_get_real (pn_val) * parse_node_get_unit (pn_unit)) else call eval_node_init_real (en, - parse_node_get_real (pn_val)) end if case ("pos_real_value") pn_val => parse_node_get_sub_ptr (parse_node_get_sub_ptr (pn, 2)) pn_unit => parse_node_get_next_ptr (pn_val) if (associated (pn_unit)) then call eval_node_init_real (en, & parse_node_get_real (pn_val) * parse_node_get_unit (pn_unit)) else call eval_node_init_real (en, parse_node_get_real (pn_val)) end if case default call parse_node_mismatch & ("integer_value|real_value|complex_value|neg_real_value|pos_real_value", pn) end select end subroutine eval_node_compile_numeric_value @ %def eval_node_compile_numeric_value @ These are the units, predefined and hardcoded. The default energy unit is GeV, the default angular unit is radians. We include units for observables of dimension energy squared. Luminosities are normalized in inverse femtobarns. <>= function parse_node_get_unit (pn) result (factor) real(default) :: factor real(default) :: unit type(parse_node_t), intent(in) :: pn type(parse_node_t), pointer :: pn_unit, pn_unit_power type(parse_node_t), pointer :: pn_frac, pn_num, pn_int, pn_div, pn_den integer :: num, den pn_unit => parse_node_get_sub_ptr (pn) select case (char (parse_node_get_key (pn_unit))) case ("TeV"); unit = 1.e3_default case ("GeV"); unit = 1 case ("MeV"); unit = 1.e-3_default case ("keV"); unit = 1.e-6_default case ("eV"); unit = 1.e-9_default case ("meV"); unit = 1.e-12_default case ("nbarn"); unit = 1.e6_default case ("pbarn"); unit = 1.e3_default case ("fbarn"); unit = 1 case ("abarn"); unit = 1.e-3_default case ("rad"); unit = 1 case ("mrad"); unit = 1.e-3_default case ("degree"); unit = degree case ("%"); unit = 1.e-2_default case default call msg_bug (" Unit '" // & char (parse_node_get_key (pn)) // "' is undefined.") end select pn_unit_power => parse_node_get_next_ptr (pn_unit) if (associated (pn_unit_power)) then pn_frac => parse_node_get_sub_ptr (pn_unit_power, 2) pn_num => parse_node_get_sub_ptr (pn_frac) select case (char (parse_node_get_rule_key (pn_num))) case ("neg_int") pn_int => parse_node_get_sub_ptr (pn_num, 2) num = - parse_node_get_integer (pn_int) case ("pos_int") pn_int => parse_node_get_sub_ptr (pn_num, 2) num = parse_node_get_integer (pn_int) case ("integer_literal") num = parse_node_get_integer (pn_num) case default call parse_node_mismatch ("neg_int|pos_int|integer_literal", pn_num) end select pn_div => parse_node_get_next_ptr (pn_num) if (associated (pn_div)) then pn_den => parse_node_get_sub_ptr (pn_div, 2) den = parse_node_get_integer (pn_den) else den = 1 end if else num = 1 den = 1 end if factor = unit ** (real (num, default) / den) end function parse_node_get_unit @ %def parse_node_get_unit @ There are only two predefined constants, but more can be added easily. <>= subroutine eval_node_compile_constant (en, pn) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn if (debug_active (D_MODEL_F)) then print *, "read constant"; call parse_node_write (pn) end if allocate (en) select case (char (parse_node_get_key (pn))) case ("pi"); call eval_node_init_real (en, pi) case ("I"); call eval_node_init_cmplx (en, imago) case default call parse_node_mismatch ("pi or I", pn) end select if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done constant" end if end subroutine eval_node_compile_constant @ %def eval_node_compile_constant @ Compile a variable, with or without a specified type. Take the list of variables, look for the name and make a node with a pointer to the value. If no type is provided, the variable is numeric, and the stored value determines whether it is real or integer. We explicitly demand that the variable is defined, so we do not accidentally point to variables that are declared only later in the script but have come into existence in a previous compilation pass. Variables may actually be anonymous, these are expressions in disguise. In that case, the expression replaces the variable name in the parse tree, and we allocate an ordinary expression node in the eval tree. Variables of type [[V_PDG]] (pdg-code array) are not treated here. They are handled by [[eval_node_compile_cvariable]]. <>= recursive subroutine eval_node_compile_variable (en, pn, var_list, var_type) type(eval_node_t), pointer :: en type(parse_node_t), intent(in), target :: pn type(var_list_t), intent(in), target :: var_list integer, intent(in), optional :: var_type type(parse_node_t), pointer :: pn_name type(string_t) :: var_name logical, target, save :: no_lval real(default), target, save :: no_rval type(subevt_t), target, save :: no_pval type(string_t), target, save :: no_sval logical, target, save :: unknown = .false. integer :: type logical :: defined logical, pointer :: known logical, pointer :: lptr integer, pointer :: iptr real(default), pointer :: rptr complex(default), pointer :: cptr type(subevt_t), pointer :: pptr type(string_t), pointer :: sptr procedure(obs_unary_int), pointer :: obs1_iptr procedure(obs_unary_real), pointer :: obs1_rptr procedure(obs_binary_int), pointer :: obs2_iptr procedure(obs_binary_real), pointer :: obs2_rptr type(prt_t), pointer :: p1, p2 if (debug_active (D_MODEL_F)) then print *, "read variable"; call parse_node_write (pn) end if if (present (var_type)) then select case (var_type) case (V_REAL, V_OBS1_REAL, V_OBS2_REAL, V_INT, V_OBS1_INT, & V_OBS2_INT, V_CMPLX) pn_name => pn case default pn_name => parse_node_get_sub_ptr (pn, 2) end select else pn_name => pn end if select case (char (parse_node_get_rule_key (pn_name))) case ("expr") call eval_node_compile_expr (en, pn_name, var_list) case ("lexpr") call eval_node_compile_lexpr (en, pn_name, var_list) case ("sexpr") call eval_node_compile_sexpr (en, pn_name, var_list) case ("pexpr") call eval_node_compile_pexpr (en, pn_name, var_list) case ("variable") var_name = parse_node_get_string (pn_name) if (present (var_type)) then select case (var_type) case (V_LOG); var_name = "?" // var_name case (V_SEV); var_name = "@" // var_name case (V_STR); var_name = "$" // var_name ! $ sign end select end if call var_list%get_var_properties & (var_name, req_type=var_type, type=type, is_defined=defined) allocate (en) if (defined) then select case (type) case (V_LOG) call var_list%get_lptr (var_name, lptr, known) call eval_node_init_log_ptr (en, var_name, lptr, known) case (V_INT) call var_list%get_iptr (var_name, iptr, known) call eval_node_init_int_ptr (en, var_name, iptr, known) case (V_REAL) call var_list%get_rptr (var_name, rptr, known) call eval_node_init_real_ptr (en, var_name, rptr, known) case (V_CMPLX) call var_list%get_cptr (var_name, cptr, known) call eval_node_init_cmplx_ptr (en, var_name, cptr, known) case (V_SEV) call var_list%get_pptr (var_name, pptr, known) call eval_node_init_subevt_ptr (en, var_name, pptr, known) case (V_STR) call var_list%get_sptr (var_name, sptr, known) call eval_node_init_string_ptr (en, var_name, sptr, known) case (V_OBS1_INT) call var_list%get_obs1_iptr (var_name, obs1_iptr, p1) call eval_node_init_obs1_int_ptr (en, var_name, obs1_iptr, p1) case (V_OBS2_INT) call var_list%get_obs2_iptr (var_name, obs2_iptr, p1, p2) call eval_node_init_obs2_int_ptr (en, var_name, obs2_iptr, p1, p2) case (V_OBS1_REAL) call var_list%get_obs1_rptr (var_name, obs1_rptr, p1) call eval_node_init_obs1_real_ptr (en, var_name, obs1_rptr, p1) case (V_OBS2_REAL) call var_list%get_obs2_rptr (var_name, obs2_rptr, p1, p2) call eval_node_init_obs2_real_ptr (en, var_name, obs2_rptr, p1, p2) case default call parse_node_write (pn) call msg_fatal ("Variable of this type " // & "is not allowed in the present context") if (present (var_type)) then select case (var_type) case (V_LOG) call eval_node_init_log_ptr (en, var_name, no_lval, unknown) case (V_SEV) call eval_node_init_subevt_ptr & (en, var_name, no_pval, unknown) case (V_STR) call eval_node_init_string_ptr & (en, var_name, no_sval, unknown) end select else call eval_node_init_real_ptr (en, var_name, no_rval, unknown) end if end select else call parse_node_write (pn) call msg_error ("This variable is undefined at this point") if (present (var_type)) then select case (var_type) case (V_LOG) call eval_node_init_log_ptr (en, var_name, no_lval, unknown) case (V_SEV) call eval_node_init_subevt_ptr & (en, var_name, no_pval, unknown) case (V_STR) call eval_node_init_string_ptr (en, var_name, no_sval, unknown) end select else call eval_node_init_real_ptr (en, var_name, no_rval, unknown) end if end if end select if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done variable" end if end subroutine eval_node_compile_variable @ %def eval_node_compile_variable @ In a given context, a variable has to have a certain type. <>= subroutine check_var_type (pn, ok, type_actual, type_requested) type(parse_node_t), intent(in) :: pn logical, intent(out) :: ok integer, intent(in) :: type_actual integer, intent(in), optional :: type_requested if (present (type_requested)) then select case (type_requested) case (V_LOG) select case (type_actual) case (V_LOG) case default call parse_node_write (pn) call msg_fatal ("Variable type is invalid (should be logical)") ok = .false. end select case (V_SEV) select case (type_actual) case (V_SEV) case default call parse_node_write (pn) call msg_fatal & ("Variable type is invalid (should be particle set)") ok = .false. end select case (V_PDG) select case (type_actual) case (V_PDG) case default call parse_node_write (pn) call msg_fatal & ("Variable type is invalid (should be PDG array)") ok = .false. end select case (V_STR) select case (type_actual) case (V_STR) case default call parse_node_write (pn) call msg_fatal & ("Variable type is invalid (should be string)") ok = .false. end select case default call parse_node_write (pn) call msg_bug ("Variable type is unknown") end select else select case (type_actual) case (V_REAL, V_OBS1_REAL, V_OBS2_REAL, V_INT, V_OBS1_INT, & V_OBS2_INT, V_CMPLX) case default call parse_node_write (pn) call msg_fatal ("Variable type is invalid (should be numeric)") ok = .false. end select end if ok = .true. end subroutine check_var_type @ %def check_var_type @ Retrieve the result of an integration. If the requested process has been integrated, the results are available as special variables. (The variables cannot be accessed in the usual way since they contain brackets in their names.) Since this compilation step may occur before the processes have been loaded, we have to initialize the required variables before they are used. <>= subroutine eval_node_compile_result (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in), target :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_key, pn_prc_id type(string_t) :: key, prc_id, var_name integer, pointer :: iptr real(default), pointer :: rptr logical, pointer :: known if (debug_active (D_MODEL_F)) then print *, "read result"; call parse_node_write (pn) end if pn_key => parse_node_get_sub_ptr (pn) pn_prc_id => parse_node_get_next_ptr (pn_key) key = parse_node_get_key (pn_key) prc_id = parse_node_get_string (pn_prc_id) var_name = key // "(" // prc_id // ")" if (var_list%contains (var_name)) then allocate (en) select case (char(key)) case ("num_id", "n_calls") call var_list%get_iptr (var_name, iptr, known) call eval_node_init_int_ptr (en, var_name, iptr, known) case ("integral", "error") call var_list%get_rptr (var_name, rptr, known) call eval_node_init_real_ptr (en, var_name, rptr, known) end select else call msg_fatal ("Result variable '" // char (var_name) & // "' is undefined (call 'integrate' before use)") end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done result" end if end subroutine eval_node_compile_result @ %def eval_node_compile_result @ This user observable behaves like a variable. We link the node to the generic user-observable entry in the variable list. The syntax element has an argument which provides the name of the user variable, this is stored as an eval-node alongside with the variable. When the variable value is used, the user-supplied external function is called and provides the (real) result value. <>= subroutine eval_node_compile_user_observable (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in), target :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_key, pn_arg, pn_obs type(eval_node_t), pointer :: en0 integer :: res_type type(string_t) :: var_name integer :: type logical :: defined if (debug_active (D_MODEL_F)) then print *, "read user observable"; call parse_node_write (pn) end if pn_key => parse_node_get_sub_ptr (pn) select case (char (parse_node_get_key (pn_key))) case ("user_obs") res_type = V_REAL case default call parse_node_write (pn_key) call msg_bug ("user_observable: wrong keyword") end select pn_arg => parse_node_get_next_ptr (pn_key) pn_obs => parse_node_get_sub_ptr (pn_arg) call eval_node_compile_sexpr (en0, pn_obs, var_list) select case (res_type) case (V_INT); var_name = "_User_obs_int" case (V_REAL); var_name = "_User_obs_real" end select call var_list%get_var_properties (var_name, type=type, is_defined=defined) allocate (en) if (defined) then select case (type) case (V_UOBS1_INT) call eval_node_init_uobs1_int (en, var_name, en0) case (V_UOBS2_INT) call eval_node_init_uobs2_int (en, var_name, en0) case (V_UOBS1_REAL) call eval_node_init_uobs1_real (en, var_name, en0) case (V_UOBS2_REAL) call eval_node_init_uobs2_real (en, var_name, en0) end select else call parse_node_write (pn) call msg_error ("This variable is undefined at this point") end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done user observable" end if end subroutine eval_node_compile_user_observable @ %def eval_node_compile_user_observable @ Functions with a single argument. For non-constant arguments, watch for functions which convert their argument to a different type. <>= recursive subroutine eval_node_compile_unary_function (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_fname, pn_arg type(eval_node_t), pointer :: en1 type(string_t) :: key integer :: t if (debug_active (D_MODEL_F)) then print *, "read unary function"; call parse_node_write (pn) end if pn_fname => parse_node_get_sub_ptr (pn) pn_arg => parse_node_get_next_ptr (pn_fname, tag="function_arg1") call eval_node_compile_expr & (en1, parse_node_get_sub_ptr (pn_arg, tag="expr"), var_list) t = en1%result_type allocate (en) key = parse_node_get_key (pn_fname) if (en1%type == EN_CONSTANT) then select case (char (key)) case ("complex") select case (t) case (V_INT); call eval_node_init_cmplx (en, cmplx_i (en1)) case (V_REAL); call eval_node_init_cmplx (en, cmplx_r (en1)) case (V_CMPLX); deallocate (en); en => en1; en1 => null () case default; call eval_type_error (pn, char (key), t) end select case ("real") select case (t) case (V_INT); call eval_node_init_real (en, real_i (en1)) case (V_REAL); deallocate (en); en => en1; en1 => null () case (V_CMPLX); call eval_node_init_real (en, real_c (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("int") select case (t) case (V_INT); deallocate (en); en => en1; en1 => null () case (V_REAL); call eval_node_init_int (en, int_r (en1)) case (V_CMPLX); call eval_node_init_int (en, int_c (en1)) end select case ("nint") select case (t) case (V_INT); deallocate (en); en => en1; en1 => null () case (V_REAL); call eval_node_init_int (en, nint_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("floor") select case (t) case (V_INT); deallocate (en); en => en1; en1 => null () case (V_REAL); call eval_node_init_int (en, floor_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("ceiling") select case (t) case (V_INT); deallocate (en); en => en1; en1 => null () case (V_REAL); call eval_node_init_int (en, ceiling_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("abs") select case (t) case (V_INT); call eval_node_init_int (en, abs_i (en1)) case (V_REAL); call eval_node_init_real (en, abs_r (en1)) case (V_CMPLX); call eval_node_init_real (en, abs_c (en1)) end select case ("conjg") select case (t) case (V_INT); call eval_node_init_int (en, conjg_i (en1)) case (V_REAL); call eval_node_init_real (en, conjg_r (en1)) case (V_CMPLX); call eval_node_init_cmplx (en, conjg_c (en1)) end select case ("sgn") select case (t) case (V_INT); call eval_node_init_int (en, sgn_i (en1)) case (V_REAL); call eval_node_init_real (en, sgn_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("sqrt") select case (t) case (V_REAL); call eval_node_init_real (en, sqrt_r (en1)) case (V_CMPLX); call eval_node_init_cmplx (en, sqrt_c (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("exp") select case (t) case (V_REAL); call eval_node_init_real (en, exp_r (en1)) case (V_CMPLX); call eval_node_init_cmplx (en, exp_c (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("log") select case (t) case (V_REAL); call eval_node_init_real (en, log_r (en1)) case (V_CMPLX); call eval_node_init_cmplx (en, log_c (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("log10") select case (t) case (V_REAL); call eval_node_init_real (en, log10_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("sin") select case (t) case (V_REAL); call eval_node_init_real (en, sin_r (en1)) case (V_CMPLX); call eval_node_init_cmplx (en, sin_c (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("cos") select case (t) case (V_REAL); call eval_node_init_real (en, cos_r (en1)) case (V_CMPLX); call eval_node_init_cmplx (en, cos_c (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("tan") select case (t) case (V_REAL); call eval_node_init_real (en, tan_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("asin") select case (t) case (V_REAL); call eval_node_init_real (en, asin_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("acos") select case (t) case (V_REAL); call eval_node_init_real (en, acos_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("atan") select case (t) case (V_REAL); call eval_node_init_real (en, atan_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("sinh") select case (t) case (V_REAL); call eval_node_init_real (en, sinh_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("cosh") select case (t) case (V_REAL); call eval_node_init_real (en, cosh_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case ("tanh") select case (t) case (V_REAL); call eval_node_init_real (en, tanh_r (en1)) case default; call eval_type_error (pn, char (key), t) end select case default call parse_node_mismatch ("function name", pn_fname) end select if (associated (en1)) then call eval_node_final_rec (en1) deallocate (en1) end if else select case (char (key)) case ("complex") call eval_node_init_branch (en, key, V_CMPLX, en1) case ("real") call eval_node_init_branch (en, key, V_REAL, en1) case ("int", "nint", "floor", "ceiling") call eval_node_init_branch (en, key, V_INT, en1) case default call eval_node_init_branch (en, key, t, en1) end select select case (char (key)) case ("complex") select case (t) case (V_INT); call eval_node_set_op1_cmplx (en, cmplx_i) case (V_REAL); call eval_node_set_op1_cmplx (en, cmplx_r) case (V_CMPLX); deallocate (en); en => en1 case default; call eval_type_error (pn, char (key), t) end select case ("real") select case (t) case (V_INT); call eval_node_set_op1_real (en, real_i) case (V_REAL); deallocate (en); en => en1 case (V_CMPLX); call eval_node_set_op1_real (en, real_c) case default; call eval_type_error (pn, char (key), t) end select case ("int") select case (t) case (V_INT); deallocate (en); en => en1 case (V_REAL); call eval_node_set_op1_int (en, int_r) case (V_CMPLX); call eval_node_set_op1_int (en, int_c) end select case ("nint") select case (t) case (V_INT); deallocate (en); en => en1 case (V_REAL); call eval_node_set_op1_int (en, nint_r) case default; call eval_type_error (pn, char (key), t) end select case ("floor") select case (t) case (V_INT); deallocate (en); en => en1 case (V_REAL); call eval_node_set_op1_int (en, floor_r) case default; call eval_type_error (pn, char (key), t) end select case ("ceiling") select case (t) case (V_INT); deallocate (en); en => en1 case (V_REAL); call eval_node_set_op1_int (en, ceiling_r) case default; call eval_type_error (pn, char (key), t) end select case ("abs") select case (t) case (V_INT); call eval_node_set_op1_int (en, abs_i) case (V_REAL); call eval_node_set_op1_real (en, abs_r) case (V_CMPLX); call eval_node_init_branch (en, key, V_REAL, en1) call eval_node_set_op1_real (en, abs_c) end select case ("conjg") select case (t) case (V_INT); call eval_node_set_op1_int (en, conjg_i) case (V_REAL); call eval_node_set_op1_real (en, conjg_r) case (V_CMPLX); call eval_node_set_op1_cmplx (en, conjg_c) end select case ("sgn") select case (t) case (V_INT); call eval_node_set_op1_int (en, sgn_i) case (V_REAL); call eval_node_set_op1_real (en, sgn_r) case default; call eval_type_error (pn, char (key), t) end select case ("sqrt") select case (t) case (V_REAL); call eval_node_set_op1_real (en, sqrt_r) case (V_CMPLX); call eval_node_set_op1_cmplx (en, sqrt_c) case default; call eval_type_error (pn, char (key), t) end select case ("exp") select case (t) case (V_REAL); call eval_node_set_op1_real (en, exp_r) case (V_CMPLX); call eval_node_set_op1_cmplx (en, exp_c) case default; call eval_type_error (pn, char (key), t) end select case ("log") select case (t) case (V_REAL); call eval_node_set_op1_real (en, log_r) case (V_CMPLX); call eval_node_set_op1_cmplx (en, log_c) case default; call eval_type_error (pn, char (key), t) end select case ("log10") select case (t) case (V_REAL); call eval_node_set_op1_real (en, log10_r) case default; call eval_type_error (pn, char (key), t) end select case ("sin") select case (t) case (V_REAL); call eval_node_set_op1_real (en, sin_r) case (V_CMPLX); call eval_node_set_op1_cmplx (en, sin_c) case default; call eval_type_error (pn, char (key), t) end select case ("cos") select case (t) case (V_REAL); call eval_node_set_op1_real (en, cos_r) case (V_CMPLX); call eval_node_set_op1_cmplx (en, cos_c) case default; call eval_type_error (pn, char (key), t) end select case ("tan") select case (t) case (V_REAL); call eval_node_set_op1_real (en, tan_r) case default; call eval_type_error (pn, char (key), t) end select case ("asin") select case (t) case (V_REAL); call eval_node_set_op1_real (en, asin_r) case default; call eval_type_error (pn, char (key), t) end select case ("acos") select case (t) case (V_REAL); call eval_node_set_op1_real (en, acos_r) case default; call eval_type_error (pn, char (key), t) end select case ("atan") select case (t) case (V_REAL); call eval_node_set_op1_real (en, atan_r) case default; call eval_type_error (pn, char (key), t) end select case ("sinh") select case (t) case (V_REAL); call eval_node_set_op1_real (en, sinh_r) case default; call eval_type_error (pn, char (key), t) end select case ("cosh") select case (t) case (V_REAL); call eval_node_set_op1_real (en, cosh_r) case default; call eval_type_error (pn, char (key), t) end select case ("tanh") select case (t) case (V_REAL); call eval_node_set_op1_real (en, tanh_r) case default; call eval_type_error (pn, char (key), t) end select case default call parse_node_mismatch ("function name", pn_fname) end select end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done function" end if end subroutine eval_node_compile_unary_function @ %def eval_node_compile_unary_function @ Functions with two arguments. <>= recursive subroutine eval_node_compile_binary_function (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_fname, pn_arg, pn_arg1, pn_arg2 type(eval_node_t), pointer :: en1, en2 type(string_t) :: key integer :: t1, t2 if (debug_active (D_MODEL_F)) then print *, "read binary function"; call parse_node_write (pn) end if pn_fname => parse_node_get_sub_ptr (pn) pn_arg => parse_node_get_next_ptr (pn_fname, tag="function_arg2") pn_arg1 => parse_node_get_sub_ptr (pn_arg, tag="expr") pn_arg2 => parse_node_get_next_ptr (pn_arg1, tag="expr") call eval_node_compile_expr (en1, pn_arg1, var_list) call eval_node_compile_expr (en2, pn_arg2, var_list) t1 = en1%result_type t2 = en2%result_type allocate (en) key = parse_node_get_key (pn_fname) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then select case (char (key)) case ("max") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_int (en, max_ii (en1, en2)) case (V_REAL); call eval_node_init_real (en, max_ir (en1, en2)) case default; call eval_type_error (pn, char (key), t2) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_real (en, max_ri (en1, en2)) case (V_REAL); call eval_node_init_real (en, max_rr (en1, en2)) case default; call eval_type_error (pn, char (key), t2) end select case default; call eval_type_error (pn, char (key), t1) end select case ("min") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_int (en, min_ii (en1, en2)) case (V_REAL); call eval_node_init_real (en, min_ir (en1, en2)) case default; call eval_type_error (pn, char (key), t2) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_real (en, min_ri (en1, en2)) case (V_REAL); call eval_node_init_real (en, min_rr (en1, en2)) case default; call eval_type_error (pn, char (key), t2) end select case default; call eval_type_error (pn, char (key), t1) end select case ("mod") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_int (en, mod_ii (en1, en2)) case (V_REAL); call eval_node_init_real (en, mod_ir (en1, en2)) case default; call eval_type_error (pn, char (key), t2) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_real (en, mod_ri (en1, en2)) case (V_REAL); call eval_node_init_real (en, mod_rr (en1, en2)) case default; call eval_type_error (pn, char (key), t2) end select case default; call eval_type_error (pn, char (key), t1) end select case ("modulo") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_int (en, modulo_ii (en1, en2)) case (V_REAL); call eval_node_init_real (en, modulo_ir (en1, en2)) case default; call eval_type_error (pn, char (key), t2) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_real (en, modulo_ri (en1, en2)) case (V_REAL); call eval_node_init_real (en, modulo_rr (en1, en2)) case default; call eval_type_error (pn, char (key), t2) end select case default; call eval_type_error (pn, char (key), t2) end select case default call parse_node_mismatch ("function name", pn_fname) end select call eval_node_final_rec (en1) deallocate (en1) else call eval_node_init_branch (en, key, t1, en1, en2) select case (char (key)) case ("max") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_int (en, max_ii) case (V_REAL); call eval_node_set_op2_real (en, max_ir) case default; call eval_type_error (pn, char (key), t2) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_real (en, max_ri) case (V_REAL); call eval_node_set_op2_real (en, max_rr) case default; call eval_type_error (pn, char (key), t2) end select case default; call eval_type_error (pn, char (key), t2) end select case ("min") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_int (en, min_ii) case (V_REAL); call eval_node_set_op2_real (en, min_ir) case default; call eval_type_error (pn, char (key), t2) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_real (en, min_ri) case (V_REAL); call eval_node_set_op2_real (en, min_rr) case default; call eval_type_error (pn, char (key), t2) end select case default; call eval_type_error (pn, char (key), t2) end select case ("mod") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_int (en, mod_ii) case (V_REAL); call eval_node_set_op2_real (en, mod_ir) case default; call eval_type_error (pn, char (key), t2) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_real (en, mod_ri) case (V_REAL); call eval_node_set_op2_real (en, mod_rr) case default; call eval_type_error (pn, char (key), t2) end select case default; call eval_type_error (pn, char (key), t2) end select case ("modulo") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_int (en, modulo_ii) case (V_REAL); call eval_node_set_op2_real (en, modulo_ir) case default; call eval_type_error (pn, char (key), t2) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_real (en, modulo_ri) case (V_REAL); call eval_node_set_op2_real (en, modulo_rr) case default; call eval_type_error (pn, char (key), t2) end select case default; call eval_type_error (pn, char (key), t2) end select case default call parse_node_mismatch ("function name", pn_fname) end select end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done function" end if end subroutine eval_node_compile_binary_function @ %def eval_node_compile_binary_function @ \subsubsection{Variable definition} A block expression contains a variable definition (first argument) and an expression where the definition can be used (second argument). The [[result_type]] decides which type of expression is expected for the second argument. For numeric variables, if there is a mismatch between real and integer type, insert an extra node for type conversion. <>= recursive subroutine eval_node_compile_block_expr & (en, pn, var_list, result_type) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list integer, intent(in), optional :: result_type type(parse_node_t), pointer :: pn_var_spec, pn_var_subspec type(parse_node_t), pointer :: pn_var_type, pn_var_name, pn_var_expr type(parse_node_t), pointer :: pn_expr type(string_t) :: var_name type(eval_node_t), pointer :: en1, en2 integer :: var_type logical :: new if (debug_active (D_MODEL_F)) then print *, "read block expr"; call parse_node_write (pn) end if new = .false. pn_var_spec => parse_node_get_sub_ptr (pn, 2) select case (char (parse_node_get_rule_key (pn_var_spec))) case ("var_num"); var_type = V_NONE pn_var_name => parse_node_get_sub_ptr (pn_var_spec) case ("var_int"); var_type = V_INT new = .true. pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2) case ("var_real"); var_type = V_REAL new = .true. pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2) case ("var_cmplx"); var_type = V_CMPLX new = .true. pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2) case ("var_logical_new"); var_type = V_LOG new = .true. pn_var_subspec => parse_node_get_sub_ptr (pn_var_spec, 2) pn_var_name => parse_node_get_sub_ptr (pn_var_subspec, 2) case ("var_logical_spec"); var_type = V_LOG pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2) case ("var_plist_new"); var_type = V_SEV new = .true. pn_var_subspec => parse_node_get_sub_ptr (pn_var_spec, 2) pn_var_name => parse_node_get_sub_ptr (pn_var_subspec, 2) case ("var_plist_spec"); var_type = V_SEV new = .true. pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2) case ("var_alias"); var_type = V_PDG new = .true. pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2) case ("var_string_new"); var_type = V_STR new = .true. pn_var_subspec => parse_node_get_sub_ptr (pn_var_spec, 2) pn_var_name => parse_node_get_sub_ptr (pn_var_subspec, 2) case ("var_string_spec"); var_type = V_STR pn_var_name => parse_node_get_sub_ptr (pn_var_spec, 2) case default call parse_node_mismatch & ("logical|int|real|plist|alias", pn_var_type) end select pn_var_expr => parse_node_get_next_ptr (pn_var_name, 2) pn_expr => parse_node_get_next_ptr (pn_var_spec, 2) var_name = parse_node_get_string (pn_var_name) select case (var_type) case (V_LOG); var_name = "?" // var_name case (V_SEV); var_name = "@" // var_name case (V_STR); var_name = "$" // var_name ! $ sign end select call var_list_check_user_var (var_list, var_name, var_type, new) call eval_node_compile_genexpr (en1, pn_var_expr, var_list, var_type) call insert_conversion_node (en1, var_type) allocate (en) call eval_node_init_block (en, var_name, var_type, en1, var_list) call eval_node_compile_genexpr (en2, pn_expr, en%var_list, result_type) call eval_node_set_expr (en, en2) if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done block expr" end if end subroutine eval_node_compile_block_expr @ %def eval_node_compile_block_expr @ Insert a conversion node for integer/real/complex transformation if necessary. What shall we do for the complex to integer/real conversion? <>= subroutine insert_conversion_node (en, result_type) type(eval_node_t), pointer :: en integer, intent(in) :: result_type type(eval_node_t), pointer :: en_conv select case (en%result_type) case (V_INT) select case (result_type) case (V_REAL) allocate (en_conv) call eval_node_init_branch (en_conv, var_str ("real"), V_REAL, en) call eval_node_set_op1_real (en_conv, real_i) en => en_conv case (V_CMPLX) allocate (en_conv) call eval_node_init_branch (en_conv, var_str ("complex"), V_CMPLX, en) call eval_node_set_op1_cmplx (en_conv, cmplx_i) en => en_conv end select case (V_REAL) select case (result_type) case (V_INT) allocate (en_conv) call eval_node_init_branch (en_conv, var_str ("int"), V_INT, en) call eval_node_set_op1_int (en_conv, int_r) en => en_conv case (V_CMPLX) allocate (en_conv) call eval_node_init_branch (en_conv, var_str ("complex"), V_CMPLX, en) call eval_node_set_op1_cmplx (en_conv, cmplx_r) en => en_conv end select case (V_CMPLX) select case (result_type) case (V_INT) allocate (en_conv) call eval_node_init_branch (en_conv, var_str ("int"), V_INT, en) call eval_node_set_op1_int (en_conv, int_c) en => en_conv case (V_REAL) allocate (en_conv) call eval_node_init_branch (en_conv, var_str ("real"), V_REAL, en) call eval_node_set_op1_real (en_conv, real_c) en => en_conv end select case default end select end subroutine insert_conversion_node @ %def insert_conversion_node @ \subsubsection{Conditionals} A conditional has the structure if lexpr then expr else expr. So we first evaluate the logical expression, then depending on the result the first or second expression. Note that the second expression is mandatory. The [[result_type]], if present, defines the requested type of the [[then]] and [[else]] clauses. Default is numeric (int/real). If there is a mismatch between real and integer result types, insert conversion nodes. <>= recursive subroutine eval_node_compile_conditional & (en, pn, var_list, result_type) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list integer, intent(in), optional :: result_type type(parse_node_t), pointer :: pn_condition, pn_expr type(parse_node_t), pointer :: pn_maybe_elsif, pn_elsif_branch type(parse_node_t), pointer :: pn_maybe_else, pn_else_branch, pn_else_expr type(eval_node_t), pointer :: en0, en1, en2 integer :: restype if (debug_active (D_MODEL_F)) then print *, "read conditional"; call parse_node_write (pn) end if pn_condition => parse_node_get_sub_ptr (pn, 2, tag="lexpr") pn_expr => parse_node_get_next_ptr (pn_condition, 2) call eval_node_compile_lexpr (en0, pn_condition, var_list) call eval_node_compile_genexpr (en1, pn_expr, var_list, result_type) if (present (result_type)) then restype = major_result_type (result_type, en1%result_type) else restype = en1%result_type end if pn_maybe_elsif => parse_node_get_next_ptr (pn_expr) select case (char (parse_node_get_rule_key (pn_maybe_elsif))) case ("maybe_elsif_expr", & "maybe_elsif_lexpr", & "maybe_elsif_pexpr", & "maybe_elsif_cexpr", & "maybe_elsif_sexpr") pn_elsif_branch => parse_node_get_sub_ptr (pn_maybe_elsif) pn_maybe_else => parse_node_get_next_ptr (pn_maybe_elsif) select case (char (parse_node_get_rule_key (pn_maybe_else))) case ("maybe_else_expr", & "maybe_else_lexpr", & "maybe_else_pexpr", & "maybe_else_cexpr", & "maybe_else_sexpr") pn_else_branch => parse_node_get_sub_ptr (pn_maybe_else) pn_else_expr => parse_node_get_sub_ptr (pn_else_branch, 2) case default pn_else_expr => null () end select call eval_node_compile_elsif & (en2, pn_elsif_branch, pn_else_expr, var_list, restype) case ("maybe_else_expr", & "maybe_else_lexpr", & "maybe_else_pexpr", & "maybe_else_cexpr", & "maybe_else_sexpr") pn_maybe_else => pn_maybe_elsif pn_maybe_elsif => null () pn_else_branch => parse_node_get_sub_ptr (pn_maybe_else) pn_else_expr => parse_node_get_sub_ptr (pn_else_branch, 2) call eval_node_compile_genexpr & (en2, pn_else_expr, var_list, restype) case ("endif") call eval_node_compile_default_else (en2, restype) case default call msg_bug ("Broken conditional: unexpected " & // char (parse_node_get_rule_key (pn_maybe_elsif))) end select call eval_node_create_conditional (en, en0, en1, en2, restype) call conditional_insert_conversion_nodes (en, restype) if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done conditional" end if end subroutine eval_node_compile_conditional @ %def eval_node_compile_conditional @ This recursively generates 'elsif' conditionals as a chain of sub-nodes of the main conditional. <>= recursive subroutine eval_node_compile_elsif & (en, pn, pn_else_expr, var_list, result_type) type(eval_node_t), pointer :: en type(parse_node_t), intent(in), target :: pn type(parse_node_t), pointer :: pn_else_expr type(var_list_t), intent(in), target :: var_list integer, intent(inout) :: result_type type(parse_node_t), pointer :: pn_next, pn_condition, pn_expr type(eval_node_t), pointer :: en0, en1, en2 pn_condition => parse_node_get_sub_ptr (pn, 2, tag="lexpr") pn_expr => parse_node_get_next_ptr (pn_condition, 2) call eval_node_compile_lexpr (en0, pn_condition, var_list) call eval_node_compile_genexpr (en1, pn_expr, var_list, result_type) result_type = major_result_type (result_type, en1%result_type) pn_next => parse_node_get_next_ptr (pn) if (associated (pn_next)) then call eval_node_compile_elsif & (en2, pn_next, pn_else_expr, var_list, result_type) result_type = major_result_type (result_type, en2%result_type) else if (associated (pn_else_expr)) then call eval_node_compile_genexpr & (en2, pn_else_expr, var_list, result_type) result_type = major_result_type (result_type, en2%result_type) else call eval_node_compile_default_else (en2, result_type) end if call eval_node_create_conditional (en, en0, en1, en2, result_type) end subroutine eval_node_compile_elsif @ %def eval_node_compile_elsif @ This makes a default 'else' branch in case it was omitted. The default value just depends on the expected type. <>= subroutine eval_node_compile_default_else (en, result_type) type(eval_node_t), pointer :: en integer, intent(in) :: result_type type(subevt_t) :: pval_empty type(pdg_array_t) :: aval_undefined allocate (en) select case (result_type) case (V_LOG); call eval_node_init_log (en, .false.) case (V_INT); call eval_node_init_int (en, 0) case (V_REAL); call eval_node_init_real (en, 0._default) case (V_CMPLX) call eval_node_init_cmplx (en, (0._default, 0._default)) case (V_SEV) call subevt_init (pval_empty) call eval_node_init_subevt (en, pval_empty) case (V_PDG) call eval_node_init_pdg_array (en, aval_undefined) case (V_STR) call eval_node_init_string (en, var_str ("")) case default call msg_bug ("Undefined type for 'else' branch in conditional") end select end subroutine eval_node_compile_default_else @ %def eval_node_compile_default_else @ If the logical expression is constant, we can simplify the conditional node by replacing it with the selected branch. Otherwise, we initialize a true branching. <>= subroutine eval_node_create_conditional (en, en0, en1, en2, result_type) type(eval_node_t), pointer :: en, en0, en1, en2 integer, intent(in) :: result_type if (en0%type == EN_CONSTANT) then if (en0%lval) then en => en1 call eval_node_final_rec (en2) deallocate (en2) else en => en2 call eval_node_final_rec (en1) deallocate (en1) end if else allocate (en) call eval_node_init_conditional (en, result_type, en0, en1, en2) end if end subroutine eval_node_create_conditional @ %def eval_node_create_conditional @ Return the numerical result type which should be used for the combination of the two result types. <>= function major_result_type (t1, t2) result (t) integer :: t integer, intent(in) :: t1, t2 select case (t1) case (V_INT) select case (t2) case (V_INT, V_REAL, V_CMPLX) t = t2 case default call type_mismatch () end select case (V_REAL) select case (t2) case (V_INT) t = t1 case (V_REAL, V_CMPLX) t = t2 case default call type_mismatch () end select case (V_CMPLX) select case (t2) case (V_INT, V_REAL, V_CMPLX) t = t1 case default call type_mismatch () end select case default if (t1 == t2) then t = t1 else call type_mismatch () end if end select contains subroutine type_mismatch () call msg_bug ("Type mismatch in branches of a conditional expression") end subroutine type_mismatch end function major_result_type @ %def major_result_type @ Recursively insert conversion nodes where necessary. <>= recursive subroutine conditional_insert_conversion_nodes (en, result_type) type(eval_node_t), intent(inout), target :: en integer, intent(in) :: result_type select case (result_type) case (V_INT, V_REAL, V_CMPLX) call insert_conversion_node (en%arg1, result_type) if (en%arg2%type == EN_CONDITIONAL) then call conditional_insert_conversion_nodes (en%arg2, result_type) else call insert_conversion_node (en%arg2, result_type) end if end select end subroutine conditional_insert_conversion_nodes @ %def conditional_insert_conversion_nodes @ \subsubsection{Logical expressions} A logical expression consists of one or more singlet logical expressions concatenated by [[;]]. This is for allowing side-effects, only the last value is used. <>= recursive subroutine eval_node_compile_lexpr (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_term, pn_sequel, pn_arg type(eval_node_t), pointer :: en1, en2 if (debug_active (D_MODEL_F)) then print *, "read lexpr"; call parse_node_write (pn) end if pn_term => parse_node_get_sub_ptr (pn, tag="lsinglet") call eval_node_compile_lsinglet (en, pn_term, var_list) pn_sequel => parse_node_get_next_ptr (pn_term, tag="lsequel") do while (associated (pn_sequel)) pn_arg => parse_node_get_sub_ptr (pn_sequel, 2, tag="lsinglet") en1 => en call eval_node_compile_lsinglet (en2, pn_arg, var_list) allocate (en) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then call eval_node_init_log (en, ignore_first_ll (en1, en2)) call eval_node_final_rec (en1) call eval_node_final_rec (en2) deallocate (en1, en2) else call eval_node_init_branch & (en, var_str ("lsequel"), V_LOG, en1, en2) call eval_node_set_op2_log (en, ignore_first_ll) end if pn_sequel => parse_node_get_next_ptr (pn_sequel) end do if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done lexpr" end if end subroutine eval_node_compile_lexpr @ %def eval_node_compile_lexpr @ A logical singlet expression consists of one or more logical terms concatenated by [[or]]. <>= recursive subroutine eval_node_compile_lsinglet (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_term, pn_alternative, pn_arg type(eval_node_t), pointer :: en1, en2 if (debug_active (D_MODEL_F)) then print *, "read lsinglet"; call parse_node_write (pn) end if pn_term => parse_node_get_sub_ptr (pn, tag="lterm") call eval_node_compile_lterm (en, pn_term, var_list) pn_alternative => parse_node_get_next_ptr (pn_term, tag="alternative") do while (associated (pn_alternative)) pn_arg => parse_node_get_sub_ptr (pn_alternative, 2, tag="lterm") en1 => en call eval_node_compile_lterm (en2, pn_arg, var_list) allocate (en) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then call eval_node_init_log (en, or_ll (en1, en2)) call eval_node_final_rec (en1) call eval_node_final_rec (en2) deallocate (en1, en2) else call eval_node_init_branch & (en, var_str ("alternative"), V_LOG, en1, en2) call eval_node_set_op2_log (en, or_ll) end if pn_alternative => parse_node_get_next_ptr (pn_alternative) end do if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done lsinglet" end if end subroutine eval_node_compile_lsinglet @ %def eval_node_compile_lsinglet @ A logical term consists of one or more logical values concatenated by [[and]]. <>= recursive subroutine eval_node_compile_lterm (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_term, pn_coincidence, pn_arg type(eval_node_t), pointer :: en1, en2 if (debug_active (D_MODEL_F)) then print *, "read lterm"; call parse_node_write (pn) end if pn_term => parse_node_get_sub_ptr (pn) call eval_node_compile_lvalue (en, pn_term, var_list) pn_coincidence => parse_node_get_next_ptr (pn_term, tag="coincidence") do while (associated (pn_coincidence)) pn_arg => parse_node_get_sub_ptr (pn_coincidence, 2) en1 => en call eval_node_compile_lvalue (en2, pn_arg, var_list) allocate (en) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then call eval_node_init_log (en, and_ll (en1, en2)) call eval_node_final_rec (en1) call eval_node_final_rec (en2) deallocate (en1, en2) else call eval_node_init_branch & (en, var_str ("coincidence"), V_LOG, en1, en2) call eval_node_set_op2_log (en, and_ll) end if pn_coincidence => parse_node_get_next_ptr (pn_coincidence) end do if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done lterm" end if end subroutine eval_node_compile_lterm @ %def eval_node_compile_lterm @ Logical variables are disabled, because they are confused with the l.h.s.\ of compared expressions. <>= recursive subroutine eval_node_compile_lvalue (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list if (debug_active (D_MODEL_F)) then print *, "read lvalue"; call parse_node_write (pn) end if select case (char (parse_node_get_rule_key (pn))) case ("true") allocate (en) call eval_node_init_log (en, .true.) case ("false") allocate (en) call eval_node_init_log (en, .false.) case ("negation") call eval_node_compile_negation (en, pn, var_list) case ("lvariable") call eval_node_compile_variable (en, pn, var_list, V_LOG) case ("lexpr") call eval_node_compile_lexpr (en, pn, var_list) case ("block_lexpr") call eval_node_compile_block_expr (en, pn, var_list, V_LOG) case ("conditional_lexpr") call eval_node_compile_conditional (en, pn, var_list, V_LOG) case ("compared_expr") call eval_node_compile_compared_expr (en, pn, var_list, V_REAL) case ("compared_sexpr") call eval_node_compile_compared_expr (en, pn, var_list, V_STR) case ("all_fun", "any_fun", "no_fun", "user_cut_fun") call eval_node_compile_log_function (en, pn, var_list) case ("record_cmd") call eval_node_compile_record_cmd (en, pn, var_list) case default call parse_node_mismatch & ("true|false|negation|lvariable|" // & "lexpr|block_lexpr|conditional_lexpr|" // & "compared_expr|compared_sexpr|logical_pexpr", pn) end select if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done lvalue" end if end subroutine eval_node_compile_lvalue @ %def eval_node_compile_lvalue @ A negation consists of the keyword [[not]] and a logical value. <>= recursive subroutine eval_node_compile_negation (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_arg type(eval_node_t), pointer :: en1 if (debug_active (D_MODEL_F)) then print *, "read negation"; call parse_node_write (pn) end if pn_arg => parse_node_get_sub_ptr (pn, 2) call eval_node_compile_lvalue (en1, pn_arg, var_list) allocate (en) if (en1%type == EN_CONSTANT) then call eval_node_init_log (en, not_l (en1)) call eval_node_final_rec (en1) deallocate (en1) else call eval_node_init_branch (en, var_str ("not"), V_LOG, en1) call eval_node_set_op1_log (en, not_l) end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done negation" end if end subroutine eval_node_compile_negation @ %def eval_node_compile_negation @ \subsubsection{Comparisons} Up to the loop, this is easy. There is always at least one comparison. This is evaluated, and the result is the logical node [[en]]. If it is constant, we keep its second sub-node as [[en2]]. (Thus, at the very end [[en2]] has to be deleted if [[en]] is (still) constant.) If there is another comparison, we first check if the first comparison was constant. In that case, there are two possibilities: (i) it was true. Then, its right-hand side is compared with the new right-hand side, and the result replaces the previous one which is deleted. (ii) it was false. In this case, the result of the whole comparison is false, and we can exit the loop without evaluating anything else. Now assume that the first comparison results in a valid branch, its second sub-node kept as [[en2]]. We first need a copy of this, which becomes the new left-hand side. If [[en2]] is constant, we make an identical constant node [[en1]]. Otherwise, we make [[en1]] an appropriate pointer node. Next, the first branch is saved as [[en0]] and we evaluate the comparison between [[en1]] and the a right-hand side. If this turns out to be constant, there are again two possibilities: (i) true, then we revert to the previous result. (ii) false, then the wh <>= recursive subroutine eval_node_compile_compared_expr (en, pn, var_list, type) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list integer, intent(in) :: type type(parse_node_t), pointer :: pn_comparison, pn_expr1 type(eval_node_t), pointer :: en0, en1, en2 if (debug_active (D_MODEL_F)) then print *, "read comparison"; call parse_node_write (pn) end if select case (type) case (V_INT, V_REAL) pn_expr1 => parse_node_get_sub_ptr (pn, tag="expr") call eval_node_compile_expr (en1, pn_expr1, var_list) pn_comparison => parse_node_get_next_ptr (pn_expr1, tag="comparison") case (V_STR) pn_expr1 => parse_node_get_sub_ptr (pn, tag="sexpr") call eval_node_compile_sexpr (en1, pn_expr1, var_list) pn_comparison => parse_node_get_next_ptr (pn_expr1, tag="str_comparison") end select call eval_node_compile_comparison & (en, en1, en2, pn_comparison, var_list, type) pn_comparison => parse_node_get_next_ptr (pn_comparison) SCAN_FURTHER: do while (associated (pn_comparison)) if (en%type == EN_CONSTANT) then if (en%lval) then en1 => en2 call eval_node_final_rec (en); deallocate (en) call eval_node_compile_comparison & (en, en1, en2, pn_comparison, var_list, type) else exit SCAN_FURTHER end if else allocate (en1) if (en2%type == EN_CONSTANT) then select case (en2%result_type) case (V_INT); call eval_node_init_int (en1, en2%ival) case (V_REAL); call eval_node_init_real (en1, en2%rval) case (V_STR); call eval_node_init_string (en1, en2%sval) end select else select case (en2%result_type) case (V_INT); call eval_node_init_int_ptr & (en1, var_str ("(previous)"), en2%ival, en2%value_is_known) case (V_REAL); call eval_node_init_real_ptr & (en1, var_str ("(previous)"), en2%rval, en2%value_is_known) case (V_STR); call eval_node_init_string_ptr & (en1, var_str ("(previous)"), en2%sval, en2%value_is_known) end select end if en0 => en call eval_node_compile_comparison & (en, en1, en2, pn_comparison, var_list, type) if (en%type == EN_CONSTANT) then if (en%lval) then call eval_node_final_rec (en); deallocate (en) en => en0 else call eval_node_final_rec (en0); deallocate (en0) exit SCAN_FURTHER end if else en1 => en allocate (en) call eval_node_init_branch (en, var_str ("and"), V_LOG, en0, en1) call eval_node_set_op2_log (en, and_ll) end if end if pn_comparison => parse_node_get_next_ptr (pn_comparison) end do SCAN_FURTHER if (en%type == EN_CONSTANT .and. associated (en2)) then call eval_node_final_rec (en2); deallocate (en2) end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done compared_expr" end if end subroutine eval_node_compile_compared_expr @ %dev eval_node_compile_compared_expr @ This takes two extra arguments: [[en1]], the left-hand-side of the comparison, is already allocated and evaluated. [[en2]] (the right-hand side) and [[en]] (the result) are allocated by the routine. [[pn]] is the parse node which contains the operator and the right-hand side as subnodes. If the result of the comparison is constant, [[en1]] is deleted but [[en2]] is kept, because it may be used in a subsequent comparison. [[en]] then becomes a constant. If the result is variable, [[en]] becomes a branch node which refers to [[en1]] and [[en2]]. <>= recursive subroutine eval_node_compile_comparison & (en, en1, en2, pn, var_list, type) type(eval_node_t), pointer :: en, en1, en2 type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list integer, intent(in) :: type type(parse_node_t), pointer :: pn_op, pn_arg type(string_t) :: key integer :: t1, t2 real(default), pointer :: tolerance_ptr pn_op => parse_node_get_sub_ptr (pn) key = parse_node_get_key (pn_op) select case (type) case (V_INT, V_REAL) pn_arg => parse_node_get_next_ptr (pn_op, tag="expr") call eval_node_compile_expr (en2, pn_arg, var_list) case (V_STR) pn_arg => parse_node_get_next_ptr (pn_op, tag="sexpr") call eval_node_compile_sexpr (en2, pn_arg, var_list) end select t1 = en1%result_type t2 = en2%result_type allocate (en) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then call var_list%get_rptr (var_str ("tolerance"), tolerance_ptr) en1%tolerance => tolerance_ptr select case (char (key)) case ("<") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_log (en, comp_lt_ii (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_ll_ir (en1, en2)) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_log (en, comp_ll_ri (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_ll_rr (en1, en2)) end select end select case (">") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_log (en, comp_gt_ii (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_gg_ir (en1, en2)) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_log (en, comp_gg_ri (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_gg_rr (en1, en2)) end select end select case ("<=") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_log (en, comp_le_ii (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_ls_ir (en1, en2)) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_log (en, comp_ls_ri (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_ls_rr (en1, en2)) end select end select case (">=") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_log (en, comp_ge_ii (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_gs_ir (en1, en2)) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_log (en, comp_gs_ri (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_gs_rr (en1, en2)) end select end select case ("==") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_log (en, comp_eq_ii (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_se_ir (en1, en2)) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_log (en, comp_se_ri (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_se_rr (en1, en2)) end select case (V_STR) select case (t2) case (V_STR); call eval_node_init_log (en, comp_eq_ss (en1, en2)) end select end select case ("<>") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_init_log (en, comp_ne_ii (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_ns_ir (en1, en2)) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_init_log (en, comp_ns_ri (en1, en2)) case (V_REAL); call eval_node_init_log (en, comp_ns_rr (en1, en2)) end select case (V_STR) select case (t2) case (V_STR); call eval_node_init_log (en, comp_ne_ss (en1, en2)) end select end select end select call eval_node_final_rec (en1) deallocate (en1) else call eval_node_init_branch (en, key, V_LOG, en1, en2) select case (char (key)) case ("<") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_lt_ii) case (V_REAL); call eval_node_set_op2_log (en, comp_ll_ir) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_ll_ri) case (V_REAL); call eval_node_set_op2_log (en, comp_ll_rr) end select end select case (">") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_gt_ii) case (V_REAL); call eval_node_set_op2_log (en, comp_gg_ir) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_gg_ri) case (V_REAL); call eval_node_set_op2_log (en, comp_gg_rr) end select end select case ("<=") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_le_ii) case (V_REAL); call eval_node_set_op2_log (en, comp_ls_ir) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_ls_ri) case (V_REAL); call eval_node_set_op2_log (en, comp_ls_rr) end select end select case (">=") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_ge_ii) case (V_REAL); call eval_node_set_op2_log (en, comp_gs_ir) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_gs_ri) case (V_REAL); call eval_node_set_op2_log (en, comp_gs_rr) end select end select case ("==") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_eq_ii) case (V_REAL); call eval_node_set_op2_log (en, comp_se_ir) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_se_ri) case (V_REAL); call eval_node_set_op2_log (en, comp_se_rr) end select case (V_STR) select case (t2) case (V_STR); call eval_node_set_op2_log (en, comp_eq_ss) end select end select case ("<>") select case (t1) case (V_INT) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_ne_ii) case (V_REAL); call eval_node_set_op2_log (en, comp_ns_ir) end select case (V_REAL) select case (t2) case (V_INT); call eval_node_set_op2_log (en, comp_ns_ri) case (V_REAL); call eval_node_set_op2_log (en, comp_ns_rr) end select case (V_STR) select case (t2) case (V_STR); call eval_node_set_op2_log (en, comp_ne_ss) end select end select end select call var_list%get_rptr (var_str ("tolerance"), tolerance_ptr) en1%tolerance => tolerance_ptr end if end subroutine eval_node_compile_comparison @ %def eval_node_compile_comparison @ \subsubsection{Recording analysis data} The [[record]] command is actually a logical expression which always evaluates [[true]]. <>= recursive subroutine eval_node_compile_record_cmd (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_key, pn_tag, pn_arg type(parse_node_t), pointer :: pn_arg1, pn_arg2, pn_arg3, pn_arg4 type(eval_node_t), pointer :: en0, en1, en2, en3, en4 real(default), pointer :: event_weight if (debug_active (D_MODEL_F)) then print *, "read record_cmd"; call parse_node_write (pn) end if pn_key => parse_node_get_sub_ptr (pn) pn_tag => parse_node_get_next_ptr (pn_key) pn_arg => parse_node_get_next_ptr (pn_tag) select case (char (parse_node_get_key (pn_key))) case ("record") call var_list%get_rptr (var_str ("event_weight"), event_weight) case ("record_unweighted") event_weight => null () case ("record_excess") call var_list%get_rptr (var_str ("event_excess"), event_weight) end select select case (char (parse_node_get_rule_key (pn_tag))) case ("analysis_id") allocate (en0) call eval_node_init_string (en0, parse_node_get_string (pn_tag)) case default call eval_node_compile_sexpr (en0, pn_tag, var_list) end select allocate (en) if (associated (pn_arg)) then pn_arg1 => parse_node_get_sub_ptr (pn_arg) call eval_node_compile_expr (en1, pn_arg1, var_list) if (en1%result_type == V_INT) & call insert_conversion_node (en1, V_REAL) pn_arg2 => parse_node_get_next_ptr (pn_arg1) if (associated (pn_arg2)) then call eval_node_compile_expr (en2, pn_arg2, var_list) if (en2%result_type == V_INT) & call insert_conversion_node (en2, V_REAL) pn_arg3 => parse_node_get_next_ptr (pn_arg2) if (associated (pn_arg3)) then call eval_node_compile_expr (en3, pn_arg3, var_list) if (en3%result_type == V_INT) & call insert_conversion_node (en3, V_REAL) pn_arg4 => parse_node_get_next_ptr (pn_arg3) if (associated (pn_arg4)) then call eval_node_compile_expr (en4, pn_arg4, var_list) if (en4%result_type == V_INT) & call insert_conversion_node (en4, V_REAL) call eval_node_init_record_cmd & (en, event_weight, en0, en1, en2, en3, en4) else call eval_node_init_record_cmd & (en, event_weight, en0, en1, en2, en3) end if else call eval_node_init_record_cmd (en, event_weight, en0, en1, en2) end if else call eval_node_init_record_cmd (en, event_weight, en0, en1) end if else call eval_node_init_record_cmd (en, event_weight, en0) end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done record_cmd" end if end subroutine eval_node_compile_record_cmd @ %def eval_node_compile_record_cmd @ \subsubsection{Particle-list expressions} A particle expression is a subevent or a concatenation of particle-list terms (using \verb|join|). <>= recursive subroutine eval_node_compile_pexpr (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_pterm, pn_concatenation, pn_op, pn_arg type(eval_node_t), pointer :: en1, en2 type(subevt_t) :: subevt if (debug_active (D_MODEL_F)) then print *, "read pexpr"; call parse_node_write (pn) end if pn_pterm => parse_node_get_sub_ptr (pn) call eval_node_compile_pterm (en, pn_pterm, var_list) pn_concatenation => & parse_node_get_next_ptr (pn_pterm, tag="pconcatenation") do while (associated (pn_concatenation)) pn_op => parse_node_get_sub_ptr (pn_concatenation) pn_arg => parse_node_get_next_ptr (pn_op) en1 => en call eval_node_compile_pterm (en2, pn_arg, var_list) allocate (en) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then call subevt_join (subevt, en1%pval, en2%pval) call eval_node_init_subevt (en, subevt) call eval_node_final_rec (en1) call eval_node_final_rec (en2) deallocate (en1, en2) else call eval_node_init_branch & (en, var_str ("join"), V_SEV, en1, en2) call eval_node_set_op2_sev (en, join_pp) end if pn_concatenation => parse_node_get_next_ptr (pn_concatenation) end do if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done pexpr" end if end subroutine eval_node_compile_pexpr @ %def eval_node_compile_pexpr @ A particle term is a subevent or a combination of particle-list values (using \verb|combine|). <>= recursive subroutine eval_node_compile_pterm (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_pvalue, pn_combination, pn_op, pn_arg type(eval_node_t), pointer :: en1, en2 type(subevt_t) :: subevt if (debug_active (D_MODEL_F)) then print *, "read pterm"; call parse_node_write (pn) end if pn_pvalue => parse_node_get_sub_ptr (pn) call eval_node_compile_pvalue (en, pn_pvalue, var_list) pn_combination => & parse_node_get_next_ptr (pn_pvalue, tag="pcombination") do while (associated (pn_combination)) pn_op => parse_node_get_sub_ptr (pn_combination) pn_arg => parse_node_get_next_ptr (pn_op) en1 => en call eval_node_compile_pvalue (en2, pn_arg, var_list) allocate (en) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then call subevt_combine (subevt, en1%pval, en2%pval) call eval_node_init_subevt (en, subevt) call eval_node_final_rec (en1) call eval_node_final_rec (en2) deallocate (en1, en2) else call eval_node_init_branch & (en, var_str ("combine"), V_SEV, en1, en2) call eval_node_set_op2_sev (en, combine_pp) end if pn_combination => parse_node_get_next_ptr (pn_combination) end do if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done pterm" end if end subroutine eval_node_compile_pterm @ %def eval_node_compile_pterm @ A particle-list value is a PDG-code array, a particle identifier, a variable, a (grouped) pexpr, a block pexpr, a conditional, or a particle-list function. The [[cexpr]] node is responsible for transforming a constant PDG-code array into a subevent. It takes the code array as its first argument, the event subevent as its second argument, and the requested particle type (incoming/outgoing) as its zero-th argument. The result is the list of particles in the event that match the code array. <>= recursive subroutine eval_node_compile_pvalue (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_prefix_cexpr type(eval_node_t), pointer :: en1, en2, en0 type(string_t) :: key type(subevt_t), pointer :: evt_ptr logical, pointer :: known if (debug_active (D_MODEL_F)) then print *, "read pvalue"; call parse_node_write (pn) end if select case (char (parse_node_get_rule_key (pn))) case ("pexpr_src") call eval_node_compile_prefix_cexpr (en1, pn, var_list) allocate (en2) if (var_list%contains (var_str ("@evt"))) then call var_list%get_pptr (var_str ("@evt"), evt_ptr, known) call eval_node_init_subevt_ptr (en2, var_str ("@evt"), evt_ptr, known) allocate (en) call eval_node_init_branch & (en, var_str ("prt_selection"), V_SEV, en1, en2) call eval_node_set_op2_sev (en, select_pdg_ca) allocate (en0) pn_prefix_cexpr => parse_node_get_sub_ptr (pn) key = parse_node_get_rule_key (pn_prefix_cexpr) select case (char (key)) case ("beam_prt") call eval_node_init_int (en0, PRT_BEAM) en%arg0 => en0 case ("incoming_prt") call eval_node_init_int (en0, PRT_INCOMING) en%arg0 => en0 case ("outgoing_prt") call eval_node_init_int (en0, PRT_OUTGOING) en%arg0 => en0 case ("unspecified_prt") call eval_node_init_int (en0, PRT_OUTGOING) en%arg0 => en0 end select else call parse_node_write (pn) call msg_bug (" Missing event data while compiling pvalue") end if case ("pvariable") call eval_node_compile_variable (en, pn, var_list, V_SEV) case ("pexpr") call eval_node_compile_pexpr (en, pn, var_list) case ("block_pexpr") call eval_node_compile_block_expr (en, pn, var_list, V_SEV) case ("conditional_pexpr") call eval_node_compile_conditional (en, pn, var_list, V_SEV) case ("join_fun", "combine_fun", "collect_fun", "cluster_fun", & "select_fun", "extract_fun", "sort_fun") call eval_node_compile_prt_function (en, pn, var_list) case default call parse_node_mismatch & ("prefix_cexpr|pvariable|" // & "grouped_pexpr|block_pexpr|conditional_pexpr|" // & "prt_function", pn) end select if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done pvalue" end if end subroutine eval_node_compile_pvalue @ %def eval_node_compile_pvalue @ \subsubsection{Particle functions} This combines the treatment of 'join', 'combine', 'collect', 'cluster', 'select', and 'extract' which all have the same syntax. The one or two argument nodes are allocated. If there is a condition, the condition node is also allocated as a logical expression, for which the variable list is augmented by the appropriate (unary/binary) observables. <>= recursive subroutine eval_node_compile_prt_function (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_clause, pn_key, pn_cond, pn_args type(parse_node_t), pointer :: pn_arg0, pn_arg1, pn_arg2 type(eval_node_t), pointer :: en0, en1, en2 type(string_t) :: key if (debug_active (D_MODEL_F)) then print *, "read prt_function"; call parse_node_write (pn) end if pn_clause => parse_node_get_sub_ptr (pn) pn_key => parse_node_get_sub_ptr (pn_clause) pn_cond => parse_node_get_next_ptr (pn_key) if (associated (pn_cond)) & pn_arg0 => parse_node_get_sub_ptr (pn_cond, 2) pn_args => parse_node_get_next_ptr (pn_clause) pn_arg1 => parse_node_get_sub_ptr (pn_args) pn_arg2 => parse_node_get_next_ptr (pn_arg1) key = parse_node_get_key (pn_key) call eval_node_compile_pexpr (en1, pn_arg1, var_list) allocate (en) if (.not. associated (pn_arg2)) then select case (char (key)) case ("collect") call eval_node_init_prt_fun_unary (en, en1, key, collect_p) case ("cluster") if (fastjet_available ()) then call fastjet_init () else call msg_fatal & ("'cluster' function requires FastJet, which is not enabled") end if en1%var_list => var_list call eval_node_init_prt_fun_unary (en, en1, key, cluster_p) call var_list%get_iptr (var_str ("jet_algorithm"), en1%jet_algorithm) call var_list%get_rptr (var_str ("jet_r"), en1%jet_r) call var_list%get_rptr (var_str ("jet_p"), en1%jet_p) call var_list%get_rptr (var_str ("jet_ycut"), en1%jet_ycut) case ("select") call eval_node_init_prt_fun_unary (en, en1, key, select_p) case ("extract") call eval_node_init_prt_fun_unary (en, en1, key, extract_p) case ("sort") call eval_node_init_prt_fun_unary (en, en1, key, sort_p) case default call msg_bug (" Unary particle function '" // char (key) // & "' undefined") end select else call eval_node_compile_pexpr (en2, pn_arg2, var_list) select case (char (key)) case ("join") call eval_node_init_prt_fun_binary (en, en1, en2, key, join_pp) case ("combine") call eval_node_init_prt_fun_binary (en, en1, en2, key, combine_pp) case ("collect") call eval_node_init_prt_fun_binary (en, en1, en2, key, collect_pp) case ("select") call eval_node_init_prt_fun_binary (en, en1, en2, key, select_pp) case ("sort") call eval_node_init_prt_fun_binary (en, en1, en2, key, sort_pp) case default call msg_bug (" Binary particle function '" // char (key) // & "' undefined") end select end if if (associated (pn_cond)) then call eval_node_set_observables (en, var_list) select case (char (key)) case ("extract", "sort") call eval_node_compile_expr (en0, pn_arg0, en%var_list) case default call eval_node_compile_lexpr (en0, pn_arg0, en%var_list) end select en%arg0 => en0 end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done prt_function" end if end subroutine eval_node_compile_prt_function @ %def eval_node_compile_prt_function @ The [[eval]] expression is similar, but here the expression [[arg0]] is mandatory, and the whole thing evaluates to a numeric value. <>= recursive subroutine eval_node_compile_eval_function (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_key, pn_arg0, pn_args, pn_arg1, pn_arg2 type(eval_node_t), pointer :: en0, en1, en2 type(string_t) :: key if (debug_active (D_MODEL_F)) then print *, "read eval_function"; call parse_node_write (pn) end if pn_key => parse_node_get_sub_ptr (pn) pn_arg0 => parse_node_get_next_ptr (pn_key) pn_args => parse_node_get_next_ptr (pn_arg0) pn_arg1 => parse_node_get_sub_ptr (pn_args) pn_arg2 => parse_node_get_next_ptr (pn_arg1) key = parse_node_get_key (pn_key) call eval_node_compile_pexpr (en1, pn_arg1, var_list) allocate (en) if (.not. associated (pn_arg2)) then call eval_node_init_eval_fun_unary (en, en1, key) else call eval_node_compile_pexpr (en2, pn_arg2, var_list) call eval_node_init_eval_fun_binary (en, en1, en2, key) end if call eval_node_set_observables (en, var_list) call eval_node_compile_expr (en0, pn_arg0, en%var_list) if (en0%result_type /= V_REAL) & call msg_fatal (" 'eval' function does not result in real value") call eval_node_set_expr (en, en0) if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done eval_function" end if end subroutine eval_node_compile_eval_function @ %def eval_node_compile_eval_function @ Logical functions of subevents. <>= recursive subroutine eval_node_compile_log_function (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_key, pn_str type(parse_node_t), pointer :: pn_arg0, pn_args, pn_arg1, pn_arg2 type(eval_node_t), pointer :: en0, en1, en2 type(string_t) :: key if (debug_active (D_MODEL_F)) then print *, "read log_function"; call parse_node_write (pn) end if select case (char (parse_node_get_rule_key (pn))) case ("all_fun", "any_fun", "no_fun") pn_key => parse_node_get_sub_ptr (pn) pn_arg0 => parse_node_get_next_ptr (pn_key) pn_args => parse_node_get_next_ptr (pn_arg0) case ("user_cut_fun") pn_key => parse_node_get_sub_ptr (pn) pn_str => parse_node_get_next_ptr (pn_key) pn_arg0 => parse_node_get_sub_ptr (pn_str) pn_args => parse_node_get_next_ptr (pn_str) case default call parse_node_mismatch & ("all_fun|any_fun|no_fun|user_cut_fun", & pn) end select pn_arg1 => parse_node_get_sub_ptr (pn_args) pn_arg2 => parse_node_get_next_ptr (pn_arg1) key = parse_node_get_key (pn_key) call eval_node_compile_pexpr (en1, pn_arg1, var_list) allocate (en) if (.not. associated (pn_arg2)) then select case (char (key)) case ("all") call eval_node_init_log_fun_unary (en, en1, key, all_p) case ("any") call eval_node_init_log_fun_unary (en, en1, key, any_p) case ("no") call eval_node_init_log_fun_unary (en, en1, key, no_p) case ("user_cut") call eval_node_init_log_fun_unary (en, en1, key, user_cut_p) case default call msg_bug ("Unary logical particle function '" // char (key) // & "' undefined") end select else call eval_node_compile_pexpr (en2, pn_arg2, var_list) select case (char (key)) case ("all") call eval_node_init_log_fun_binary (en, en1, en2, key, all_pp) case ("any") call eval_node_init_log_fun_binary (en, en1, en2, key, any_pp) case ("no") call eval_node_init_log_fun_binary (en, en1, en2, key, no_pp) case default call msg_bug ("Binary logical particle function '" // char (key) // & "' undefined") end select end if if (associated (pn_arg0)) then call eval_node_set_observables (en, var_list) select case (char (key)) case ("all", "any", "no") call eval_node_compile_lexpr (en0, pn_arg0, en%var_list) case ("user_cut") call eval_node_compile_sexpr (en0, pn_arg0, en%var_list) case default call msg_bug ("Compiling logical particle function: missing mode") end select call eval_node_set_expr (en, en0, V_LOG) end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done log_function" end if end subroutine eval_node_compile_log_function @ %def eval_node_compile_log_function @ Numeric functions of subevents. <>= recursive subroutine eval_node_compile_numeric_function (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_clause, pn_key, pn_cond, pn_args type(parse_node_t), pointer :: pn_arg0, pn_arg1, pn_arg2 type(eval_node_t), pointer :: en0, en1, en2 type(string_t) :: key if (debug_active (D_MODEL_F)) then print *, "read numeric_function"; call parse_node_write (pn) end if select case (char (parse_node_get_rule_key (pn))) case ("count_fun") pn_clause => parse_node_get_sub_ptr (pn) pn_key => parse_node_get_sub_ptr (pn_clause) pn_cond => parse_node_get_next_ptr (pn_key) if (associated (pn_cond)) then pn_arg0 => parse_node_get_sub_ptr (pn_cond, 2) else pn_arg0 => null () end if pn_args => parse_node_get_next_ptr (pn_clause) case ("user_event_fun") pn_key => parse_node_get_sub_ptr (pn) pn_cond => parse_node_get_next_ptr (pn_key) pn_arg0 => parse_node_get_sub_ptr (pn_cond) pn_args => parse_node_get_next_ptr (pn_cond) end select pn_arg1 => parse_node_get_sub_ptr (pn_args) pn_arg2 => parse_node_get_next_ptr (pn_arg1) key = parse_node_get_key (pn_key) call eval_node_compile_pexpr (en1, pn_arg1, var_list) allocate (en) if (.not. associated (pn_arg2)) then select case (char (key)) case ("count") call eval_node_init_int_fun_unary (en, en1, key, count_a) case ("user_event_shape") call eval_node_init_real_fun_unary (en, en1, key, user_event_shape_a) case default call msg_bug ("Unary subevent function '" // char (key) // & "' undefined") end select else call eval_node_compile_pexpr (en2, pn_arg2, var_list) select case (char (key)) case ("count") call eval_node_init_int_fun_binary (en, en1, en2, key, count_pp) case default call msg_bug ("Binary subevent function '" // char (key) // & "' undefined") end select end if if (associated (pn_arg0)) then call eval_node_set_observables (en, var_list) select case (char (key)) case ("count") call eval_node_compile_lexpr (en0, pn_arg0, en%var_list) call eval_node_set_expr (en, en0, V_INT) case ("user_event_shape") call eval_node_compile_sexpr (en0, pn_arg0, en%var_list) call eval_node_set_expr (en, en0, V_REAL) end select end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done numeric_function" end if end subroutine eval_node_compile_numeric_function @ %def eval_node_compile_numeric_function @ \subsubsection{PDG-code arrays} A PDG-code expression is (optionally) prefixed by [[beam]], [[incoming]], or [[outgoing]], a block, or a conditional. In any case, it evaluates to a constant. <>= recursive subroutine eval_node_compile_prefix_cexpr (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_avalue, pn_prt type(string_t) :: key if (debug_active (D_MODEL_F)) then print *, "read prefix_cexpr"; call parse_node_write (pn) end if pn_avalue => parse_node_get_sub_ptr (pn) key = parse_node_get_rule_key (pn_avalue) select case (char (key)) case ("beam_prt") pn_prt => parse_node_get_sub_ptr (pn_avalue, 2) call eval_node_compile_cexpr (en, pn_prt, var_list) case ("incoming_prt") pn_prt => parse_node_get_sub_ptr (pn_avalue, 2) call eval_node_compile_cexpr (en, pn_prt, var_list) case ("outgoing_prt") pn_prt => parse_node_get_sub_ptr (pn_avalue, 2) call eval_node_compile_cexpr (en, pn_prt, var_list) case ("unspecified_prt") pn_prt => parse_node_get_sub_ptr (pn_avalue, 1) call eval_node_compile_cexpr (en, pn_prt, var_list) case default call parse_node_mismatch & ("beam_prt|incoming_prt|outgoing_prt|unspecified_prt", & pn_avalue) end select if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done prefix_cexpr" end if end subroutine eval_node_compile_prefix_cexpr @ %def eval_node_compile_prefix_cexpr @ A PDG array is a string of PDG code definitions (or aliases), concatenated by ':'. The code definitions may be variables which are not defined at compile time, so we have to allocate sub-nodes. This analogous to [[eval_node_compile_term]]. <>= recursive subroutine eval_node_compile_cexpr (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_prt, pn_concatenation type(eval_node_t), pointer :: en1, en2 type(pdg_array_t) :: aval if (debug_active (D_MODEL_F)) then print *, "read cexpr"; call parse_node_write (pn) end if pn_prt => parse_node_get_sub_ptr (pn) call eval_node_compile_avalue (en, pn_prt, var_list) pn_concatenation => parse_node_get_next_ptr (pn_prt) do while (associated (pn_concatenation)) pn_prt => parse_node_get_sub_ptr (pn_concatenation, 2) en1 => en call eval_node_compile_avalue (en2, pn_prt, var_list) allocate (en) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then call concat_cc (aval, en1, en2) call eval_node_init_pdg_array (en, aval) call eval_node_final_rec (en1) call eval_node_final_rec (en2) deallocate (en1, en2) else call eval_node_init_branch (en, var_str (":"), V_PDG, en1, en2) call eval_node_set_op2_pdg (en, concat_cc) end if pn_concatenation => parse_node_get_next_ptr (pn_concatenation) end do if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done cexpr" end if end subroutine eval_node_compile_cexpr @ %def eval_node_compile_cexpr @ Compile a PDG-code type value. It may be either an integer expression or a variable of type PDG array, optionally quoted. <>= recursive subroutine eval_node_compile_avalue (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list if (debug_active (D_MODEL_F)) then print *, "read avalue"; call parse_node_write (pn) end if select case (char (parse_node_get_rule_key (pn))) case ("pdg_code") call eval_node_compile_pdg_code (en, pn, var_list) case ("cvariable", "variable", "prt_name") call eval_node_compile_cvariable (en, pn, var_list) case ("cexpr") call eval_node_compile_cexpr (en, pn, var_list) case ("block_cexpr") call eval_node_compile_block_expr (en, pn, var_list, V_PDG) case ("conditional_cexpr") call eval_node_compile_conditional (en, pn, var_list, V_PDG) case default call parse_node_mismatch & ("grouped_cexpr|block_cexpr|conditional_cexpr|" // & "pdg_code|cvariable|prt_name", pn) end select if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done avalue" end if end subroutine eval_node_compile_avalue @ %def eval_node_compile_avalue @ Compile a PDG-code expression, which is the key [[PDG]] with an integer expression as argument. The procedure is analogous to [[eval_node_compile_unary_function]]. <>= subroutine eval_node_compile_pdg_code (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in), target :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_arg type(eval_node_t), pointer :: en1 type(string_t) :: key type(pdg_array_t) :: aval integer :: t if (debug_active (D_MODEL_F)) then print *, "read PDG code"; call parse_node_write (pn) end if pn_arg => parse_node_get_sub_ptr (pn, 2) call eval_node_compile_expr & (en1, parse_node_get_sub_ptr (pn_arg, tag="expr"), var_list) t = en1%result_type allocate (en) key = "PDG" if (en1%type == EN_CONSTANT) then select case (t) case (V_INT) call pdg_i (aval, en1) call eval_node_init_pdg_array (en, aval) case default; call eval_type_error (pn, char (key), t) end select call eval_node_final_rec (en1) deallocate (en1) else select case (t) case (V_INT); call eval_node_set_op1_pdg (en, pdg_i) case default; call eval_type_error (pn, char (key), t) end select end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done function" end if end subroutine eval_node_compile_pdg_code @ %def eval_node_compile_pdg_code @ This is entirely analogous to [[eval_node_compile_variable]]. However, PDG-array variables occur in different contexts. To avoid name clashes between PDG-array variables and ordinary variables, we prepend a character ([[*]]). This is not visible to the user. <>= subroutine eval_node_compile_cvariable (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in), target :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_name type(string_t) :: var_name type(pdg_array_t), pointer :: aptr type(pdg_array_t), target, save :: no_aval logical, pointer :: known logical, target, save :: unknown = .false. if (debug_active (D_MODEL_F)) then print *, "read cvariable"; call parse_node_write (pn) end if pn_name => pn var_name = parse_node_get_string (pn_name) allocate (en) if (var_list%contains (var_name)) then call var_list%get_aptr (var_name, aptr, known) call eval_node_init_pdg_array_ptr (en, var_name, aptr, known) else call parse_node_write (pn) call msg_error ("This PDG-array variable is undefined at this point") call eval_node_init_pdg_array_ptr (en, var_name, no_aval, unknown) end if if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done cvariable" end if end subroutine eval_node_compile_cvariable @ %def eval_node_compile_cvariable @ \subsubsection{String expressions} A string expression is either a string value or a concatenation of string values. <>= recursive subroutine eval_node_compile_sexpr (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_svalue, pn_concatenation, pn_op, pn_arg type(eval_node_t), pointer :: en1, en2 type(string_t) :: string if (debug_active (D_MODEL_F)) then print *, "read sexpr"; call parse_node_write (pn) end if pn_svalue => parse_node_get_sub_ptr (pn) call eval_node_compile_svalue (en, pn_svalue, var_list) pn_concatenation => & parse_node_get_next_ptr (pn_svalue, tag="str_concatenation") do while (associated (pn_concatenation)) pn_op => parse_node_get_sub_ptr (pn_concatenation) pn_arg => parse_node_get_next_ptr (pn_op) en1 => en call eval_node_compile_svalue (en2, pn_arg, var_list) allocate (en) if (en1%type == EN_CONSTANT .and. en2%type == EN_CONSTANT) then call concat_ss (string, en1, en2) call eval_node_init_string (en, string) call eval_node_final_rec (en1) call eval_node_final_rec (en2) deallocate (en1, en2) else call eval_node_init_branch & (en, var_str ("concat"), V_STR, en1, en2) call eval_node_set_op2_str (en, concat_ss) end if pn_concatenation => parse_node_get_next_ptr (pn_concatenation) end do if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done sexpr" end if end subroutine eval_node_compile_sexpr @ %def eval_node_compile_sexpr @ A string value is a string literal, a variable, a (grouped) sexpr, a block sexpr, or a conditional. <>= recursive subroutine eval_node_compile_svalue (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list if (debug_active (D_MODEL_F)) then print *, "read svalue"; call parse_node_write (pn) end if select case (char (parse_node_get_rule_key (pn))) case ("svariable") call eval_node_compile_variable (en, pn, var_list, V_STR) case ("sexpr") call eval_node_compile_sexpr (en, pn, var_list) case ("block_sexpr") call eval_node_compile_block_expr (en, pn, var_list, V_STR) case ("conditional_sexpr") call eval_node_compile_conditional (en, pn, var_list, V_STR) case ("sprintf_fun") call eval_node_compile_sprintf (en, pn, var_list) case ("string_literal") allocate (en) call eval_node_init_string (en, parse_node_get_string (pn)) case default call parse_node_mismatch & ("svariable|" // & "grouped_sexpr|block_sexpr|conditional_sexpr|" // & "string_function|string_literal", pn) end select if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done svalue" end if end subroutine eval_node_compile_svalue @ %def eval_node_compile_svalue @ There is currently one string function, [[sprintf]]. For [[sprintf]], the first argument (no brackets) is the format string, the optional arguments in brackets are the expressions or variables to be formatted. <>= recursive subroutine eval_node_compile_sprintf (en, pn, var_list) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_clause, pn_key, pn_args type(parse_node_t), pointer :: pn_arg0 type(eval_node_t), pointer :: en0, en1 integer :: n_args type(string_t) :: key if (debug_active (D_MODEL_F)) then print *, "read sprintf_fun"; call parse_node_write (pn) end if pn_clause => parse_node_get_sub_ptr (pn) pn_key => parse_node_get_sub_ptr (pn_clause) pn_arg0 => parse_node_get_next_ptr (pn_key) pn_args => parse_node_get_next_ptr (pn_clause) call eval_node_compile_sexpr (en0, pn_arg0, var_list) if (associated (pn_args)) then call eval_node_compile_sprintf_args (en1, pn_args, var_list, n_args) else n_args = 0 en1 => null () end if allocate (en) key = parse_node_get_key (pn_key) call eval_node_init_format_string (en, en0, en1, key, n_args) if (debug_active (D_MODEL_F)) then call eval_node_write (en) print *, "done sprintf_fun" end if end subroutine eval_node_compile_sprintf @ %def eval_node_compile_sprintf <>= subroutine eval_node_compile_sprintf_args (en, pn, var_list, n_args) type(eval_node_t), pointer :: en type(parse_node_t), intent(in) :: pn type(var_list_t), intent(in), target :: var_list integer, intent(out) :: n_args type(parse_node_t), pointer :: pn_arg integer :: i type(eval_node_t), pointer :: en1, en2 n_args = parse_node_get_n_sub (pn) en => null () do i = n_args, 1, -1 pn_arg => parse_node_get_sub_ptr (pn, i) select case (char (parse_node_get_rule_key (pn_arg))) case ("lvariable") call eval_node_compile_variable (en1, pn_arg, var_list, V_LOG) case ("svariable") call eval_node_compile_variable (en1, pn_arg, var_list, V_STR) case ("expr") call eval_node_compile_expr (en1, pn_arg, var_list) case default call parse_node_mismatch ("variable|svariable|lvariable|expr", pn_arg) end select if (associated (en)) then en2 => en allocate (en) call eval_node_init_branch & (en, var_str ("sprintf_arg"), V_NONE, en1, en2) else allocate (en) call eval_node_init_branch & (en, var_str ("sprintf_arg"), V_NONE, en1) end if end do end subroutine eval_node_compile_sprintf_args @ %def eval_node_compile_sprintf_args @ Evaluation. We allocate the argument list and apply the Fortran wrapper for the [[sprintf]] function. <>= subroutine evaluate_sprintf (string, n_args, en_fmt, en_arg) type(string_t), intent(out) :: string integer, intent(in) :: n_args type(eval_node_t), pointer :: en_fmt type(eval_node_t), intent(in), optional, target :: en_arg type(eval_node_t), pointer :: en_branch, en_var type(sprintf_arg_t), dimension(:), allocatable :: arg type(string_t) :: fmt logical :: autoformat integer :: i, j, sprintf_argc autoformat = .not. associated (en_fmt) if (autoformat) fmt = "" if (present (en_arg)) then sprintf_argc = 0 en_branch => en_arg do i = 1, n_args select case (en_branch%arg1%result_type) case (V_CMPLX); sprintf_argc = sprintf_argc + 2 case default ; sprintf_argc = sprintf_argc + 1 end select en_branch => en_branch%arg2 end do allocate (arg (sprintf_argc)) j = 1 en_branch => en_arg do i = 1, n_args en_var => en_branch%arg1 select case (en_var%result_type) case (V_LOG) call sprintf_arg_init (arg(j), en_var%lval) if (autoformat) fmt = fmt // "%s " case (V_INT); call sprintf_arg_init (arg(j), en_var%ival) if (autoformat) fmt = fmt // "%i " case (V_REAL); call sprintf_arg_init (arg(j), en_var%rval) if (autoformat) fmt = fmt // "%g " case (V_STR) call sprintf_arg_init (arg(j), en_var%sval) if (autoformat) fmt = fmt // "%s " case (V_CMPLX) call sprintf_arg_init (arg(j), real (en_var%cval, default)) j = j + 1 call sprintf_arg_init (arg(j), aimag (en_var%cval)) if (autoformat) fmt = fmt // "(%g + %g * I) " case default call eval_node_write (en_var) call msg_error ("sprintf is implemented " & // "for logical, integer, real, and string values only") end select j = j + 1 en_branch => en_branch%arg2 end do else allocate (arg(0)) end if if (autoformat) then string = sprintf (trim (fmt), arg) else string = sprintf (en_fmt%sval, arg) end if end subroutine evaluate_sprintf @ %def evaluate_sprintf @ \subsection{Auxiliary functions for the compiler} Issue an error that the current node could not be compiled because of type mismatch: <>= subroutine eval_type_error (pn, string, t) type(parse_node_t), intent(in) :: pn character(*), intent(in) :: string integer, intent(in) :: t type(string_t) :: type select case (t) case (V_NONE); type = "(none)" case (V_LOG); type = "'logical'" case (V_INT); type = "'integer'" case (V_REAL); type = "'real'" case (V_CMPLX); type = "'complex'" case default; type = "(unknown)" end select call parse_node_write (pn) call msg_fatal (" The " // string // & " operation is not defined for the given argument type " // & char (type)) end subroutine eval_type_error @ %def eval_type_error @ If two numerics are combined, the result is integer if both arguments are integer, if one is integer and the other real or both are real, than its argument is real, otherwise complex. <>= function numeric_result_type (t1, t2) result (t) integer, intent(in) :: t1, t2 integer :: t if (t1 == V_INT .and. t2 == V_INT) then t = V_INT else if (t1 == V_INT .and. t2 == V_REAL) then t = V_REAL else if (t1 == V_REAL .and. t2 == V_INT) then t = V_REAL else if (t1 == V_REAL .and. t2 == V_REAL) then t = V_REAL else t = V_CMPLX end if end function numeric_result_type @ %def numeric_type @ \subsection{Evaluation} Evaluation is done recursively. For leaf nodes nothing is to be done. Evaluating particle-list functions: First, we evaluate the particle lists. If a condition is present, we assign the particle pointers of the condition node to the allocated particle entries in the parent node, keeping in mind that the observables in the variable stack used for the evaluation of the condition also contain pointers to these entries. Then, the assigned procedure is evaluated, which sets the subevent in the parent node. If required, the procedure evaluates the condition node once for each (pair of) particles to determine the result. <>= recursive subroutine eval_node_evaluate (en) type(eval_node_t), intent(inout) :: en logical :: exist select case (en%type) case (EN_UNARY) if (associated (en%arg1)) then call eval_node_evaluate (en%arg1) en%value_is_known = en%arg1%value_is_known else en%value_is_known = .false. end if if (en%value_is_known) then select case (en%result_type) case (V_LOG); en%lval = en%op1_log (en%arg1) case (V_INT); en%ival = en%op1_int (en%arg1) case (V_REAL); en%rval = en%op1_real (en%arg1) case (V_CMPLX); en%cval = en%op1_cmplx (en%arg1) case (V_PDG); call en%op1_pdg (en%aval, en%arg1) case (V_SEV) if (associated (en%arg0)) then call en%op1_sev (en%pval, en%arg1, en%arg0) else call en%op1_sev (en%pval, en%arg1) end if case (V_STR) call en%op1_str (en%sval, en%arg1) end select end if case (EN_BINARY) if (associated (en%arg1) .and. associated (en%arg2)) then call eval_node_evaluate (en%arg1) call eval_node_evaluate (en%arg2) en%value_is_known = & en%arg1%value_is_known .and. en%arg2%value_is_known else en%value_is_known = .false. end if if (en%value_is_known) then select case (en%result_type) case (V_LOG); en%lval = en%op2_log (en%arg1, en%arg2) case (V_INT); en%ival = en%op2_int (en%arg1, en%arg2) case (V_REAL); en%rval = en%op2_real (en%arg1, en%arg2) case (V_CMPLX); en%cval = en%op2_cmplx (en%arg1, en%arg2) case (V_PDG) call en%op2_pdg (en%aval, en%arg1, en%arg2) case (V_SEV) if (associated (en%arg0)) then call en%op2_sev (en%pval, en%arg1, en%arg2, en%arg0) else call en%op2_sev (en%pval, en%arg1, en%arg2) end if case (V_STR) call en%op2_str (en%sval, en%arg1, en%arg2) end select end if case (EN_BLOCK) if (associated (en%arg1) .and. associated (en%arg0)) then call eval_node_evaluate (en%arg1) call eval_node_evaluate (en%arg0) en%value_is_known = en%arg0%value_is_known else en%value_is_known = .false. end if if (en%value_is_known) then select case (en%result_type) case (V_LOG); en%lval = en%arg0%lval case (V_INT); en%ival = en%arg0%ival case (V_REAL); en%rval = en%arg0%rval case (V_CMPLX); en%cval = en%arg0%cval case (V_PDG); en%aval = en%arg0%aval case (V_SEV); en%pval = en%arg0%pval case (V_STR); en%sval = en%arg0%sval end select end if case (EN_CONDITIONAL) if (associated (en%arg0)) then call eval_node_evaluate (en%arg0) en%value_is_known = en%arg0%value_is_known else en%value_is_known = .false. end if if (en%arg0%value_is_known) then if (en%arg0%lval) then call eval_node_evaluate (en%arg1) en%value_is_known = en%arg1%value_is_known if (en%value_is_known) then select case (en%result_type) case (V_LOG); en%lval = en%arg1%lval case (V_INT); en%ival = en%arg1%ival case (V_REAL); en%rval = en%arg1%rval case (V_CMPLX); en%cval = en%arg1%cval case (V_PDG); en%aval = en%arg1%aval case (V_SEV); en%pval = en%arg1%pval case (V_STR); en%sval = en%arg1%sval end select end if else call eval_node_evaluate (en%arg2) en%value_is_known = en%arg2%value_is_known if (en%value_is_known) then select case (en%result_type) case (V_LOG); en%lval = en%arg2%lval case (V_INT); en%ival = en%arg2%ival case (V_REAL); en%rval = en%arg2%rval case (V_CMPLX); en%cval = en%arg2%cval case (V_PDG); en%aval = en%arg2%aval case (V_SEV); en%pval = en%arg2%pval case (V_STR); en%sval = en%arg2%sval end select end if end if end if case (EN_RECORD_CMD) exist = .true. en%lval = .false. call eval_node_evaluate (en%arg0) if (en%arg0%value_is_known) then if (associated (en%arg1)) then call eval_node_evaluate (en%arg1) if (en%arg1%value_is_known) then if (associated (en%arg2)) then call eval_node_evaluate (en%arg2) if (en%arg2%value_is_known) then if (associated (en%arg3)) then call eval_node_evaluate (en%arg3) if (en%arg3%value_is_known) then if (associated (en%arg4)) then call eval_node_evaluate (en%arg4) if (en%arg4%value_is_known) then if (associated (en%rval)) then call analysis_record_data (en%arg0%sval, & en%arg1%rval, en%arg2%rval, & en%arg3%rval, en%arg4%rval, & weight=en%rval, exist=exist, & success=en%lval) else call analysis_record_data (en%arg0%sval, & en%arg1%rval, en%arg2%rval, & en%arg3%rval, en%arg4%rval, & exist=exist, success=en%lval) end if end if else if (associated (en%rval)) then call analysis_record_data (en%arg0%sval, & en%arg1%rval, en%arg2%rval, & en%arg3%rval, & weight=en%rval, exist=exist, & success=en%lval) else call analysis_record_data (en%arg0%sval, & en%arg1%rval, en%arg2%rval, & en%arg3%rval, & exist=exist, success=en%lval) end if end if end if else if (associated (en%rval)) then call analysis_record_data (en%arg0%sval, & en%arg1%rval, en%arg2%rval, & weight=en%rval, exist=exist, & success=en%lval) else call analysis_record_data (en%arg0%sval, & en%arg1%rval, en%arg2%rval, & exist=exist, success=en%lval) end if end if end if else if (associated (en%rval)) then call analysis_record_data (en%arg0%sval, & en%arg1%rval, & weight=en%rval, exist=exist, success=en%lval) else call analysis_record_data (en%arg0%sval, & en%arg1%rval, & exist=exist, success=en%lval) end if end if end if else if (associated (en%rval)) then call analysis_record_data (en%arg0%sval, 1._default, & weight=en%rval, exist=exist, success=en%lval) else call analysis_record_data (en%arg0%sval, 1._default, & exist=exist, success=en%lval) end if end if if (.not. exist) then call msg_error ("Analysis object '" // char (en%arg0%sval) & // "' is undefined") en%arg0%value_is_known = .false. end if end if case (EN_OBS1_INT) en%ival = en%obs1_int (en%prt1) en%value_is_known = .true. case (EN_OBS2_INT) en%ival = en%obs2_int (en%prt1, en%prt2) en%value_is_known = .true. case (EN_OBS1_REAL) en%rval = en%obs1_real (en%prt1) en%value_is_known = .true. case (EN_OBS2_REAL) en%rval = en%obs2_real (en%prt1, en%prt2) en%value_is_known = .true. case (EN_UOBS1_INT) en%ival = user_obs_int_p (en%arg0, en%prt1) en%value_is_known = .true. case (EN_UOBS2_INT) en%ival = user_obs_int_pp (en%arg0, en%prt1, en%prt2) en%value_is_known = .true. case (EN_UOBS1_REAL) en%rval = user_obs_real_p (en%arg0, en%prt1) en%value_is_known = .true. case (EN_UOBS2_REAL) en%rval = user_obs_real_pp (en%arg0, en%prt1, en%prt2) en%value_is_known = .true. case (EN_PRT_FUN_UNARY) call eval_node_evaluate (en%arg1) en%value_is_known = en%arg1%value_is_known if (en%value_is_known) then if (associated (en%arg0)) then en%arg0%index => en%index en%arg0%prt1 => en%prt1 call en%op1_sev (en%pval, en%arg1, en%arg0) else call en%op1_sev (en%pval, en%arg1) end if end if case (EN_PRT_FUN_BINARY) call eval_node_evaluate (en%arg1) call eval_node_evaluate (en%arg2) en%value_is_known = & en%arg1%value_is_known .and. en%arg2%value_is_known if (en%value_is_known) then if (associated (en%arg0)) then en%arg0%index => en%index en%arg0%prt1 => en%prt1 en%arg0%prt2 => en%prt2 call en%op2_sev (en%pval, en%arg1, en%arg2, en%arg0) else call en%op2_sev (en%pval, en%arg1, en%arg2) end if end if case (EN_EVAL_FUN_UNARY) call eval_node_evaluate (en%arg1) en%value_is_known = subevt_is_nonempty (en%arg1%pval) if (en%value_is_known) then en%arg0%index => en%index en%index = 1 en%arg0%prt1 => en%prt1 en%prt1 = subevt_get_prt (en%arg1%pval, 1) call eval_node_evaluate (en%arg0) en%rval = en%arg0%rval end if case (EN_EVAL_FUN_BINARY) call eval_node_evaluate (en%arg1) call eval_node_evaluate (en%arg2) en%value_is_known = & subevt_is_nonempty (en%arg1%pval) .and. & subevt_is_nonempty (en%arg2%pval) if (en%value_is_known) then en%arg0%index => en%index en%arg0%prt1 => en%prt1 en%arg0%prt2 => en%prt2 en%index = 1 call eval_pp (en%arg1, en%arg2, en%arg0, en%rval, en%value_is_known) end if case (EN_LOG_FUN_UNARY) call eval_node_evaluate (en%arg1) en%value_is_known = .true. if (en%value_is_known) then en%arg0%index => en%index en%arg0%prt1 => en%prt1 en%lval = en%op1_cut (en%arg1, en%arg0) end if case (EN_LOG_FUN_BINARY) call eval_node_evaluate (en%arg1) call eval_node_evaluate (en%arg2) en%value_is_known = .true. if (en%value_is_known) then en%arg0%index => en%index en%arg0%prt1 => en%prt1 en%arg0%prt2 => en%prt2 en%lval = en%op2_cut (en%arg1, en%arg2, en%arg0) end if case (EN_INT_FUN_UNARY) call eval_node_evaluate (en%arg1) en%value_is_known = en%arg1%value_is_known if (en%value_is_known) then if (associated (en%arg0)) then en%arg0%index => en%index en%arg0%prt1 => en%prt1 call en%op1_evi (en%ival, en%arg1, en%arg0) else call en%op1_evi (en%ival, en%arg1) end if end if case (EN_INT_FUN_BINARY) call eval_node_evaluate (en%arg1) call eval_node_evaluate (en%arg2) en%value_is_known = & en%arg1%value_is_known .and. & en%arg2%value_is_known if (en%value_is_known) then if (associated (en%arg0)) then en%arg0%index => en%index en%arg0%prt1 => en%prt1 en%arg0%prt2 => en%prt2 call en%op2_evi (en%ival, en%arg1, en%arg2, en%arg0) else call en%op2_evi (en%ival, en%arg1, en%arg2) end if end if case (EN_REAL_FUN_UNARY) call eval_node_evaluate (en%arg1) en%value_is_known = en%arg1%value_is_known if (en%value_is_known) then if (associated (en%arg0)) then en%arg0%index => en%index en%arg0%prt1 => en%prt1 call en%op1_evr (en%rval, en%arg1, en%arg0) else call en%op1_evr (en%rval, en%arg1) end if end if case (EN_REAL_FUN_BINARY) call eval_node_evaluate (en%arg1) call eval_node_evaluate (en%arg2) en%value_is_known = & en%arg1%value_is_known .and. & en%arg2%value_is_known if (en%value_is_known) then if (associated (en%arg0)) then en%arg0%index => en%index en%arg0%prt1 => en%prt1 en%arg0%prt2 => en%prt2 call en%op2_evr (en%rval, en%arg1, en%arg2, en%arg0) else call en%op2_evr (en%rval, en%arg1, en%arg2) end if end if case (EN_FORMAT_STR) if (associated (en%arg0)) then call eval_node_evaluate (en%arg0) en%value_is_known = en%arg0%value_is_known else en%value_is_known = .true. end if if (associated (en%arg1)) then call eval_node_evaluate (en%arg1) en%value_is_known = & en%value_is_known .and. en%arg1%value_is_known if (en%value_is_known) then call evaluate_sprintf (en%sval, en%ival, en%arg0, en%arg1) end if else if (en%value_is_known) then call evaluate_sprintf (en%sval, en%ival, en%arg0) end if end if end select if (debug2_active (D_MODEL_F)) then print *, "eval_node_evaluate" call eval_node_write (en) end if end subroutine eval_node_evaluate @ %def eval_node_evaluate @ \subsubsection{Test method} This is called from a unit test: initialize a particular observable. <>= procedure :: test_obs => eval_node_test_obs <>= subroutine eval_node_test_obs (node, var_list, var_name) class(eval_node_t), intent(inout) :: node type(var_list_t), intent(in) :: var_list type(string_t), intent(in) :: var_name procedure(obs_unary_int), pointer :: obs1_iptr type(prt_t), pointer :: p1 call var_list%get_obs1_iptr (var_name, obs1_iptr, p1) call eval_node_init_obs1_int_ptr (node, var_name, obs1_iptr, p1) end subroutine eval_node_test_obs @ %def eval_node_test_obs @ \subsection{Evaluation syntax} We have two different flavors of the syntax: with and without particles. <>= public :: syntax_expr public :: syntax_pexpr <>= type(syntax_t), target, save :: syntax_expr type(syntax_t), target, save :: syntax_pexpr @ %def syntax_expr syntax_pexpr @ These are for testing only and may be removed: <>= public :: syntax_expr_init public :: syntax_pexpr_init <>= subroutine syntax_expr_init () type(ifile_t) :: ifile call define_expr_syntax (ifile, particles=.false., analysis=.false.) call syntax_init (syntax_expr, ifile) call ifile_final (ifile) end subroutine syntax_expr_init subroutine syntax_pexpr_init () type(ifile_t) :: ifile call define_expr_syntax (ifile, particles=.true., analysis=.false.) call syntax_init (syntax_pexpr, ifile) call ifile_final (ifile) end subroutine syntax_pexpr_init @ %def syntax_expr_init syntax_pexpr_init <>= public :: syntax_expr_final public :: syntax_pexpr_final <>= subroutine syntax_expr_final () call syntax_final (syntax_expr) end subroutine syntax_expr_final subroutine syntax_pexpr_final () call syntax_final (syntax_pexpr) end subroutine syntax_pexpr_final @ %def syntax_expr_final syntax_pexpr_final <>= public :: syntax_pexpr_write <>= subroutine syntax_pexpr_write (unit) integer, intent(in), optional :: unit call syntax_write (syntax_pexpr, unit) end subroutine syntax_pexpr_write @ %def syntax_pexpr_write <>= public :: define_expr_syntax @ Numeric expressions. <>= subroutine define_expr_syntax (ifile, particles, analysis) type(ifile_t), intent(inout) :: ifile logical, intent(in) :: particles, analysis type(string_t) :: numeric_pexpr type(string_t) :: var_plist, var_alias if (particles) then numeric_pexpr = " | numeric_pexpr" var_plist = " | var_plist" var_alias = " | var_alias" else numeric_pexpr = "" var_plist = "" var_alias = "" end if call ifile_append (ifile, "SEQ expr = subexpr addition*") call ifile_append (ifile, "ALT subexpr = addition | term") call ifile_append (ifile, "SEQ addition = plus_or_minus term") call ifile_append (ifile, "SEQ term = factor multiplication*") call ifile_append (ifile, "SEQ multiplication = times_or_over factor") call ifile_append (ifile, "SEQ factor = value exponentiation?") call ifile_append (ifile, "SEQ exponentiation = to_the value") call ifile_append (ifile, "ALT plus_or_minus = '+' | '-'") call ifile_append (ifile, "ALT times_or_over = '*' | '/'") call ifile_append (ifile, "ALT to_the = '^' | '**'") call ifile_append (ifile, "KEY '+'") call ifile_append (ifile, "KEY '-'") call ifile_append (ifile, "KEY '*'") call ifile_append (ifile, "KEY '/'") call ifile_append (ifile, "KEY '^'") call ifile_append (ifile, "KEY '**'") call ifile_append (ifile, "ALT value = signed_value | unsigned_value") call ifile_append (ifile, "SEQ signed_value = '-' unsigned_value") call ifile_append (ifile, "ALT unsigned_value = " // & "numeric_value | constant | variable | " // & "result | user_observable | " // & "grouped_expr | block_expr | conditional_expr | " // & "unary_function | binary_function" // & numeric_pexpr) call ifile_append (ifile, "ALT numeric_value = integer_value | " & // "real_value | complex_value") call ifile_append (ifile, "SEQ integer_value = integer_literal unit_expr?") call ifile_append (ifile, "SEQ real_value = real_literal unit_expr?") call ifile_append (ifile, "SEQ complex_value = complex_literal unit_expr?") call ifile_append (ifile, "INT integer_literal") call ifile_append (ifile, "REA real_literal") call ifile_append (ifile, "COM complex_literal") call ifile_append (ifile, "SEQ unit_expr = unit unit_power?") call ifile_append (ifile, "ALT unit = " // & "TeV | GeV | MeV | keV | eV | meV | " // & "nbarn | pbarn | fbarn | abarn | " // & "rad | mrad | degree | '%'") call ifile_append (ifile, "KEY TeV") call ifile_append (ifile, "KEY GeV") call ifile_append (ifile, "KEY MeV") call ifile_append (ifile, "KEY keV") call ifile_append (ifile, "KEY eV") call ifile_append (ifile, "KEY meV") call ifile_append (ifile, "KEY nbarn") call ifile_append (ifile, "KEY pbarn") call ifile_append (ifile, "KEY fbarn") call ifile_append (ifile, "KEY abarn") call ifile_append (ifile, "KEY rad") call ifile_append (ifile, "KEY mrad") call ifile_append (ifile, "KEY degree") call ifile_append (ifile, "KEY '%'") call ifile_append (ifile, "SEQ unit_power = '^' frac_expr") call ifile_append (ifile, "ALT frac_expr = frac | grouped_frac") call ifile_append (ifile, "GRO grouped_frac = ( frac_expr )") call ifile_append (ifile, "SEQ frac = signed_int div?") call ifile_append (ifile, "ALT signed_int = " & // "neg_int | pos_int | integer_literal") call ifile_append (ifile, "SEQ neg_int = '-' integer_literal") call ifile_append (ifile, "SEQ pos_int = '+' integer_literal") call ifile_append (ifile, "SEQ div = '/' integer_literal") call ifile_append (ifile, "ALT constant = pi | I") call ifile_append (ifile, "KEY pi") call ifile_append (ifile, "KEY I") call ifile_append (ifile, "IDE variable") call ifile_append (ifile, "SEQ result = result_key result_arg") call ifile_append (ifile, "ALT result_key = " // & "num_id | integral | error") call ifile_append (ifile, "SEQ user_observable = user_obs user_arg") call ifile_append (ifile, "KEY user_obs") call ifile_append (ifile, "ARG user_arg = ( sexpr )") call ifile_append (ifile, "KEY num_id") call ifile_append (ifile, "KEY integral") call ifile_append (ifile, "KEY error") call ifile_append (ifile, "GRO result_arg = ( process_id )") call ifile_append (ifile, "IDE process_id") call ifile_append (ifile, "SEQ unary_function = fun_unary function_arg1") call ifile_append (ifile, "SEQ binary_function = fun_binary function_arg2") call ifile_append (ifile, "ALT fun_unary = " // & "complex | real | int | nint | floor | ceiling | abs | conjg | sgn | " // & "sqrt | exp | log | log10 | " // & "sin | cos | tan | asin | acos | atan | " // & "sinh | cosh | tanh") call ifile_append (ifile, "KEY complex") call ifile_append (ifile, "KEY real") call ifile_append (ifile, "KEY int") call ifile_append (ifile, "KEY nint") call ifile_append (ifile, "KEY floor") call ifile_append (ifile, "KEY ceiling") call ifile_append (ifile, "KEY abs") call ifile_append (ifile, "KEY conjg") call ifile_append (ifile, "KEY sgn") call ifile_append (ifile, "KEY sqrt") call ifile_append (ifile, "KEY exp") call ifile_append (ifile, "KEY log") call ifile_append (ifile, "KEY log10") call ifile_append (ifile, "KEY sin") call ifile_append (ifile, "KEY cos") call ifile_append (ifile, "KEY tan") call ifile_append (ifile, "KEY asin") call ifile_append (ifile, "KEY acos") call ifile_append (ifile, "KEY atan") call ifile_append (ifile, "KEY sinh") call ifile_append (ifile, "KEY cosh") call ifile_append (ifile, "KEY tanh") call ifile_append (ifile, "ALT fun_binary = max | min | mod | modulo") call ifile_append (ifile, "KEY max") call ifile_append (ifile, "KEY min") call ifile_append (ifile, "KEY mod") call ifile_append (ifile, "KEY modulo") call ifile_append (ifile, "ARG function_arg1 = ( expr )") call ifile_append (ifile, "ARG function_arg2 = ( expr, expr )") call ifile_append (ifile, "GRO grouped_expr = ( expr )") call ifile_append (ifile, "SEQ block_expr = let var_spec in expr") call ifile_append (ifile, "KEY let") call ifile_append (ifile, "ALT var_spec = " // & "var_num | var_int | var_real | var_complex | " // & "var_logical" // var_plist // var_alias // " | var_string") call ifile_append (ifile, "SEQ var_num = var_name '=' expr") call ifile_append (ifile, "SEQ var_int = int var_name '=' expr") call ifile_append (ifile, "SEQ var_real = real var_name '=' expr") call ifile_append (ifile, "SEQ var_complex = complex var_name '=' complex_expr") call ifile_append (ifile, "ALT complex_expr = " // & "cexpr_real | cexpr_complex") call ifile_append (ifile, "ARG cexpr_complex = ( expr, expr )") call ifile_append (ifile, "SEQ cexpr_real = expr") call ifile_append (ifile, "IDE var_name") call ifile_append (ifile, "KEY '='") call ifile_append (ifile, "KEY in") call ifile_append (ifile, "SEQ conditional_expr = " // & "if lexpr then expr maybe_elsif_expr maybe_else_expr endif") call ifile_append (ifile, "SEQ maybe_elsif_expr = elsif_expr*") call ifile_append (ifile, "SEQ maybe_else_expr = else_expr?") call ifile_append (ifile, "SEQ elsif_expr = elsif lexpr then expr") call ifile_append (ifile, "SEQ else_expr = else expr") call ifile_append (ifile, "KEY if") call ifile_append (ifile, "KEY then") call ifile_append (ifile, "KEY elsif") call ifile_append (ifile, "KEY else") call ifile_append (ifile, "KEY endif") call define_lexpr_syntax (ifile, particles, analysis) call define_sexpr_syntax (ifile) if (particles) then call define_pexpr_syntax (ifile) call define_cexpr_syntax (ifile) call define_var_plist_syntax (ifile) call define_var_alias_syntax (ifile) call define_numeric_pexpr_syntax (ifile) call define_logical_pexpr_syntax (ifile) end if end subroutine define_expr_syntax @ %def define_expr_syntax @ Logical expressions. <>= subroutine define_lexpr_syntax (ifile, particles, analysis) type(ifile_t), intent(inout) :: ifile logical, intent(in) :: particles, analysis type(string_t) :: logical_pexpr, record_cmd if (particles) then logical_pexpr = " | logical_pexpr" else logical_pexpr = "" end if if (analysis) then record_cmd = " | record_cmd" else record_cmd = "" end if call ifile_append (ifile, "SEQ lexpr = lsinglet lsequel*") call ifile_append (ifile, "SEQ lsequel = ';' lsinglet") call ifile_append (ifile, "SEQ lsinglet = lterm alternative*") call ifile_append (ifile, "SEQ alternative = or lterm") call ifile_append (ifile, "SEQ lterm = lvalue coincidence*") call ifile_append (ifile, "SEQ coincidence = and lvalue") call ifile_append (ifile, "KEY ';'") call ifile_append (ifile, "KEY or") call ifile_append (ifile, "KEY and") call ifile_append (ifile, "ALT lvalue = " // & "true | false | lvariable | negation | " // & "grouped_lexpr | block_lexpr | conditional_lexpr | " // & "compared_expr | compared_sexpr" // & logical_pexpr // record_cmd) call ifile_append (ifile, "KEY true") call ifile_append (ifile, "KEY false") call ifile_append (ifile, "SEQ lvariable = '?' alt_lvariable") call ifile_append (ifile, "KEY '?'") call ifile_append (ifile, "ALT alt_lvariable = variable | grouped_lexpr") call ifile_append (ifile, "SEQ negation = not lvalue") call ifile_append (ifile, "KEY not") call ifile_append (ifile, "GRO grouped_lexpr = ( lexpr )") call ifile_append (ifile, "SEQ block_lexpr = let var_spec in lexpr") call ifile_append (ifile, "ALT var_logical = " // & "var_logical_new | var_logical_spec") call ifile_append (ifile, "SEQ var_logical_new = logical var_logical_spec") call ifile_append (ifile, "KEY logical") call ifile_append (ifile, "SEQ var_logical_spec = '?' var_name = lexpr") call ifile_append (ifile, "SEQ conditional_lexpr = " // & "if lexpr then lexpr maybe_elsif_lexpr maybe_else_lexpr endif") call ifile_append (ifile, "SEQ maybe_elsif_lexpr = elsif_lexpr*") call ifile_append (ifile, "SEQ maybe_else_lexpr = else_lexpr?") call ifile_append (ifile, "SEQ elsif_lexpr = elsif lexpr then lexpr") call ifile_append (ifile, "SEQ else_lexpr = else lexpr") call ifile_append (ifile, "SEQ compared_expr = expr comparison+") call ifile_append (ifile, "SEQ comparison = compare expr") call ifile_append (ifile, "ALT compare = " // & "'<' | '>' | '<=' | '>=' | '==' | '<>'") call ifile_append (ifile, "KEY '<'") call ifile_append (ifile, "KEY '>'") call ifile_append (ifile, "KEY '<='") call ifile_append (ifile, "KEY '>='") call ifile_append (ifile, "KEY '=='") call ifile_append (ifile, "KEY '<>'") call ifile_append (ifile, "SEQ compared_sexpr = sexpr str_comparison+") call ifile_append (ifile, "SEQ str_comparison = str_compare sexpr") call ifile_append (ifile, "ALT str_compare = '==' | '<>'") if (analysis) then call ifile_append (ifile, "SEQ record_cmd = " // & "record_key analysis_tag record_arg?") call ifile_append (ifile, "ALT record_key = " // & "record | record_unweighted | record_excess") call ifile_append (ifile, "KEY record") call ifile_append (ifile, "KEY record_unweighted") call ifile_append (ifile, "KEY record_excess") call ifile_append (ifile, "ALT analysis_tag = analysis_id | sexpr") call ifile_append (ifile, "IDE analysis_id") call ifile_append (ifile, "ARG record_arg = ( expr+ )") end if end subroutine define_lexpr_syntax @ %def define_lexpr_syntax @ String expressions. <>= subroutine define_sexpr_syntax (ifile) type(ifile_t), intent(inout) :: ifile call ifile_append (ifile, "SEQ sexpr = svalue str_concatenation*") call ifile_append (ifile, "SEQ str_concatenation = '&' svalue") call ifile_append (ifile, "KEY '&'") call ifile_append (ifile, "ALT svalue = " // & "grouped_sexpr | block_sexpr | conditional_sexpr | " // & "svariable | string_function | string_literal") call ifile_append (ifile, "GRO grouped_sexpr = ( sexpr )") call ifile_append (ifile, "SEQ block_sexpr = let var_spec in sexpr") call ifile_append (ifile, "SEQ conditional_sexpr = " // & "if lexpr then sexpr maybe_elsif_sexpr maybe_else_sexpr endif") call ifile_append (ifile, "SEQ maybe_elsif_sexpr = elsif_sexpr*") call ifile_append (ifile, "SEQ maybe_else_sexpr = else_sexpr?") call ifile_append (ifile, "SEQ elsif_sexpr = elsif lexpr then sexpr") call ifile_append (ifile, "SEQ else_sexpr = else sexpr") call ifile_append (ifile, "SEQ svariable = '$' alt_svariable") call ifile_append (ifile, "KEY '$'") call ifile_append (ifile, "ALT alt_svariable = variable | grouped_sexpr") call ifile_append (ifile, "ALT var_string = " // & "var_string_new | var_string_spec") call ifile_append (ifile, "SEQ var_string_new = string var_string_spec") call ifile_append (ifile, "KEY string") call ifile_append (ifile, "SEQ var_string_spec = '$' var_name = sexpr") ! $ call ifile_append (ifile, "ALT string_function = sprintf_fun") call ifile_append (ifile, "SEQ sprintf_fun = sprintf_clause sprintf_args?") call ifile_append (ifile, "SEQ sprintf_clause = sprintf sexpr") call ifile_append (ifile, "KEY sprintf") call ifile_append (ifile, "ARG sprintf_args = ( sprintf_arg* )") call ifile_append (ifile, "ALT sprintf_arg = " & // "lvariable | svariable | expr") call ifile_append (ifile, "QUO string_literal = '""'...'""'") end subroutine define_sexpr_syntax @ %def define_sexpr_syntax @ Eval trees that evaluate to subevents. <>= subroutine define_pexpr_syntax (ifile) type(ifile_t), intent(inout) :: ifile call ifile_append (ifile, "SEQ pexpr = pterm pconcatenation*") call ifile_append (ifile, "SEQ pconcatenation = '&' pterm") ! call ifile_append (ifile, "KEY '&'") !!! (Key exists already) call ifile_append (ifile, "SEQ pterm = pvalue pcombination*") call ifile_append (ifile, "SEQ pcombination = '+' pvalue") ! call ifile_append (ifile, "KEY '+'") !!! (Key exists already) call ifile_append (ifile, "ALT pvalue = " // & "pexpr_src | pvariable | " // & "grouped_pexpr | block_pexpr | conditional_pexpr | " // & "prt_function") call ifile_append (ifile, "SEQ pexpr_src = prefix_cexpr") call ifile_append (ifile, "ALT prefix_cexpr = " // & "beam_prt | incoming_prt | outgoing_prt | unspecified_prt") call ifile_append (ifile, "SEQ beam_prt = beam cexpr") call ifile_append (ifile, "KEY beam") call ifile_append (ifile, "SEQ incoming_prt = incoming cexpr") call ifile_append (ifile, "KEY incoming") call ifile_append (ifile, "SEQ outgoing_prt = outgoing cexpr") call ifile_append (ifile, "KEY outgoing") call ifile_append (ifile, "SEQ unspecified_prt = cexpr") call ifile_append (ifile, "SEQ pvariable = '@' alt_pvariable") call ifile_append (ifile, "KEY '@'") call ifile_append (ifile, "ALT alt_pvariable = variable | grouped_pexpr") call ifile_append (ifile, "GRO grouped_pexpr = '[' pexpr ']'") call ifile_append (ifile, "SEQ block_pexpr = let var_spec in pexpr") call ifile_append (ifile, "SEQ conditional_pexpr = " // & "if lexpr then pexpr maybe_elsif_pexpr maybe_else_pexpr endif") call ifile_append (ifile, "SEQ maybe_elsif_pexpr = elsif_pexpr*") call ifile_append (ifile, "SEQ maybe_else_pexpr = else_pexpr?") call ifile_append (ifile, "SEQ elsif_pexpr = elsif lexpr then pexpr") call ifile_append (ifile, "SEQ else_pexpr = else pexpr") call ifile_append (ifile, "ALT prt_function = " // & "join_fun | combine_fun | collect_fun | cluster_fun | " // & "select_fun | extract_fun | sort_fun") call ifile_append (ifile, "SEQ join_fun = join_clause pargs2") call ifile_append (ifile, "SEQ combine_fun = combine_clause pargs2") call ifile_append (ifile, "SEQ collect_fun = collect_clause pargs1") call ifile_append (ifile, "SEQ cluster_fun = cluster_clause pargs1") call ifile_append (ifile, "SEQ select_fun = select_clause pargs1") call ifile_append (ifile, "SEQ extract_fun = extract_clause pargs1") call ifile_append (ifile, "SEQ sort_fun = sort_clause pargs1") call ifile_append (ifile, "SEQ join_clause = join condition?") call ifile_append (ifile, "SEQ combine_clause = combine condition?") call ifile_append (ifile, "SEQ collect_clause = collect condition?") call ifile_append (ifile, "SEQ cluster_clause = cluster condition?") call ifile_append (ifile, "SEQ select_clause = select condition?") call ifile_append (ifile, "SEQ extract_clause = extract position?") call ifile_append (ifile, "SEQ sort_clause = sort criterion?") call ifile_append (ifile, "KEY join") call ifile_append (ifile, "KEY combine") call ifile_append (ifile, "KEY collect") call ifile_append (ifile, "KEY cluster") call ifile_append (ifile, "KEY select") call ifile_append (ifile, "SEQ condition = if lexpr") call ifile_append (ifile, "KEY extract") call ifile_append (ifile, "SEQ position = index expr") call ifile_append (ifile, "KEY sort") call ifile_append (ifile, "SEQ criterion = by expr") call ifile_append (ifile, "KEY index") call ifile_append (ifile, "KEY by") call ifile_append (ifile, "ARG pargs2 = '[' pexpr, pexpr ']'") call ifile_append (ifile, "ARG pargs1 = '[' pexpr, pexpr? ']'") end subroutine define_pexpr_syntax @ %def define_pexpr_syntax @ Eval trees that evaluate to PDG-code arrays. <>= subroutine define_cexpr_syntax (ifile) type(ifile_t), intent(inout) :: ifile call ifile_append (ifile, "SEQ cexpr = avalue concatenation*") call ifile_append (ifile, "SEQ concatenation = ':' avalue") call ifile_append (ifile, "KEY ':'") call ifile_append (ifile, "ALT avalue = " // & "grouped_cexpr | block_cexpr | conditional_cexpr | " // & "variable | pdg_code | prt_name") call ifile_append (ifile, "GRO grouped_cexpr = ( cexpr )") call ifile_append (ifile, "SEQ block_cexpr = let var_spec in cexpr") call ifile_append (ifile, "SEQ conditional_cexpr = " // & "if lexpr then cexpr maybe_elsif_cexpr maybe_else_cexpr endif") call ifile_append (ifile, "SEQ maybe_elsif_cexpr = elsif_cexpr*") call ifile_append (ifile, "SEQ maybe_else_cexpr = else_cexpr?") call ifile_append (ifile, "SEQ elsif_cexpr = elsif lexpr then cexpr") call ifile_append (ifile, "SEQ else_cexpr = else cexpr") call ifile_append (ifile, "SEQ pdg_code = pdg pdg_arg") call ifile_append (ifile, "KEY pdg") call ifile_append (ifile, "ARG pdg_arg = ( expr )") call ifile_append (ifile, "QUO prt_name = '""'...'""'") end subroutine define_cexpr_syntax @ %def define_cexpr_syntax @ Extra variable types. <>= subroutine define_var_plist_syntax (ifile) type(ifile_t), intent(inout) :: ifile call ifile_append (ifile, "ALT var_plist = var_plist_new | var_plist_spec") call ifile_append (ifile, "SEQ var_plist_new = subevt var_plist_spec") call ifile_append (ifile, "KEY subevt") call ifile_append (ifile, "SEQ var_plist_spec = '@' var_name '=' pexpr") end subroutine define_var_plist_syntax subroutine define_var_alias_syntax (ifile) type(ifile_t), intent(inout) :: ifile call ifile_append (ifile, "SEQ var_alias = alias var_name '=' cexpr") call ifile_append (ifile, "KEY alias") end subroutine define_var_alias_syntax @ %def define_var_plist_syntax define_var_alias_syntax @ Particle-list expressions that evaluate to numeric values <>= subroutine define_numeric_pexpr_syntax (ifile) type(ifile_t), intent(inout) :: ifile call ifile_append (ifile, "ALT numeric_pexpr = " & // "eval_fun | count_fun | event_shape_fun") call ifile_append (ifile, "SEQ eval_fun = eval expr pargs1") call ifile_append (ifile, "SEQ count_fun = count_clause pargs1") call ifile_append (ifile, "SEQ count_clause = count condition?") call ifile_append (ifile, "KEY eval") call ifile_append (ifile, "KEY count") call ifile_append (ifile, "ALT event_shape_fun = user_event_fun") call ifile_append (ifile, "SEQ user_event_fun = " & // "user_event_shape user_arg pargs1") call ifile_append (ifile, "KEY user_event_shape") end subroutine define_numeric_pexpr_syntax @ %def define_numeric_pexpr_syntax @ Particle-list functions that evaluate to logical values. <>= subroutine define_logical_pexpr_syntax (ifile) type(ifile_t), intent(inout) :: ifile call ifile_append (ifile, "ALT logical_pexpr = " // & "all_fun | any_fun | no_fun | user_cut_fun") call ifile_append (ifile, "SEQ all_fun = all lexpr pargs1") call ifile_append (ifile, "SEQ any_fun = any lexpr pargs1") call ifile_append (ifile, "SEQ no_fun = no lexpr pargs1") call ifile_append (ifile, "KEY all") call ifile_append (ifile, "KEY any") call ifile_append (ifile, "KEY no") call ifile_append (ifile, "SEQ user_cut_fun = user_cut user_arg pargs1") call ifile_append (ifile, "KEY user_cut") end subroutine define_logical_pexpr_syntax @ %def define_logical_pexpr_syntax @ All characters that can occur in expressions (apart from alphanumeric). <>= subroutine lexer_init_eval_tree (lexer, particles) type(lexer_t), intent(out) :: lexer logical, intent(in) :: particles type(keyword_list_t), pointer :: keyword_list if (particles) then keyword_list => syntax_get_keyword_list_ptr (syntax_pexpr) else keyword_list => syntax_get_keyword_list_ptr (syntax_expr) end if call lexer_init (lexer, & comment_chars = "#!", & quote_chars = '"', & quote_match = '"', & single_chars = "()[],;:&%?$@", & special_class = [ "+-*/^", "<>=~ " ] , & keyword_list = keyword_list) end subroutine lexer_init_eval_tree @ %def lexer_init_eval_tree @ \subsection{Set up appropriate parse trees} Parse an input stream as a specific flavor of expression. The appropriate expression syntax has to be available. <>= public :: parse_tree_init_expr public :: parse_tree_init_lexpr public :: parse_tree_init_pexpr public :: parse_tree_init_cexpr public :: parse_tree_init_sexpr <>= subroutine parse_tree_init_expr (parse_tree, stream, particles) type(parse_tree_t), intent(out) :: parse_tree type(stream_t), intent(inout), target :: stream logical, intent(in) :: particles type(lexer_t) :: lexer call lexer_init_eval_tree (lexer, particles) call lexer_assign_stream (lexer, stream) if (particles) then call parse_tree_init & (parse_tree, syntax_pexpr, lexer, var_str ("expr")) else call parse_tree_init & (parse_tree, syntax_expr, lexer, var_str ("expr")) end if call lexer_final (lexer) end subroutine parse_tree_init_expr subroutine parse_tree_init_lexpr (parse_tree, stream, particles) type(parse_tree_t), intent(out) :: parse_tree type(stream_t), intent(inout), target :: stream logical, intent(in) :: particles type(lexer_t) :: lexer call lexer_init_eval_tree (lexer, particles) call lexer_assign_stream (lexer, stream) if (particles) then call parse_tree_init & (parse_tree, syntax_pexpr, lexer, var_str ("lexpr")) else call parse_tree_init & (parse_tree, syntax_expr, lexer, var_str ("lexpr")) end if call lexer_final (lexer) end subroutine parse_tree_init_lexpr subroutine parse_tree_init_pexpr (parse_tree, stream) type(parse_tree_t), intent(out) :: parse_tree type(stream_t), intent(inout), target :: stream type(lexer_t) :: lexer call lexer_init_eval_tree (lexer, .true.) call lexer_assign_stream (lexer, stream) call parse_tree_init & (parse_tree, syntax_pexpr, lexer, var_str ("pexpr")) call lexer_final (lexer) end subroutine parse_tree_init_pexpr subroutine parse_tree_init_cexpr (parse_tree, stream) type(parse_tree_t), intent(out) :: parse_tree type(stream_t), intent(inout), target :: stream type(lexer_t) :: lexer call lexer_init_eval_tree (lexer, .true.) call lexer_assign_stream (lexer, stream) call parse_tree_init & (parse_tree, syntax_pexpr, lexer, var_str ("cexpr")) call lexer_final (lexer) end subroutine parse_tree_init_cexpr subroutine parse_tree_init_sexpr (parse_tree, stream, particles) type(parse_tree_t), intent(out) :: parse_tree type(stream_t), intent(inout), target :: stream logical, intent(in) :: particles type(lexer_t) :: lexer call lexer_init_eval_tree (lexer, particles) call lexer_assign_stream (lexer, stream) if (particles) then call parse_tree_init & (parse_tree, syntax_pexpr, lexer, var_str ("sexpr")) else call parse_tree_init & (parse_tree, syntax_expr, lexer, var_str ("sexpr")) end if call lexer_final (lexer) end subroutine parse_tree_init_sexpr @ %def parse_tree_init_expr @ %def parse_tree_init_lexpr @ %def parse_tree_init_pexpr @ %def parse_tree_init_cexpr @ %def parse_tree_init_sexpr @ \subsection{The evaluation tree} The evaluation tree contains the initial variable list and the root node. <>= public :: eval_tree_t <>= type, extends (expr_t) :: eval_tree_t private type(parse_node_t), pointer :: pn => null () type(var_list_t) :: var_list type(eval_node_t), pointer :: root => null () contains <> end type eval_tree_t @ %def eval_tree_t @ Init from stream, using a temporary parse tree. <>= procedure :: init_stream => eval_tree_init_stream <>= subroutine eval_tree_init_stream & (eval_tree, stream, var_list, subevt, result_type) class(eval_tree_t), intent(out), target :: eval_tree type(stream_t), intent(inout), target :: stream type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), target, optional :: subevt integer, intent(in), optional :: result_type type(parse_tree_t) :: parse_tree type(parse_node_t), pointer :: nd_root integer :: type type = V_REAL; if (present (result_type)) type = result_type select case (type) case (V_INT, V_REAL, V_CMPLX) call parse_tree_init_expr (parse_tree, stream, present (subevt)) case (V_LOG) call parse_tree_init_lexpr (parse_tree, stream, present (subevt)) case (V_SEV) call parse_tree_init_pexpr (parse_tree, stream) case (V_PDG) call parse_tree_init_cexpr (parse_tree, stream) case (V_STR) call parse_tree_init_sexpr (parse_tree, stream, present (subevt)) end select nd_root => parse_tree%get_root_ptr () if (associated (nd_root)) then select case (type) case (V_INT, V_REAL, V_CMPLX) call eval_tree_init_expr (eval_tree, nd_root, var_list, subevt) case (V_LOG) call eval_tree_init_lexpr (eval_tree, nd_root, var_list, subevt) case (V_SEV) call eval_tree_init_pexpr (eval_tree, nd_root, var_list, subevt) case (V_PDG) call eval_tree_init_cexpr (eval_tree, nd_root, var_list, subevt) case (V_STR) call eval_tree_init_sexpr (eval_tree, nd_root, var_list, subevt) end select end if call parse_tree_final (parse_tree) end subroutine eval_tree_init_stream @ %def eval_tree_init_stream @ API (to be superseded by the methods below): Init from a given parse-tree node. If we evaluate an expression that contains particle-list references, the original subevent has to be supplied. The initial variable list is optional. <>= procedure :: init_expr => eval_tree_init_expr procedure :: init_lexpr => eval_tree_init_lexpr procedure :: init_pexpr => eval_tree_init_pexpr procedure :: init_cexpr => eval_tree_init_cexpr procedure :: init_sexpr => eval_tree_init_sexpr <>= subroutine eval_tree_init_expr & (expr, parse_node, var_list, subevt) class(eval_tree_t), intent(out), target :: expr type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt call eval_tree_link_var_list (expr, var_list) if (present (subevt)) call eval_tree_set_subevt (expr, subevt) call eval_node_compile_expr & (expr%root, parse_node, expr%var_list) end subroutine eval_tree_init_expr subroutine eval_tree_init_lexpr & (expr, parse_node, var_list, subevt) class(eval_tree_t), intent(out), target :: expr type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt call eval_tree_link_var_list (expr, var_list) if (present (subevt)) call eval_tree_set_subevt (expr, subevt) call eval_node_compile_lexpr & (expr%root, parse_node, expr%var_list) end subroutine eval_tree_init_lexpr subroutine eval_tree_init_pexpr & (expr, parse_node, var_list, subevt) class(eval_tree_t), intent(out), target :: expr type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt call eval_tree_link_var_list (expr, var_list) if (present (subevt)) call eval_tree_set_subevt (expr, subevt) call eval_node_compile_pexpr & (expr%root, parse_node, expr%var_list) end subroutine eval_tree_init_pexpr subroutine eval_tree_init_cexpr & (expr, parse_node, var_list, subevt) class(eval_tree_t), intent(out), target :: expr type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt call eval_tree_link_var_list (expr, var_list) if (present (subevt)) call eval_tree_set_subevt (expr, subevt) call eval_node_compile_cexpr & (expr%root, parse_node, expr%var_list) end subroutine eval_tree_init_cexpr subroutine eval_tree_init_sexpr & (expr, parse_node, var_list, subevt) class(eval_tree_t), intent(out), target :: expr type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt call eval_tree_link_var_list (expr, var_list) if (present (subevt)) call eval_tree_set_subevt (expr, subevt) call eval_node_compile_sexpr & (expr%root, parse_node, expr%var_list) end subroutine eval_tree_init_sexpr @ %def eval_tree_init_expr @ %def eval_tree_init_lexpr @ %def eval_tree_init_pexpr @ %def eval_tree_init_cexpr @ %def eval_tree_init_sexpr @ Alternative: set up the expression using the parse node that has already been stored. We assume that the [[subevt]] or any other variable that may be referred to has already been added to the local variable list. <>= procedure :: setup_expr => eval_tree_setup_expr procedure :: setup_lexpr => eval_tree_setup_lexpr procedure :: setup_pexpr => eval_tree_setup_pexpr procedure :: setup_cexpr => eval_tree_setup_cexpr procedure :: setup_sexpr => eval_tree_setup_sexpr <>= subroutine eval_tree_setup_expr (expr, vars) class(eval_tree_t), intent(inout), target :: expr class(vars_t), intent(in), target :: vars call eval_tree_link_var_list (expr, vars) call eval_node_compile_expr (expr%root, expr%pn, expr%var_list) end subroutine eval_tree_setup_expr subroutine eval_tree_setup_lexpr (expr, vars) class(eval_tree_t), intent(inout), target :: expr class(vars_t), intent(in), target :: vars call eval_tree_link_var_list (expr, vars) call eval_node_compile_lexpr (expr%root, expr%pn, expr%var_list) end subroutine eval_tree_setup_lexpr subroutine eval_tree_setup_pexpr (expr, vars) class(eval_tree_t), intent(inout), target :: expr class(vars_t), intent(in), target :: vars call eval_tree_link_var_list (expr, vars) call eval_node_compile_pexpr (expr%root, expr%pn, expr%var_list) end subroutine eval_tree_setup_pexpr subroutine eval_tree_setup_cexpr (expr, vars) class(eval_tree_t), intent(inout), target :: expr class(vars_t), intent(in), target :: vars call eval_tree_link_var_list (expr, vars) call eval_node_compile_cexpr (expr%root, expr%pn, expr%var_list) end subroutine eval_tree_setup_cexpr subroutine eval_tree_setup_sexpr (expr, vars) class(eval_tree_t), intent(inout), target :: expr class(vars_t), intent(in), target :: vars call eval_tree_link_var_list (expr, vars) call eval_node_compile_sexpr (expr%root, expr%pn, expr%var_list) end subroutine eval_tree_setup_sexpr @ %def eval_tree_setup_expr @ %def eval_tree_setup_lexpr @ %def eval_tree_setup_pexpr @ %def eval_tree_setup_cexpr @ %def eval_tree_setup_sexpr @ This extra API function handles numerical constant expressions only. The only nontrivial part is the optional unit. <>= procedure :: init_numeric_value => eval_tree_init_numeric_value <>= subroutine eval_tree_init_numeric_value (eval_tree, parse_node) class(eval_tree_t), intent(out), target :: eval_tree type(parse_node_t), intent(in), target :: parse_node call eval_node_compile_numeric_value (eval_tree%root, parse_node) end subroutine eval_tree_init_numeric_value @ %def eval_tree_init_numeric_value @ Initialize the variable list, linking it to a context variable list. <>= subroutine eval_tree_link_var_list (eval_tree, vars) type(eval_tree_t), intent(inout), target :: eval_tree class(vars_t), intent(in), target :: vars call eval_tree%var_list%link (vars) end subroutine eval_tree_link_var_list @ %def eval_tree_link_var_list @ Include a subevent object in the initialization. We add a pointer to this as variable [[@evt]] in the local variable list. <>= subroutine eval_tree_set_subevt (eval_tree, subevt) type(eval_tree_t), intent(inout), target :: eval_tree type(subevt_t), intent(in), target :: subevt logical, save, target :: known = .true. call var_list_append_subevt_ptr & (eval_tree%var_list, var_str ("@evt"), subevt, known, & intrinsic=.true.) end subroutine eval_tree_set_subevt @ %def eval_tree_set_subevt @ Finalizer. <>= procedure :: final => eval_tree_final <>= subroutine eval_tree_final (expr) class(eval_tree_t), intent(inout) :: expr call expr%var_list%final () if (associated (expr%root)) then call eval_node_final_rec (expr%root) deallocate (expr%root) end if end subroutine eval_tree_final @ %def eval_tree_final @ <>= procedure :: evaluate => eval_tree_evaluate <>= subroutine eval_tree_evaluate (expr) class(eval_tree_t), intent(inout) :: expr if (associated (expr%root)) then call eval_node_evaluate (expr%root) end if end subroutine eval_tree_evaluate @ %def eval_tree_evaluate @ Check if the eval tree is allocated. <>= function eval_tree_is_defined (eval_tree) result (flag) logical :: flag type(eval_tree_t), intent(in) :: eval_tree flag = associated (eval_tree%root) end function eval_tree_is_defined @ %def eval_tree_is_defined @ Check if the eval tree result is constant. <>= function eval_tree_is_constant (eval_tree) result (flag) logical :: flag type(eval_tree_t), intent(in) :: eval_tree if (associated (eval_tree%root)) then flag = eval_tree%root%type == EN_CONSTANT else flag = .false. end if end function eval_tree_is_constant @ %def eval_tree_is_constant @ Insert a conversion node at the root, if necessary (only for real/int conversion) <>= subroutine eval_tree_convert_result (eval_tree, result_type) type(eval_tree_t), intent(inout) :: eval_tree integer, intent(in) :: result_type if (associated (eval_tree%root)) then call insert_conversion_node (eval_tree%root, result_type) end if end subroutine eval_tree_convert_result @ %def eval_tree_convert_result @ Return the value of the top node, after evaluation. If the tree is empty, return the type of [[V_NONE]]. When extracting the value, no check for existence is done. For numeric values, the functions are safe against real/integer mismatch. <>= procedure :: is_known => eval_tree_result_is_known procedure :: get_log => eval_tree_get_log procedure :: get_int => eval_tree_get_int procedure :: get_real => eval_tree_get_real procedure :: get_cmplx => eval_tree_get_cmplx procedure :: get_pdg_array => eval_tree_get_pdg_array procedure :: get_subevt => eval_tree_get_subevt procedure :: get_string => eval_tree_get_string <>= function eval_tree_get_result_type (expr) result (type) integer :: type class(eval_tree_t), intent(in) :: expr if (associated (expr%root)) then type = expr%root%result_type else type = V_NONE end if end function eval_tree_get_result_type function eval_tree_result_is_known (expr) result (flag) logical :: flag class(eval_tree_t), intent(in) :: expr if (associated (expr%root)) then select case (expr%root%result_type) case (V_LOG, V_INT, V_REAL) flag = expr%root%value_is_known case default flag = .true. end select else flag = .false. end if end function eval_tree_result_is_known function eval_tree_result_is_known_ptr (expr) result (ptr) logical, pointer :: ptr class(eval_tree_t), intent(in) :: expr logical, target, save :: known = .true. if (associated (expr%root)) then select case (expr%root%result_type) case (V_LOG, V_INT, V_REAL) ptr => expr%root%value_is_known case default ptr => known end select else ptr => null () end if end function eval_tree_result_is_known_ptr function eval_tree_get_log (expr) result (lval) logical :: lval class(eval_tree_t), intent(in) :: expr if (associated (expr%root)) lval = expr%root%lval end function eval_tree_get_log function eval_tree_get_int (expr) result (ival) integer :: ival class(eval_tree_t), intent(in) :: expr if (associated (expr%root)) then select case (expr%root%result_type) case (V_INT); ival = expr%root%ival case (V_REAL); ival = expr%root%rval case (V_CMPLX); ival = expr%root%cval end select end if end function eval_tree_get_int function eval_tree_get_real (expr) result (rval) real(default) :: rval class(eval_tree_t), intent(in) :: expr if (associated (expr%root)) then select case (expr%root%result_type) case (V_REAL); rval = expr%root%rval case (V_INT); rval = expr%root%ival case (V_CMPLX); rval = expr%root%cval end select end if end function eval_tree_get_real function eval_tree_get_cmplx (expr) result (cval) complex(default) :: cval class(eval_tree_t), intent(in) :: expr if (associated (expr%root)) then select case (expr%root%result_type) case (V_CMPLX); cval = expr%root%cval case (V_REAL); cval = expr%root%rval case (V_INT); cval = expr%root%ival end select end if end function eval_tree_get_cmplx function eval_tree_get_pdg_array (expr) result (aval) type(pdg_array_t) :: aval class(eval_tree_t), intent(in) :: expr if (associated (expr%root)) then aval = expr%root%aval end if end function eval_tree_get_pdg_array function eval_tree_get_subevt (expr) result (pval) type(subevt_t) :: pval class(eval_tree_t), intent(in) :: expr if (associated (expr%root)) then pval = expr%root%pval end if end function eval_tree_get_subevt function eval_tree_get_string (expr) result (sval) type(string_t) :: sval class(eval_tree_t), intent(in) :: expr if (associated (expr%root)) then sval = expr%root%sval end if end function eval_tree_get_string @ %def eval_tree_get_result_type @ %def eval_tree_result_is_known @ %def eval_tree_get_log eval_tree_get_int eval_tree_get_real @ %def eval_tree_get_cmplx @ %def eval_tree_get_pdg_expr @ %def eval_tree_get_pdg_array @ %def eval_tree_get_subevt @ %def eval_tree_get_string @ Return a pointer to the value of the top node. <>= function eval_tree_get_log_ptr (eval_tree) result (lval) logical, pointer :: lval type(eval_tree_t), intent(in) :: eval_tree if (associated (eval_tree%root)) then lval => eval_tree%root%lval else lval => null () end if end function eval_tree_get_log_ptr function eval_tree_get_int_ptr (eval_tree) result (ival) integer, pointer :: ival type(eval_tree_t), intent(in) :: eval_tree if (associated (eval_tree%root)) then ival => eval_tree%root%ival else ival => null () end if end function eval_tree_get_int_ptr function eval_tree_get_real_ptr (eval_tree) result (rval) real(default), pointer :: rval type(eval_tree_t), intent(in) :: eval_tree if (associated (eval_tree%root)) then rval => eval_tree%root%rval else rval => null () end if end function eval_tree_get_real_ptr function eval_tree_get_cmplx_ptr (eval_tree) result (cval) complex(default), pointer :: cval type(eval_tree_t), intent(in) :: eval_tree if (associated (eval_tree%root)) then cval => eval_tree%root%cval else cval => null () end if end function eval_tree_get_cmplx_ptr function eval_tree_get_subevt_ptr (eval_tree) result (pval) type(subevt_t), pointer :: pval type(eval_tree_t), intent(in) :: eval_tree if (associated (eval_tree%root)) then pval => eval_tree%root%pval else pval => null () end if end function eval_tree_get_subevt_ptr function eval_tree_get_pdg_array_ptr (eval_tree) result (aval) type(pdg_array_t), pointer :: aval type(eval_tree_t), intent(in) :: eval_tree if (associated (eval_tree%root)) then aval => eval_tree%root%aval else aval => null () end if end function eval_tree_get_pdg_array_ptr function eval_tree_get_string_ptr (eval_tree) result (sval) type(string_t), pointer :: sval type(eval_tree_t), intent(in) :: eval_tree if (associated (eval_tree%root)) then sval => eval_tree%root%sval else sval => null () end if end function eval_tree_get_string_ptr @ %def eval_tree_get_log_ptr eval_tree_get_int_ptr eval_tree_get_real_ptr @ %def eval_tree_get_cmplx_ptr @ %def eval_tree_get_subevt_ptr eval_tree_get_pdg_array_ptr @ %def eval_tree_get_string_ptr <>= procedure :: write => eval_tree_write <>= subroutine eval_tree_write (expr, unit, write_vars) class(eval_tree_t), intent(in) :: expr integer, intent(in), optional :: unit logical, intent(in), optional :: write_vars integer :: u logical :: vl u = given_output_unit (unit); if (u < 0) return vl = .false.; if (present (write_vars)) vl = write_vars write (u, "(1x,A)") "Evaluation tree:" if (associated (expr%root)) then call eval_node_write_rec (expr%root, unit) else write (u, "(3x,A)") "[empty]" end if if (vl) call var_list_write (expr%var_list, unit) end subroutine eval_tree_write @ %def eval_tree_write @ Use the written representation for generating an MD5 sum: <>= function eval_tree_get_md5sum (eval_tree) result (md5sum_et) character(32) :: md5sum_et type(eval_tree_t), intent(in) :: eval_tree integer :: u u = free_unit () open (unit = u, status = "scratch", action = "readwrite") call eval_tree_write (eval_tree, unit=u) rewind (u) md5sum_et = md5sum (u) close (u) end function eval_tree_get_md5sum @ %def eval_tree_get_md5sum @ \subsection{Direct evaluation} These procedures create an eval tree and evaluate it on-the-fly, returning only the final value. The evaluation must yield a well-defined value, unless the [[is_known]] flag is present, which will be set accordingly. <>= public :: eval_log public :: eval_int public :: eval_real public :: eval_cmplx public :: eval_subevt public :: eval_pdg_array public :: eval_string <>= function eval_log & (parse_node, var_list, subevt, is_known) result (lval) logical :: lval type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt logical, intent(out), optional :: is_known type(eval_tree_t), target :: eval_tree call eval_tree_init_lexpr & (eval_tree, parse_node, var_list, subevt) call eval_tree_evaluate (eval_tree) if (eval_tree_result_is_known (eval_tree)) then if (present (is_known)) is_known = .true. lval = eval_tree_get_log (eval_tree) else if (present (is_known)) then is_known = .false. else call eval_tree_unknown (eval_tree, parse_node) lval = .false. end if call eval_tree_final (eval_tree) end function eval_log function eval_int & (parse_node, var_list, subevt, is_known) result (ival) integer :: ival type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt logical, intent(out), optional :: is_known type(eval_tree_t), target :: eval_tree call eval_tree_init_expr & (eval_tree, parse_node, var_list, subevt) call eval_tree_evaluate (eval_tree) if (eval_tree_result_is_known (eval_tree)) then if (present (is_known)) is_known = .true. ival = eval_tree_get_int (eval_tree) else if (present (is_known)) then is_known = .false. else call eval_tree_unknown (eval_tree, parse_node) ival = 0 end if call eval_tree_final (eval_tree) end function eval_int function eval_real & (parse_node, var_list, subevt, is_known) result (rval) real(default) :: rval type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt logical, intent(out), optional :: is_known type(eval_tree_t), target :: eval_tree call eval_tree_init_expr & (eval_tree, parse_node, var_list, subevt) call eval_tree_evaluate (eval_tree) if (eval_tree_result_is_known (eval_tree)) then if (present (is_known)) is_known = .true. rval = eval_tree_get_real (eval_tree) else if (present (is_known)) then is_known = .false. else call eval_tree_unknown (eval_tree, parse_node) rval = 0 end if call eval_tree_final (eval_tree) end function eval_real function eval_cmplx & (parse_node, var_list, subevt, is_known) result (cval) complex(default) :: cval type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt logical, intent(out), optional :: is_known type(eval_tree_t), target :: eval_tree call eval_tree_init_expr & (eval_tree, parse_node, var_list, subevt) call eval_tree_evaluate (eval_tree) if (eval_tree_result_is_known (eval_tree)) then if (present (is_known)) is_known = .true. cval = eval_tree_get_cmplx (eval_tree) else if (present (is_known)) then is_known = .false. else call eval_tree_unknown (eval_tree, parse_node) cval = 0 end if call eval_tree_final (eval_tree) end function eval_cmplx function eval_subevt & (parse_node, var_list, subevt, is_known) result (pval) type(subevt_t) :: pval type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt logical, intent(out), optional :: is_known type(eval_tree_t), target :: eval_tree call eval_tree_init_pexpr & (eval_tree, parse_node, var_list, subevt) call eval_tree_evaluate (eval_tree) if (eval_tree_result_is_known (eval_tree)) then if (present (is_known)) is_known = .true. pval = eval_tree_get_subevt (eval_tree) else if (present (is_known)) then is_known = .false. else call eval_tree_unknown (eval_tree, parse_node) end if call eval_tree_final (eval_tree) end function eval_subevt function eval_pdg_array & (parse_node, var_list, subevt, is_known) result (aval) type(pdg_array_t) :: aval type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt logical, intent(out), optional :: is_known type(eval_tree_t), target :: eval_tree call eval_tree_init_cexpr & (eval_tree, parse_node, var_list, subevt) call eval_tree_evaluate (eval_tree) if (eval_tree_result_is_known (eval_tree)) then if (present (is_known)) is_known = .true. aval = eval_tree_get_pdg_array (eval_tree) else if (present (is_known)) then is_known = .false. else call eval_tree_unknown (eval_tree, parse_node) end if call eval_tree_final (eval_tree) end function eval_pdg_array function eval_string & (parse_node, var_list, subevt, is_known) result (sval) type(string_t) :: sval type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt logical, intent(out), optional :: is_known type(eval_tree_t), target :: eval_tree call eval_tree_init_sexpr & (eval_tree, parse_node, var_list, subevt) call eval_tree_evaluate (eval_tree) if (eval_tree_result_is_known (eval_tree)) then if (present (is_known)) is_known = .true. sval = eval_tree_get_string (eval_tree) else if (present (is_known)) then is_known = .false. else call eval_tree_unknown (eval_tree, parse_node) sval = "" end if call eval_tree_final (eval_tree) end function eval_string @ %def eval_log eval_int eval_real eval_cmplx @ %def eval_subevt eval_pdg_array eval_string @ %def eval_tree_unknown @ Here is a variant that returns numeric values of all possible kinds, the appropriate kind to be selected later: <>= public :: eval_numeric <>= subroutine eval_numeric & (parse_node, var_list, subevt, ival, rval, cval, & is_known, result_type) type(parse_node_t), intent(in), target :: parse_node type(var_list_t), intent(in), target :: var_list type(subevt_t), intent(in), optional, target :: subevt integer, intent(out), optional :: ival real(default), intent(out), optional :: rval complex(default), intent(out), optional :: cval logical, intent(out), optional :: is_known integer, intent(out), optional :: result_type type(eval_tree_t), target :: eval_tree call eval_tree_init_expr & (eval_tree, parse_node, var_list, subevt) call eval_tree_evaluate (eval_tree) if (eval_tree_result_is_known (eval_tree)) then if (present (ival)) ival = eval_tree_get_int (eval_tree) if (present (rval)) rval = eval_tree_get_real (eval_tree) if (present (cval)) cval = eval_tree_get_cmplx (eval_tree) if (present (is_known)) is_known = .true. else call eval_tree_unknown (eval_tree, parse_node) if (present (ival)) ival = 0 if (present (rval)) rval = 0 if (present (cval)) cval = 0 if (present (is_known)) is_known = .false. end if if (present (result_type)) & result_type = eval_tree_get_result_type (eval_tree) call eval_tree_final (eval_tree) end subroutine eval_numeric @ %def eval_numeric @ Error message with debugging info: <>= subroutine eval_tree_unknown (eval_tree, parse_node) type(eval_tree_t), intent(in) :: eval_tree type(parse_node_t), intent(in) :: parse_node call parse_node_write_rec (parse_node) call eval_tree_write (eval_tree) call msg_error ("Evaluation yields an undefined result, inserting default") end subroutine eval_tree_unknown @ %def eval_tree_unknown @ \subsection{Factory Type} Since [[eval_tree_t]] is an implementation of [[expr_t]], we also need a matching factory type and build method. <>= public :: eval_tree_factory_t <>= type, extends (expr_factory_t) :: eval_tree_factory_t private type(parse_node_t), pointer :: pn => null () contains <> end type eval_tree_factory_t @ %def eval_tree_factory_t @ Output: delegate to the output of the embedded parse node. <>= procedure :: write => eval_tree_factory_write <>= subroutine eval_tree_factory_write (expr_factory, unit) class(eval_tree_factory_t), intent(in) :: expr_factory integer, intent(in), optional :: unit if (associated (expr_factory%pn)) then call parse_node_write_rec (expr_factory%pn, unit) end if end subroutine eval_tree_factory_write @ %def eval_tree_factory_write @ Initializer: take a parse node and hide it thus from the environment. <>= procedure :: init => eval_tree_factory_init <>= subroutine eval_tree_factory_init (expr_factory, pn) class(eval_tree_factory_t), intent(out) :: expr_factory type(parse_node_t), intent(in), pointer :: pn expr_factory%pn => pn end subroutine eval_tree_factory_init @ %def eval_tree_factory_init @ Factory method: allocate expression with correct eval tree type. If the stored parse node is not associate, don't allocate. <>= procedure :: build => eval_tree_factory_build <>= subroutine eval_tree_factory_build (expr_factory, expr) class(eval_tree_factory_t), intent(in) :: expr_factory class(expr_t), intent(out), allocatable :: expr if (associated (expr_factory%pn)) then allocate (eval_tree_t :: expr) select type (expr) type is (eval_tree_t) expr%pn => expr_factory%pn end select end if end subroutine eval_tree_factory_build @ %def eval_tree_factory_build @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[eval_trees_ut.f90]]>>= <> module eval_trees_ut use unit_tests use eval_trees_uti <> <> contains <> end module eval_trees_ut @ %def eval_trees_ut @ <<[[eval_trees_uti.f90]]>>= <> module eval_trees_uti <> <> use ifiles use lexers use lorentz use syntax_rules, only: syntax_write use pdg_arrays use subevents use variables use observables use eval_trees <> <> contains <> end module eval_trees_uti @ %def eval_trees_ut @ API: driver for the unit tests below. <>= public :: expressions_test <>= subroutine expressions_test (u, results) integer, intent(in) :: u type (test_results_t), intent(inout) :: results <> end subroutine expressions_test @ %def expressions_test @ Testing the routines of the expressions module. First a simple unary observable and the node evaluation. <>= call test (expressions_1, "expressions_1", & "check simple observable", & u, results) <>= public :: expressions_1 <>= subroutine expressions_1 (u) integer, intent(in) :: u type(var_list_t), pointer :: var_list => null () type(eval_node_t), pointer :: node => null () type(prt_t), pointer :: prt => null () type(string_t) :: var_name write (u, "(A)") "* Test output: Expressions" write (u, "(A)") "* Purpose: test simple observable and node evaluation" write (u, "(A)") write (u, "(A)") "* Setting a unary observable:" write (u, "(A)") allocate (var_list) allocate (prt) call var_list_set_observables_unary (var_list, prt) call var_list%write (u) write (u, "(A)") "* Evaluating the observable node:" write (u, "(A)") var_name = "PDG" allocate (node) call node%test_obs (var_list, var_name) call node%write (u) write (u, "(A)") "* Cleanup" write (u, "(A)") call node%final_rec () deallocate (node) !!! Workaround for NAGFOR 6.2 ! call var_list%final () deallocate (var_list) deallocate (prt) write (u, "(A)") write (u, "(A)") "* Test output end: expressions_1" end subroutine expressions_1 @ %def expressions_1 @ Parse a complicated expression, transfer it to a parse tree and evaluate. <>= call test (expressions_2, "expressions_2", & "check expression transfer to parse tree", & u, results) <>= public :: expressions_2 <>= subroutine expressions_2 (u) integer, intent(in) :: u type(ifile_t) :: ifile type(stream_t) :: stream type(eval_tree_t) :: eval_tree type(string_t) :: expr_text type(var_list_t), pointer :: var_list => null () write (u, "(A)") "* Test output: Expressions" write (u, "(A)") "* Purpose: test parse routines" write (u, "(A)") call syntax_expr_init () call syntax_write (syntax_expr, u) allocate (var_list) call var_list_append_real (var_list, var_str ("tolerance"), 0._default) call var_list_append_real (var_list, var_str ("x"), -5._default) call var_list_append_int (var_list, var_str ("foo"), -27) call var_list_append_real (var_list, var_str ("mb"), 4._default) expr_text = & "let real twopi = 2 * pi in" // & " twopi * sqrt (25.d0 - mb^2)" // & " / (let int mb_or_0 = max (mb, 0) in" // & " 1 + (if -1 TeV <= x < mb_or_0 then abs(x) else x endif))" call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call var_list%write (u) call eval_tree%init_stream (stream, var_list=var_list) call eval_tree%evaluate () call eval_tree%write (u) write (u, "(A)") "* Input string:" write (u, "(A,A)") " ", char (expr_text) write (u, "(A)") write (u, "(A)") "* Cleanup" call stream_final (stream) call ifile_final (ifile) call eval_tree%final () call var_list%final () deallocate (var_list) call syntax_expr_final () write (u, "(A)") write (u, "(A)") "* Test output end: expressions_2" end subroutine expressions_2 @ %def expressions_2 @ Test a subevent expression. <>= call test (expressions_3, "expressions_3", & "check subevent expressions", & u, results) <>= public :: expressions_3 <>= subroutine expressions_3 (u) integer, intent(in) :: u type(subevt_t) :: subevt write (u, "(A)") "* Test output: Expressions" write (u, "(A)") "* Purpose: test subevent expressions" write (u, "(A)") write (u, "(A)") "* Initialize subevent:" write (u, "(A)") call subevt_init (subevt) call subevt_reset (subevt, 1) call subevt_set_incoming (subevt, 1, & 22, vector4_moving (1.e3_default, 1.e3_default, 1), & 0._default, [2]) call subevt_write (subevt, u) call subevt_reset (subevt, 4) call subevt_reset (subevt, 3) call subevt_set_incoming (subevt, 1, & 21, vector4_moving (1.e3_default, 1.e3_default, 3), & 0._default, [1]) call subevt_polarize (subevt, 1, -1) call subevt_set_outgoing (subevt, 2, & 1, vector4_moving (0._default, 1.e3_default, 3), & -1.e6_default, [7]) call subevt_set_composite (subevt, 3, & vector4_moving (-1.e3_default, 0._default, 3), & [2, 7]) call subevt_write (subevt, u) write (u, "(A)") write (u, "(A)") "* Test output end: expressions_3" end subroutine expressions_3 @ %def expressions_3 @ Test expressions from a PDG array. <>= call test (expressions_4, "expressions_4", & "check pdg array expressions", & u, results) <>= public :: expressions_4 <>= subroutine expressions_4 (u) integer, intent(in) :: u type(subevt_t), target :: subevt type(string_t) :: expr_text type(ifile_t) :: ifile type(stream_t) :: stream type(eval_tree_t) :: eval_tree type(var_list_t), pointer :: var_list => null () type(pdg_array_t) :: aval write (u, "(A)") "* Test output: Expressions" write (u, "(A)") "* Purpose: test pdg array expressions" write (u, "(A)") write (u, "(A)") "* Initialization:" write (u, "(A)") call syntax_pexpr_init () call syntax_write (syntax_pexpr, u) allocate (var_list) call var_list_append_real (var_list, var_str ("tolerance"), 0._default) aval = 0 call var_list_append_pdg_array (var_list, var_str ("particle"), aval) aval = [11,-11] call var_list_append_pdg_array (var_list, var_str ("lepton"), aval) aval = 22 call var_list_append_pdg_array (var_list, var_str ("photon"), aval) aval = 1 call var_list_append_pdg_array (var_list, var_str ("u"), aval) call subevt_init (subevt) call subevt_reset (subevt, 6) call subevt_set_incoming (subevt, 1, & 1, vector4_moving (1._default, 1._default, 1), 0._default) call subevt_set_incoming (subevt, 2, & -1, vector4_moving (2._default, 2._default, 1), 0._default) call subevt_set_outgoing (subevt, 3, & 22, vector4_moving (3._default, 3._default, 1), 0._default) call subevt_set_outgoing (subevt, 4, & 22, vector4_moving (4._default, 4._default, 1), 0._default) call subevt_set_outgoing (subevt, 5, & 11, vector4_moving (5._default, 5._default, 1), 0._default) call subevt_set_outgoing (subevt, 6, & -11, vector4_moving (6._default, 6._default, 1), 0._default) write (u, "(A)") write (u, "(A)") "* Expression:" expr_text = & "let alias quark = pdg(1):pdg(2):pdg(3) in" // & " any E > 3 GeV " // & " [sort by - Pt " // & " [select if Index < 6 " // & " [photon:pdg(-11):pdg(3):quark " // & " & incoming particle]]]" // & " and" // & " eval Theta [extract index -1 [photon]] > 45 degree" // & " and" // & " count [incoming photon] * 3 > 0" write (u, "(A,A)") " ", char (expr_text) write (u, "(A)") write (u, "(A)") write (u, "(A)") "* Extract the evaluation tree:" write (u, "(A)") call ifile_append (ifile, expr_text) call stream_init (stream, ifile) call eval_tree%init_stream (stream, var_list, subevt, V_LOG) call eval_tree%write (u) call eval_tree%evaluate () write (u, "(A)") write (u, "(A)") "* Evaluate the tree:" write (u, "(A)") call eval_tree%write (u) write (u, "(A)") write (u, "(A)") "* Cleanup" write (u, "(A)") call stream_final (stream) call ifile_final (ifile) call eval_tree%final () call var_list%final () deallocate (var_list) call syntax_pexpr_final () write (u, "(A)") write (u, "(A)") "* Test output end: expressions_4" end subroutine expressions_4 @ %def expressions_4 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{Physics Models} A model object represents a physics model. It contains a table of particle data, a list of parameters, and a vertex table. The list of parameters is a variable list which includes the real parameters (which are pointers to the particle data table) and PDG array variables for the particles themselves. The vertex list is used for phase-space generation, not for calculating the matrix element. The actual numeric model data are in the base type [[model_data_t]], as part of the [[qft]] section. We implement the [[model_t]] as an extension of this, for convenient direct access to the base-type methods via inheritance. (Alternatively, we could delegate these calls explicitly.) The extension contains administrative additions, such as the methods for recalculating derived data and keeping the parameter set consistent. It thus acts as a proxy of the actual model-data object towards the \whizard\ package. There are further proxy objects, such as the [[parameter_t]] array which provides the interface to the actual numeric parameters. Model definitions are read from model files. Therefore, this module contains a parser for model files. The parameter definitions (derived parameters) are Sindarin expressions. The models, as read from file, are stored in a model library which is a simple list of model definitions. For setting up a process object we should make a copy (an instance) of a model, which gets the current parameter values from the global variable list. \subsection{Module} <<[[models.f90]]>>= <> module models use, intrinsic :: iso_c_binding !NODEP! <> use kinds, only: c_default_float <> use io_units use diagnostics use md5 use os_interface use physics_defs, only: UNDEFINED use model_data use ifiles use syntax_rules use lexers use parser use pdg_arrays use variables use expr_base use eval_trees use ttv_formfactors, only: init_parameters <> <> <> <> <> <> contains <> end module models @ %def models @ \subsection{Physics Parameters} A parameter has a name, a value. Derived parameters also have a definition in terms of other parameters, which is stored as an [[eval_tree]]. External parameters are set by an external program. This parameter object should be considered as a proxy object. The parameter name and value are stored in a corresponding [[modelpar_data_t]] object which is located in a [[model_data_t]] object. The latter is a component of the [[model_t]] handler. Methods of [[parameter_t]] can be delegated to the [[par_data_t]] component. The [[pn]] component is a pointer to the parameter definition inside the model parse tree. It allows us to recreate the [[eval_tree]] when making copies (instances) of the parameter object. <>= integer, parameter :: PAR_NONE = 0, PAR_UNUSED = -1 integer, parameter :: PAR_INDEPENDENT = 1, PAR_DERIVED = 2 integer, parameter :: PAR_EXTERNAL = 3 @ %def PAR_NONE PAR_INDEPENDENT PAR_DERIVED PAR_EXTERNAL PAR_UNUSED <>= type :: parameter_t private integer :: type = PAR_NONE class(modelpar_data_t), pointer :: data => null () type(parse_node_t), pointer :: pn => null () class(expr_t), allocatable :: expr contains <> end type parameter_t @ %def parameter_t @ Initialization depends on parameter type. Independent parameters are initialized by a constant value or a constant numerical expression (which may contain a unit). Derived parameters are initialized by an arbitrary numerical expression, which makes use of the current variable list. The expression is evaluated by the function [[parameter_reset]]. This implementation supports only real parameters and real values. <>= procedure :: init_independent_value => parameter_init_independent_value procedure :: init_independent => parameter_init_independent procedure :: init_derived => parameter_init_derived procedure :: init_external => parameter_init_external procedure :: init_unused => parameter_init_unused <>= subroutine parameter_init_independent_value (par, par_data, name, value) class(parameter_t), intent(out) :: par class(modelpar_data_t), intent(in), target :: par_data type(string_t), intent(in) :: name real(default), intent(in) :: value par%type = PAR_INDEPENDENT par%data => par_data call par%data%init (name, value) end subroutine parameter_init_independent_value subroutine parameter_init_independent (par, par_data, name, pn) class(parameter_t), intent(out) :: par class(modelpar_data_t), intent(in), target :: par_data type(string_t), intent(in) :: name type(parse_node_t), intent(in), target :: pn par%type = PAR_INDEPENDENT par%pn => pn allocate (eval_tree_t :: par%expr) select type (expr => par%expr) type is (eval_tree_t) call expr%init_numeric_value (pn) end select par%data => par_data call par%data%init (name, par%expr%get_real ()) end subroutine parameter_init_independent subroutine parameter_init_derived (par, par_data, name, pn, var_list) class(parameter_t), intent(out) :: par class(modelpar_data_t), intent(in), target :: par_data type(string_t), intent(in) :: name type(parse_node_t), intent(in), target :: pn type(var_list_t), intent(in), target :: var_list par%type = PAR_DERIVED par%pn => pn allocate (eval_tree_t :: par%expr) select type (expr => par%expr) type is (eval_tree_t) call expr%init_expr (pn, var_list=var_list) end select par%data => par_data ! call par%expr%evaluate () call par%data%init (name, 0._default) end subroutine parameter_init_derived subroutine parameter_init_external (par, par_data, name) class(parameter_t), intent(out) :: par class(modelpar_data_t), intent(in), target :: par_data type(string_t), intent(in) :: name par%type = PAR_EXTERNAL par%data => par_data call par%data%init (name, 0._default) end subroutine parameter_init_external subroutine parameter_init_unused (par, par_data, name) class(parameter_t), intent(out) :: par class(modelpar_data_t), intent(in), target :: par_data type(string_t), intent(in) :: name par%type = PAR_UNUSED par%data => par_data call par%data%init (name, 0._default) end subroutine parameter_init_unused @ %def parameter_init_independent_value @ %def parameter_init_independent @ %def parameter_init_derived @ %def parameter_init_external @ %def parameter_init_unused @ The finalizer is needed for the evaluation tree in the definition. <>= procedure :: final => parameter_final <>= subroutine parameter_final (par) class(parameter_t), intent(inout) :: par if (allocated (par%expr)) then call par%expr%final () end if end subroutine parameter_final @ %def parameter_final @ All derived parameters should be recalculated if some independent parameters have changed: <>= procedure :: reset_derived => parameter_reset_derived <>= subroutine parameter_reset_derived (par) class(parameter_t), intent(inout) :: par select case (par%type) case (PAR_DERIVED) call par%expr%evaluate () par%data = par%expr%get_real () end select end subroutine parameter_reset_derived @ %def parameter_reset_derived parameter_reset_external @ Output. [We should have a formula format for the eval tree, suitable for input and output!] <>= procedure :: write => parameter_write <>= subroutine parameter_write (par, unit, write_defs) class(parameter_t), intent(in) :: par integer, intent(in), optional :: unit logical, intent(in), optional :: write_defs logical :: defs integer :: u u = given_output_unit (unit); if (u < 0) return defs = .false.; if (present (write_defs)) defs = write_defs select case (par%type) case (PAR_INDEPENDENT) write (u, "(3x,A)", advance="no") "parameter" call par%data%write (u) case (PAR_DERIVED) write (u, "(3x,A)", advance="no") "derived" call par%data%write (u) case (PAR_EXTERNAL) write (u, "(3x,A)", advance="no") "external" call par%data%write (u) case (PAR_UNUSED) write (u, "(3x,A)", advance="no") "unused" write (u, "(1x,A)", advance="no") char (par%data%get_name ()) end select select case (par%type) case (PAR_DERIVED) if (defs) then call par%expr%write (unit) else write (u, "(A)") end if case default write (u, "(A)") end select end subroutine parameter_write @ %def parameter_write @ Screen output variant. Restrict output to the given parameter type. <>= procedure :: show => parameter_show <>= subroutine parameter_show (par, l, u, partype) class(parameter_t), intent(in) :: par integer, intent(in) :: l, u integer, intent(in) :: partype if (par%type == partype) then call par%data%show (l, u) end if end subroutine parameter_show @ %def parameter_show @ \subsection{Model Object} A model object holds all information about parameters, particles, and vertices. For models that require an external program for parameter calculation, there is the pointer to a function that does this calculation, given the set of independent and derived parameters. As explained above, the type inherits from [[model_data_t]], which is the actual storage for the model data. When reading a model, we create a parse tree. Parameter definitions are available via parse nodes. Since we may need those later when making model instances, we keep the whole parse tree in the model definition (but not in the instances). <>= public :: model_t <>= type, extends (model_data_t) :: model_t private character(32) :: md5sum = "" logical :: ufo_model = .false. type(string_t) :: ufo_path type(string_t), dimension(:), allocatable :: schemes type(string_t), allocatable :: selected_scheme type(parameter_t), dimension(:), allocatable :: par integer :: max_par_name_length = 0 integer :: max_field_name_length = 0 type(var_list_t) :: var_list type(string_t) :: dlname procedure(model_init_external_parameters), nopass, pointer :: & init_external_parameters => null () type(dlaccess_t) :: dlaccess type(parse_tree_t) :: parse_tree contains <> end type model_t @ %def model_t @ This is the interface for a procedure that initializes the calculation of external parameters, given the array of all parameters. <>= abstract interface subroutine model_init_external_parameters (par) bind (C) import real(c_default_float), dimension(*), intent(inout) :: par end subroutine model_init_external_parameters end interface @ %def model_init_external_parameters @ Initialization: Specify the number of parameters, particles, vertices and allocate memory. If an associated DL library is specified, load this library. The model may already carry scheme information, so we have to save and restore the scheme number when actually initializing the [[model_data_t]] base. <>= generic :: init => model_init procedure, private :: model_init <>= subroutine model_init & (model, name, libname, os_data, n_par, n_prt, n_vtx, ufo) class(model_t), intent(inout) :: model type(string_t), intent(in) :: name, libname type(os_data_t), intent(in) :: os_data integer, intent(in) :: n_par, n_prt, n_vtx logical, intent(in), optional :: ufo type(c_funptr) :: c_fptr type(string_t) :: libpath integer :: scheme_num scheme_num = model%get_scheme_num () call model%basic_init (name, n_par, n_prt, n_vtx) if (present (ufo)) model%ufo_model = ufo call model%set_scheme_num (scheme_num) if (libname /= "") then if (.not. os_data%use_testfiles) then libpath = os_data%whizard_models_libpath_local model%dlname = os_get_dlname ( & libpath // "/" // libname, os_data, ignore=.true.) end if if (model%dlname == "") then libpath = os_data%whizard_models_libpath model%dlname = os_get_dlname (libpath // "/" // libname, os_data) end if else model%dlname = "" end if if (model%dlname /= "") then if (.not. dlaccess_is_open (model%dlaccess)) then if (logging) & call msg_message ("Loading model auxiliary library '" & // char (libpath) // "/" // char (model%dlname) // "'") call dlaccess_init (model%dlaccess, os_data%whizard_models_libpath, & model%dlname, os_data) if (dlaccess_has_error (model%dlaccess)) then call msg_message (char (dlaccess_get_error (model%dlaccess))) call msg_fatal ("Loading model auxiliary library '" & // char (model%dlname) // "' failed") return end if c_fptr = dlaccess_get_c_funptr (model%dlaccess, & var_str ("init_external_parameters")) if (dlaccess_has_error (model%dlaccess)) then call msg_message (char (dlaccess_get_error (model%dlaccess))) call msg_fatal ("Loading function from auxiliary library '" & // char (model%dlname) // "' failed") return end if call c_f_procpointer (c_fptr, model% init_external_parameters) end if end if end subroutine model_init @ %def model_init @ For a model instance, we do not attempt to load a DL library. This is the core of the full initializer above. <>= procedure, private :: basic_init => model_basic_init <>= subroutine model_basic_init (model, name, n_par, n_prt, n_vtx) class(model_t), intent(inout) :: model type(string_t), intent(in) :: name integer, intent(in) :: n_par, n_prt, n_vtx allocate (model%par (n_par)) call model%model_data_t%init (name, n_par, 0, n_prt, n_vtx) end subroutine model_basic_init @ %def model_basic_init @ Finalization: The variable list contains allocated pointers, also the parse tree. We also close the DL access object, if any, that enables external parameter calculation. <>= procedure :: final => model_final <>= subroutine model_final (model) class(model_t), intent(inout) :: model integer :: i if (allocated (model%par)) then do i = 1, size (model%par) call model%par(i)%final () end do end if call model%var_list%final (follow_link=.false.) if (model%dlname /= "") call dlaccess_final (model%dlaccess) call parse_tree_final (model%parse_tree) call model%model_data_t%final () end subroutine model_final @ %def model_final @ Output. By default, the output is in the form of an input file. If [[verbose]] is true, for each derived parameter the definition (eval tree) is displayed, and the vertex hash table is shown. <>= procedure :: write => model_write <>= subroutine model_write (model, unit, verbose, & show_md5sum, show_variables, show_parameters, & show_particles, show_vertices, show_scheme) class(model_t), intent(in) :: model integer, intent(in), optional :: unit logical, intent(in), optional :: verbose logical, intent(in), optional :: show_md5sum logical, intent(in), optional :: show_variables logical, intent(in), optional :: show_parameters logical, intent(in), optional :: show_particles logical, intent(in), optional :: show_vertices logical, intent(in), optional :: show_scheme logical :: verb, show_md5, show_par, show_var integer :: u, i u = given_output_unit (unit); if (u < 0) return verb = .false.; if (present (verbose)) verb = verbose show_md5 = .true.; if (present (show_md5sum)) & show_md5 = show_md5sum show_par = .true.; if (present (show_parameters)) & show_par = show_parameters show_var = verb; if (present (show_variables)) & show_var = show_variables write (u, "(A,A,A)") 'model "', char (model%get_name ()), '"' if (show_md5 .and. model%md5sum /= "") & write (u, "(1x,A,A,A)") "! md5sum = '", model%md5sum, "'" if (model%is_ufo_model ()) then write (u, "(1x,A)") "! model derived from UFO source" else if (model%has_schemes ()) then write (u, "(1x,A)", advance="no") "! schemes =" do i = 1, size (model%schemes) if (i > 1) write (u, "(',')", advance="no") write (u, "(1x,A,A,A)", advance="no") & "'", char (model%schemes(i)), "'" end do write (u, *) if (allocated (model%selected_scheme)) then write (u, "(1x,A,A,A,I0,A)") & "! selected scheme = '", char (model%get_scheme ()), & "' (", model%get_scheme_num (), ")" end if end if if (show_par) then write (u, "(A)") do i = 1, size (model%par) call model%par(i)%write (u, write_defs=verbose) end do end if call model%model_data_t%write (unit, verbose, & show_md5sum, show_variables, & show_parameters=.false., & show_particles=show_particles, & show_vertices=show_vertices, & show_scheme=show_scheme) if (show_var) then write (u, "(A)") call var_list_write (model%var_list, unit, follow_link=.false.) end if end subroutine model_write @ %def model_write @ Screen output, condensed form. <>= procedure :: show => model_show <>= subroutine model_show (model, unit) class(model_t), intent(in) :: model integer, intent(in), optional :: unit integer :: i, u, l u = given_output_unit (unit) write (u, "(A,1x,A)") "Model:", char (model%get_name ()) if (model%has_schemes ()) then write (u, "(2x,A,A,A,I0,A)") "Scheme: '", & char (model%get_scheme ()), "' (", model%get_scheme_num (), ")" end if l = model%max_field_name_length call model%show_fields (l, u) l = model%max_par_name_length if (any (model%par%type == PAR_INDEPENDENT)) then write (u, "(2x,A)") "Independent parameters:" do i = 1, size (model%par) call model%par(i)%show (l, u, PAR_INDEPENDENT) end do end if if (any (model%par%type == PAR_DERIVED)) then write (u, "(2x,A)") "Derived parameters:" do i = 1, size (model%par) call model%par(i)%show (l, u, PAR_DERIVED) end do end if if (any (model%par%type == PAR_EXTERNAL)) then write (u, "(2x,A)") "External parameters:" do i = 1, size (model%par) call model%par(i)%show (l, u, PAR_EXTERNAL) end do end if if (any (model%par%type == PAR_UNUSED)) then write (u, "(2x,A)") "Unused parameters:" do i = 1, size (model%par) call model%par(i)%show (l, u, PAR_UNUSED) end do end if end subroutine model_show @ %def model_show @ Show all fields/particles. <>= procedure :: show_fields => model_show_fields <>= subroutine model_show_fields (model, l, unit) class(model_t), intent(in), target :: model integer, intent(in) :: l integer, intent(in), optional :: unit type(field_data_t), pointer :: field integer :: u, i u = given_output_unit (unit) write (u, "(2x,A)") "Particles:" do i = 1, model%get_n_field () field => model%get_field_ptr_by_index (i) call field%show (l, u) end do end subroutine model_show_fields @ %def model_data_show_fields @ Show the list of stable, unstable, polarized, or unpolarized particles, respectively. <>= procedure :: show_stable => model_show_stable procedure :: show_unstable => model_show_unstable procedure :: show_polarized => model_show_polarized procedure :: show_unpolarized => model_show_unpolarized <>= subroutine model_show_stable (model, unit) class(model_t), intent(in), target :: model integer, intent(in), optional :: unit type(field_data_t), pointer :: field integer :: u, i u = given_output_unit (unit) write (u, "(A,1x)", advance="no") "Stable particles:" do i = 1, model%get_n_field () field => model%get_field_ptr_by_index (i) if (field%is_stable (.false.)) then write (u, "(1x,A)", advance="no") char (field%get_name (.false.)) end if if (field%has_antiparticle ()) then if (field%is_stable (.true.)) then write (u, "(1x,A)", advance="no") char (field%get_name (.true.)) end if end if end do write (u, *) end subroutine model_show_stable subroutine model_show_unstable (model, unit) class(model_t), intent(in), target :: model integer, intent(in), optional :: unit type(field_data_t), pointer :: field integer :: u, i u = given_output_unit (unit) write (u, "(A,1x)", advance="no") "Unstable particles:" do i = 1, model%get_n_field () field => model%get_field_ptr_by_index (i) if (.not. field%is_stable (.false.)) then write (u, "(1x,A)", advance="no") char (field%get_name (.false.)) end if if (field%has_antiparticle ()) then if (.not. field%is_stable (.true.)) then write (u, "(1x,A)", advance="no") char (field%get_name (.true.)) end if end if end do write (u, *) end subroutine model_show_unstable subroutine model_show_polarized (model, unit) class(model_t), intent(in), target :: model integer, intent(in), optional :: unit type(field_data_t), pointer :: field integer :: u, i u = given_output_unit (unit) write (u, "(A,1x)", advance="no") "Polarized particles:" do i = 1, model%get_n_field () field => model%get_field_ptr_by_index (i) if (field%is_polarized (.false.)) then write (u, "(1x,A)", advance="no") char (field%get_name (.false.)) end if if (field%has_antiparticle ()) then if (field%is_polarized (.true.)) then write (u, "(1x,A)", advance="no") char (field%get_name (.true.)) end if end if end do write (u, *) end subroutine model_show_polarized subroutine model_show_unpolarized (model, unit) class(model_t), intent(in), target :: model integer, intent(in), optional :: unit type(field_data_t), pointer :: field integer :: u, i u = given_output_unit (unit) write (u, "(A,1x)", advance="no") "Unpolarized particles:" do i = 1, model%get_n_field () field => model%get_field_ptr_by_index (i) if (.not. field%is_polarized (.false.)) then write (u, "(1x,A)", advance="no") & char (field%get_name (.false.)) end if if (field%has_antiparticle ()) then if (.not. field%is_polarized (.true.)) then write (u, "(1x,A)", advance="no") char (field%get_name (.true.)) end if end if end do write (u, *) end subroutine model_show_unpolarized @ %def model_show_stable @ %def model_show_unstable @ %def model_show_polarized @ %def model_show_unpolarized @ Retrieve the MD5 sum of a model (actually, of the model file). <>= procedure :: get_md5sum => model_get_md5sum <>= function model_get_md5sum (model) result (md5sum) character(32) :: md5sum class(model_t), intent(in) :: model md5sum = model%md5sum end function model_get_md5sum @ %def model_get_md5sum @ Parameters are defined by an expression which may be constant or arbitrary. Note: the auxiliary pointer [[value_ptr]] is a workaround for a bug in gfortran 4.8.1: the target of the function pointer is lost, if the pointer is provided directly as argument. <>= procedure :: & set_parameter_constant => model_set_parameter_constant procedure, private :: & set_parameter_parse_node => model_set_parameter_parse_node procedure :: & set_parameter_external => model_set_parameter_external procedure :: & set_parameter_unused => model_set_parameter_unused <>= subroutine model_set_parameter_constant (model, i, name, value) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(string_t), intent(in) :: name real(default), intent(in) :: value logical, save, target :: known = .true. class(modelpar_data_t), pointer :: par_data real(default), pointer :: value_ptr par_data => model%get_par_real_ptr (i) call model%par(i)%init_independent_value (par_data, name, value) value_ptr => par_data%get_real_ptr () call var_list_append_real_ptr (model%var_list, & name, value_ptr, & is_known=known, intrinsic=.true.) model%max_par_name_length = max (model%max_par_name_length, len (name)) end subroutine model_set_parameter_constant subroutine model_set_parameter_parse_node (model, i, name, pn, constant) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(string_t), intent(in) :: name type(parse_node_t), intent(in), target :: pn logical, intent(in) :: constant logical, save, target :: known = .true. class(modelpar_data_t), pointer :: par_data real(default), pointer :: value_ptr par_data => model%get_par_real_ptr (i) if (constant) then call model%par(i)%init_independent (par_data, name, pn) else call model%par(i)%init_derived (par_data, name, pn, model%var_list) end if value_ptr => par_data%get_real_ptr () call var_list_append_real_ptr (model%var_list, & name, value_ptr, & is_known=known, locked=.not.constant, intrinsic=.true.) model%max_par_name_length = max (model%max_par_name_length, len (name)) end subroutine model_set_parameter_parse_node subroutine model_set_parameter_external (model, i, name) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(string_t), intent(in) :: name logical, save, target :: known = .true. class(modelpar_data_t), pointer :: par_data real(default), pointer :: value_ptr par_data => model%get_par_real_ptr (i) call model%par(i)%init_external (par_data, name) value_ptr => par_data%get_real_ptr () call var_list_append_real_ptr (model%var_list, & name, value_ptr, & is_known=known, locked=.true., intrinsic=.true.) model%max_par_name_length = max (model%max_par_name_length, len (name)) end subroutine model_set_parameter_external subroutine model_set_parameter_unused (model, i, name) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(string_t), intent(in) :: name class(modelpar_data_t), pointer :: par_data par_data => model%get_par_real_ptr (i) call model%par(i)%init_unused (par_data, name) call var_list_append_real (model%var_list, & name, locked=.true., intrinsic=.true.) model%max_par_name_length = max (model%max_par_name_length, len (name)) end subroutine model_set_parameter_unused @ %def model_set_parameter @ Make a copy of a parameter. We assume that the [[model_data_t]] parameter arrays have already been copied, so names and values are available in the current model, and can be used as targets. The eval tree should not be copied, since it should refer to the new variable list. The safe solution is to make use of the above initializers, which also take care of the building a new variable list. <>= procedure, private :: copy_parameter => model_copy_parameter <>= subroutine model_copy_parameter (model, i, par) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(parameter_t), intent(in) :: par type(string_t) :: name real(default) :: value name = par%data%get_name () select case (par%type) case (PAR_INDEPENDENT) if (associated (par%pn)) then call model%set_parameter_parse_node (i, name, par%pn, & constant = .true.) else value = par%data%get_real () call model%set_parameter_constant (i, name, value) end if case (PAR_DERIVED) call model%set_parameter_parse_node (i, name, par%pn, & constant = .false.) case (PAR_EXTERNAL) call model%set_parameter_external (i, name) case (PAR_UNUSED) call model%set_parameter_unused (i, name) end select end subroutine model_copy_parameter @ %def model_copy_parameter @ Recalculate all derived parameters. <>= procedure :: update_parameters => model_parameters_update <>= subroutine model_parameters_update (model) class(model_t), intent(inout) :: model integer :: i real(default), dimension(:), allocatable :: par do i = 1, size (model%par) call model%par(i)%reset_derived () end do if (associated (model%init_external_parameters)) then allocate (par (model%get_n_real ())) call model%real_parameters_to_c_array (par) call model%init_external_parameters (par) call model%real_parameters_from_c_array (par) if (model%get_name() == var_str ("SM_tt_threshold")) & call set_threshold_parameters () end if contains subroutine set_threshold_parameters () real(default) :: mpole, wtop !!! !!! !!! Workaround for OS-X and BSD which do not load !!! !!! !!! the global values created previously. Therefore !!! !!! !!! a second initialization for the threshold model, !!! !!! !!! where M1S is required to compute the top mass. call init_parameters (mpole, wtop, & par(20), par(21), par(22), & par(19), par(39), par(4), par(1), & par(2), par(10), par(24), par(25), & par(23), par(26), par(27), par(29), & par(30), par(31), par(32), par(33), & par(36) > 0._default, par(28)) end subroutine set_threshold_parameters end subroutine model_parameters_update @ %def model_parameters_update @ Initialize field data with PDG long name and PDG code. <>= procedure, private :: init_field => model_init_field <>= subroutine model_init_field (model, i, longname, pdg) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(string_t), intent(in) :: longname integer, intent(in) :: pdg type(field_data_t), pointer :: field field => model%get_field_ptr_by_index (i) call field%init (longname, pdg) end subroutine model_init_field @ %def model_init_field @ Copy field data for index [[i]] from another particle which serves as a template. The name should be the unique long name. <>= procedure, private :: copy_field => model_copy_field <>= subroutine model_copy_field (model, i, name_src) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(string_t), intent(in) :: name_src type(field_data_t), pointer :: field_src, field field_src => model%get_field_ptr (name_src) field => model%get_field_ptr_by_index (i) call field%copy_from (field_src) end subroutine model_copy_field @ %def model_copy_field @ \subsection{Model Access via Variables} Write the model variable list. <>= procedure :: write_var_list => model_write_var_list <>= subroutine model_write_var_list (model, unit, follow_link) class(model_t), intent(in) :: model integer, intent(in), optional :: unit logical, intent(in), optional :: follow_link call var_list_write (model%var_list, unit, follow_link) end subroutine model_write_var_list @ %def model_write_var_list @ Link a variable list to the model variables. <>= procedure :: link_var_list => model_link_var_list <>= subroutine model_link_var_list (model, var_list) class(model_t), intent(inout) :: model type(var_list_t), intent(in), target :: var_list call model%var_list%link (var_list) end subroutine model_link_var_list @ %def model_link_var_list @ Check if the model contains a named variable. <>= procedure :: var_exists => model_var_exists <>= function model_var_exists (model, name) result (flag) class(model_t), intent(in) :: model type(string_t), intent(in) :: name logical :: flag flag = model%var_list%contains (name, follow_link=.false.) end function model_var_exists @ %def model_var_exists @ Check if the model variable is a derived parameter, i.e., locked. <>= procedure :: var_is_locked => model_var_is_locked <>= function model_var_is_locked (model, name) result (flag) class(model_t), intent(in) :: model type(string_t), intent(in) :: name logical :: flag flag = model%var_list%is_locked (name, follow_link=.false.) end function model_var_is_locked @ %def model_var_is_locked @ Set a model parameter via the named variable. We assume that the variable exists and is writable, i.e., non-locked. We update the model and variable list, so independent and derived parameters are always synchronized. <>= procedure :: set_real => model_var_set_real <>= subroutine model_var_set_real (model, name, rval, verbose, pacified) class(model_t), intent(inout) :: model type(string_t), intent(in) :: name real(default), intent(in) :: rval logical, intent(in), optional :: verbose, pacified call model%var_list%set_real (name, rval, & is_known=.true., ignore=.false., & verbose=verbose, model_name=model%get_name (), pacified=pacified) call model%update_parameters () end subroutine model_var_set_real @ %def model_var_set_real @ Retrieve a model parameter value. <>= procedure :: get_rval => model_var_get_rval <>= function model_var_get_rval (model, name) result (rval) class(model_t), intent(in) :: model type(string_t), intent(in) :: name real(default) :: rval rval = model%var_list%get_rval (name, follow_link=.false.) end function model_var_get_rval @ %def model_var_get_rval @ [To be deleted] Return a pointer to the variable list. <>= procedure :: get_var_list_ptr => model_get_var_list_ptr <>= function model_get_var_list_ptr (model) result (var_list) type(var_list_t), pointer :: var_list class(model_t), intent(in), target :: model var_list => model%var_list end function model_get_var_list_ptr @ %def model_get_var_list_ptr @ \subsection{UFO models} A single flag identifies a model as a UFO model. There is no other distinction, but the flag allows us to handle built-in and UFO models with the same name in parallel. <>= procedure :: is_ufo_model => model_is_ufo_model <>= function model_is_ufo_model (model) result (flag) class(model_t), intent(in) :: model logical :: flag flag = model%ufo_model end function model_is_ufo_model @ %def model_is_ufo_model @ Return the UFO path used for fetching the UFO source. <>= procedure :: get_ufo_path => model_get_ufo_path <>= function model_get_ufo_path (model) result (path) class(model_t), intent(in) :: model type(string_t) :: path if (model%ufo_model) then path = model%ufo_path else path = "" end if end function model_get_ufo_path @ %def model_get_ufo_path @ Call OMega and generate a model file from an UFO source file. We start with a file name; the model name is expected to be the base name, stripping extensions. The path search either takes [[ufo_path_requested]], or searches first in the working directory, then in a hard-coded UFO model directory. <>= subroutine model_generate_ufo (filename, os_data, ufo_path, & ufo_path_requested) type(string_t), intent(in) :: filename type(os_data_t), intent(in) :: os_data type(string_t), intent(out) :: ufo_path type(string_t), intent(in), optional :: ufo_path_requested type(string_t) :: model_name, omega_path, ufo_dir, ufo_init logical :: exist call get_model_name (filename, model_name) call msg_message ("Model: Generating model '" // char (model_name) & // "' from UFO sources") if (present (ufo_path_requested)) then call msg_message ("Model: Searching for UFO sources in '" & // char (ufo_path_requested) // "'") ufo_path = ufo_path_requested ufo_dir = ufo_path_requested // "/" // model_name ufo_init = ufo_dir // "/" // "__init__.py" inquire (file = char (ufo_init), exist = exist) else call msg_message ("Model: Searching for UFO sources in & &working directory") ufo_path = "." ufo_dir = ufo_path // "/" // model_name ufo_init = ufo_dir // "/" // "__init__.py" inquire (file = char (ufo_init), exist = exist) if (.not. exist) then ufo_path = char (os_data%whizard_modelpath_ufo) ufo_dir = ufo_path // "/" // model_name ufo_init = ufo_dir // "/" // "__init__.py" call msg_message ("Model: Searching for UFO sources in '" & // char (os_data%whizard_modelpath_ufo) // "'") inquire (file = char (ufo_init), exist = exist) end if end if if (exist) then call msg_message ("Model: Found UFO sources for model '" & // char (model_name) // "'") else call msg_fatal ("Model: UFO sources for model '" & // char (model_name) // "' not found") end if omega_path = os_data%whizard_omega_binpath // "/omega_UFO.opt" call os_system_call (omega_path & // " -model:UFO_dir " // ufo_dir & + // " -model:exec" & // " -model:write_WHIZARD" & // " > " // filename) inquire (file = char (filename), exist = exist) if (exist) then call msg_message ("Model: Model file '" // char (filename) //& "' generated") else call msg_fatal ("Model: Model file '" // char (filename) & // "' could not be generated") end if contains subroutine get_model_name (filename, model_name) type(string_t), intent(in) :: filename type(string_t), intent(out) :: model_name type(string_t) :: string string = filename call split (string, model_name, ".") end subroutine get_model_name end subroutine model_generate_ufo @ %def model_generate_ufo @ \subsection{Scheme handling} A model can specify a set of allowed schemes that steer the setup of model variables. The model file can contain scheme-specific declarations that are selected by a [[select scheme]] clause. Scheme support is optional. If enabled, the model object contains a list of allowed schemes, and the model reader takes the active scheme as an argument. After the model has been read, the scheme is fixed and can no longer be modified. The model supports schemes if the scheme array is allocated. <>= procedure :: has_schemes => model_has_schemes <>= function model_has_schemes (model) result (flag) logical :: flag class(model_t), intent(in) :: model flag = allocated (model%schemes) end function model_has_schemes @ %def model_has_schemes @ Enable schemes: fix the list of allowed schemes. <>= procedure :: enable_schemes => model_enable_schemes <>= subroutine model_enable_schemes (model, scheme) class(model_t), intent(inout) :: model type(string_t), dimension(:), intent(in) :: scheme allocate (model%schemes (size (scheme)), source = scheme) end subroutine model_enable_schemes @ %def model_enable_schemes @ Find the scheme. Check if the scheme is allowed. The numeric index of the selected scheme is stored in the [[model_data_t]] base object. If no argument is given, select the first scheme. The numeric scheme ID will then be $1$, while a model without schemes retains $0$. <>= procedure :: set_scheme => model_set_scheme <>= subroutine model_set_scheme (model, scheme) class(model_t), intent(inout) :: model type(string_t), intent(in), optional :: scheme logical :: ok integer :: i if (model%has_schemes ()) then if (present (scheme)) then ok = .false. CHECK_SCHEME: do i = 1, size (model%schemes) if (scheme == model%schemes(i)) then allocate (model%selected_scheme, source = scheme) call model%set_scheme_num (i) ok = .true. exit CHECK_SCHEME end if end do CHECK_SCHEME if (.not. ok) then call msg_fatal & ("Model '" // char (model%get_name ()) & // "': scheme '" // char (scheme) // "' not supported") end if else allocate (model%selected_scheme, source = model%schemes(1)) call model%set_scheme_num (1) end if else if (present (scheme)) then call msg_error & ("Model '" // char (model%get_name ()) & // "' does not support schemes") end if end if end subroutine model_set_scheme @ %def model_set_scheme @ Get the scheme. Note that the base [[model_data_t]] provides a [[get_scheme_num]] getter function. <>= procedure :: get_scheme => model_get_scheme <>= function model_get_scheme (model) result (scheme) class(model_t), intent(in) :: model type(string_t) :: scheme if (allocated (model%selected_scheme)) then scheme = model%selected_scheme else scheme = "" end if end function model_get_scheme @ %def model_get_scheme @ Check if a model has been set up with a specific name and (if applicable) scheme. This helps in determining whether we need a new model object. A UFO model is considered to be distinct from a non-UFO model. We assume that if [[ufo]] is asked for, there is no scheme argument. Furthermore, if there is an [[ufo_path]] requested, it must coincide with the [[ufo_path]] of the model. If not, the model [[ufo_path]] is not checked. <>= procedure :: matches => model_matches <>= function model_matches (model, name, scheme, ufo, ufo_path) result (flag) logical :: flag class(model_t), intent(in) :: model type(string_t), intent(in) :: name type(string_t), intent(in), optional :: scheme logical, intent(in), optional :: ufo type(string_t), intent(in), optional :: ufo_path logical :: ufo_model ufo_model = .false.; if (present (ufo)) ufo_model = ufo if (name /= model%get_name ()) then flag = .false. else if (ufo_model .neqv. model%is_ufo_model ()) then flag = .false. else if (ufo_model) then if (present (ufo_path)) then flag = model%get_ufo_path () == ufo_path else flag = .true. end if else if (model%has_schemes ()) then if (present (scheme)) then flag = model%get_scheme () == scheme else flag = model%get_scheme_num () == 1 end if else if (present (scheme)) then flag = .false. else flag = .true. end if end function model_matches @ %def model_matches @ \subsection{Reading models from file} This procedure defines the model-file syntax for the parser, returning an internal file (ifile). Note that arithmetic operators are defined as keywords in the expression syntax, so we exclude them here. <>= subroutine define_model_file_syntax (ifile) type(ifile_t), intent(inout) :: ifile call ifile_append (ifile, "SEQ model_def = model_name_def " // & "scheme_header parameters external_pars particles vertices") call ifile_append (ifile, "SEQ model_name_def = model model_name") call ifile_append (ifile, "KEY model") call ifile_append (ifile, "QUO model_name = '""'...'""'") call ifile_append (ifile, "SEQ scheme_header = scheme_decl?") call ifile_append (ifile, "SEQ scheme_decl = schemes '=' scheme_list") call ifile_append (ifile, "KEY schemes") call ifile_append (ifile, "LIS scheme_list = scheme_name+") call ifile_append (ifile, "QUO scheme_name = '""'...'""'") call ifile_append (ifile, "SEQ parameters = generic_par_def*") call ifile_append (ifile, "ALT generic_par_def = & ¶meter_def | derived_def | unused_def | scheme_block") call ifile_append (ifile, "SEQ parameter_def = parameter par_name " // & "'=' any_real_value") call ifile_append (ifile, "ALT any_real_value = " & // "neg_real_value | pos_real_value | real_value") call ifile_append (ifile, "SEQ neg_real_value = '-' real_value") call ifile_append (ifile, "SEQ pos_real_value = '+' real_value") call ifile_append (ifile, "KEY parameter") call ifile_append (ifile, "IDE par_name") ! call ifile_append (ifile, "KEY '='") !!! Key already exists call ifile_append (ifile, "SEQ derived_def = derived par_name " // & "'=' expr") call ifile_append (ifile, "KEY derived") call ifile_append (ifile, "SEQ unused_def = unused par_name") call ifile_append (ifile, "KEY unused") call ifile_append (ifile, "SEQ external_pars = external_def*") call ifile_append (ifile, "SEQ external_def = external par_name") call ifile_append (ifile, "KEY external") call ifile_append (ifile, "SEQ scheme_block = & &scheme_block_beg scheme_block_body scheme_block_end") call ifile_append (ifile, "SEQ scheme_block_beg = select scheme") call ifile_append (ifile, "SEQ scheme_block_body = scheme_block_case*") call ifile_append (ifile, "SEQ scheme_block_case = & &scheme scheme_id parameters") call ifile_append (ifile, "ALT scheme_id = scheme_list | other") call ifile_append (ifile, "SEQ scheme_block_end = end select") call ifile_append (ifile, "KEY select") call ifile_append (ifile, "KEY scheme") call ifile_append (ifile, "KEY other") call ifile_append (ifile, "KEY end") call ifile_append (ifile, "SEQ particles = particle_def*") call ifile_append (ifile, "SEQ particle_def = particle name_def " // & "prt_pdg prt_details") call ifile_append (ifile, "KEY particle") call ifile_append (ifile, "INT prt_pdg") call ifile_append (ifile, "ALT prt_details = prt_src | prt_properties") call ifile_append (ifile, "SEQ prt_src = like name_def prt_properties") call ifile_append (ifile, "KEY like") call ifile_append (ifile, "SEQ prt_properties = prt_property*") call ifile_append (ifile, "ALT prt_property = " // & "parton | invisible | gauge | left | right | " // & "prt_name | prt_anti | prt_tex_name | prt_tex_anti | " // & "prt_spin | prt_isospin | prt_charge | " // & "prt_color | prt_mass | prt_width") call ifile_append (ifile, "KEY parton") call ifile_append (ifile, "KEY invisible") call ifile_append (ifile, "KEY gauge") call ifile_append (ifile, "KEY left") call ifile_append (ifile, "KEY right") call ifile_append (ifile, "SEQ prt_name = name name_def+") call ifile_append (ifile, "SEQ prt_anti = anti name_def+") call ifile_append (ifile, "SEQ prt_tex_name = tex_name name_def") call ifile_append (ifile, "SEQ prt_tex_anti = tex_anti name_def") call ifile_append (ifile, "KEY name") call ifile_append (ifile, "KEY anti") call ifile_append (ifile, "KEY tex_name") call ifile_append (ifile, "KEY tex_anti") call ifile_append (ifile, "ALT name_def = name_string | name_id") call ifile_append (ifile, "QUO name_string = '""'...'""'") call ifile_append (ifile, "IDE name_id") call ifile_append (ifile, "SEQ prt_spin = spin frac") call ifile_append (ifile, "KEY spin") call ifile_append (ifile, "SEQ prt_isospin = isospin frac") call ifile_append (ifile, "KEY isospin") call ifile_append (ifile, "SEQ prt_charge = charge frac") call ifile_append (ifile, "KEY charge") call ifile_append (ifile, "SEQ prt_color = color integer_literal") call ifile_append (ifile, "KEY color") call ifile_append (ifile, "SEQ prt_mass = mass par_name") call ifile_append (ifile, "KEY mass") call ifile_append (ifile, "SEQ prt_width = width par_name") call ifile_append (ifile, "KEY width") call ifile_append (ifile, "SEQ vertices = vertex_def*") call ifile_append (ifile, "SEQ vertex_def = vertex name_def+") call ifile_append (ifile, "KEY vertex") call define_expr_syntax (ifile, particles=.false., analysis=.false.) end subroutine define_model_file_syntax @ %def define_model_file_syntax @ The model-file syntax and lexer are fixed, therefore stored as module variables: <>= type(syntax_t), target, save :: syntax_model_file @ %def syntax_model_file <>= public :: syntax_model_file_init <>= subroutine syntax_model_file_init () type(ifile_t) :: ifile call define_model_file_syntax (ifile) call syntax_init (syntax_model_file, ifile) call ifile_final (ifile) end subroutine syntax_model_file_init @ %def syntax_model_file_init <>= subroutine lexer_init_model_file (lexer) type(lexer_t), intent(out) :: lexer call lexer_init (lexer, & comment_chars = "#!", & quote_chars = '"{', & quote_match = '"}', & single_chars = ":(),", & special_class = [ "+-*/^", "<>= " ] , & keyword_list = syntax_get_keyword_list_ptr (syntax_model_file)) end subroutine lexer_init_model_file @ %def lexer_init_model_file <>= public :: syntax_model_file_final <>= subroutine syntax_model_file_final () call syntax_final (syntax_model_file) end subroutine syntax_model_file_final @ %def syntax_model_file_final <>= public :: syntax_model_file_write <>= subroutine syntax_model_file_write (unit) integer, intent(in), optional :: unit call syntax_write (syntax_model_file, unit) end subroutine syntax_model_file_write @ %def syntax_model_file_write @ Read a model from file. Handle all syntax and respect the provided scheme. The [[ufo]] flag just says that the model object should be tagged as being derived from an UFO model. The UFO model path may be requested by the caller. If not, we use a standard path search for UFO models. There is no difference in the contents of the file or the generated model object. <>= procedure :: read => model_read <>= subroutine model_read (model, filename, os_data, exist, & scheme, ufo, ufo_path_requested, rebuild_mdl) class(model_t), intent(out), target :: model type(string_t), intent(in) :: filename type(os_data_t), intent(in) :: os_data logical, intent(out), optional :: exist type(string_t), intent(in), optional :: scheme logical, intent(in), optional :: ufo type(string_t), intent(in), optional :: ufo_path_requested logical, intent(in), optional :: rebuild_mdl type(string_t) :: file type(stream_t), target :: stream type(lexer_t) :: lexer integer :: unit character(32) :: model_md5sum type(parse_node_t), pointer :: nd_model_def, nd_model_name_def type(parse_node_t), pointer :: nd_schemes, nd_scheme_decl type(parse_node_t), pointer :: nd_parameters type(parse_node_t), pointer :: nd_external_pars type(parse_node_t), pointer :: nd_particles, nd_vertices type(string_t) :: model_name, lib_name integer :: n_parblock, n_par, i_par, n_ext, n_prt, n_vtx type(parse_node_t), pointer :: nd_par_def type(parse_node_t), pointer :: nd_ext_def type(parse_node_t), pointer :: nd_prt type(parse_node_t), pointer :: nd_vtx logical :: ufo_model, model_exist, rebuild ufo_model = .false.; if (present (ufo)) ufo_model = ufo rebuild = .true.; if (present (rebuild_mdl)) rebuild = rebuild_mdl file = filename inquire (file=char(file), exist=model_exist) if ((.not. model_exist) .and. (.not. os_data%use_testfiles)) then file = os_data%whizard_modelpath_local // "/" // filename inquire (file = char (file), exist = model_exist) end if if (.not. model_exist) then file = os_data%whizard_modelpath // "/" // filename inquire (file = char (file), exist = model_exist) end if if (ufo_model .and. rebuild) then file = filename call model_generate_ufo (filename, os_data, model%ufo_path, & ufo_path_requested=ufo_path_requested) inquire (file = char (file), exist = model_exist) end if if (.not. model_exist) then call msg_fatal ("Model file '" // char (filename) // "' not found") if (present (exist)) exist = .false. return end if if (present (exist)) exist = .true. if (logging) call msg_message ("Reading model file '" // char (file) // "'") unit = free_unit () open (file=char(file), unit=unit, action="read", status="old") model_md5sum = md5sum (unit) close (unit) call lexer_init_model_file (lexer) call stream_init (stream, char (file)) call lexer_assign_stream (lexer, stream) call parse_tree_init (model%parse_tree, syntax_model_file, lexer) call stream_final (stream) call lexer_final (lexer) nd_model_def => model%parse_tree%get_root_ptr () nd_model_name_def => parse_node_get_sub_ptr (nd_model_def) model_name = parse_node_get_string & (parse_node_get_sub_ptr (nd_model_name_def, 2)) nd_schemes => nd_model_name_def%get_next_ptr () call find_block & ("scheme_header", nd_schemes, nd_scheme_decl, nd_next=nd_parameters) call find_block & ("parameters", nd_parameters, nd_par_def, n_parblock, nd_external_pars) call find_block & ("external_pars", nd_external_pars, nd_ext_def, n_ext, nd_particles) call find_block & ("particles", nd_particles, nd_prt, n_prt, nd_vertices) call find_block & ("vertices", nd_vertices, nd_vtx, n_vtx) if (associated (nd_external_pars)) then lib_name = "external." // model_name else lib_name = "" end if if (associated (nd_scheme_decl)) then call handle_schemes (nd_scheme_decl, scheme) end if n_par = 0 call count_parameters (nd_par_def, n_parblock, n_par) call model%init & (model_name, lib_name, os_data, n_par + n_ext, n_prt, n_vtx, ufo) model%md5sum = model_md5sum if (associated (nd_par_def)) then i_par = 0 call handle_parameters (nd_par_def, n_parblock, i_par) end if if (associated (nd_ext_def)) then call handle_external (nd_ext_def, n_par, n_ext) end if call model%update_parameters () if (associated (nd_prt)) then call handle_fields (nd_prt, n_prt) end if if (associated (nd_vtx)) then call handle_vertices (nd_vtx, n_vtx) end if call model%freeze_vertices () call model%append_field_vars () contains subroutine find_block (key, nd, nd_item, n_item, nd_next) character(*), intent(in) :: key type(parse_node_t), pointer, intent(inout) :: nd type(parse_node_t), pointer, intent(out) :: nd_item integer, intent(out), optional :: n_item type(parse_node_t), pointer, intent(out), optional :: nd_next if (associated (nd)) then if (nd%get_rule_key () == key) then nd_item => nd%get_sub_ptr () if (present (n_item)) n_item = nd%get_n_sub () if (present (nd_next)) nd_next => nd%get_next_ptr () else nd_item => null () if (present (n_item)) n_item = 0 if (present (nd_next)) nd_next => nd nd => null () end if else nd_item => null () if (present (n_item)) n_item = 0 if (present (nd_next)) nd_next => null () end if end subroutine find_block subroutine handle_schemes (nd_scheme_decl, scheme) type(parse_node_t), pointer, intent(in) :: nd_scheme_decl type(string_t), intent(in), optional :: scheme type(parse_node_t), pointer :: nd_list, nd_entry type(string_t), dimension(:), allocatable :: schemes integer :: i, n_schemes nd_list => nd_scheme_decl%get_sub_ptr (3) nd_entry => nd_list%get_sub_ptr () n_schemes = nd_list%get_n_sub () allocate (schemes (n_schemes)) do i = 1, n_schemes schemes(i) = nd_entry%get_string () nd_entry => nd_entry%get_next_ptr () end do if (present (scheme)) then do i = 1, n_schemes if (schemes(i) == scheme) goto 10 ! block exit end do call msg_fatal ("Scheme '" // char (scheme) & // "' is not supported by model '" // char (model_name) // "'") end if 10 continue call model%enable_schemes (schemes) call model%set_scheme (scheme) end subroutine handle_schemes subroutine select_scheme (nd_scheme_block, n_parblock_sub, nd_par_def) type(parse_node_t), pointer, intent(in) :: nd_scheme_block integer, intent(out) :: n_parblock_sub type(parse_node_t), pointer, intent(out) :: nd_par_def type(parse_node_t), pointer :: nd_scheme_body type(parse_node_t), pointer :: nd_scheme_case, nd_scheme_id, nd_scheme type(string_t) :: scheme integer :: n_cases, i scheme = model%get_scheme () nd_scheme_body => nd_scheme_block%get_sub_ptr (2) nd_parameters => null () select case (char (nd_scheme_body%get_rule_key ())) case ("scheme_block_body") n_cases = nd_scheme_body%get_n_sub () FIND_SCHEME: do i = 1, n_cases nd_scheme_case => nd_scheme_body%get_sub_ptr (i) nd_scheme_id => nd_scheme_case%get_sub_ptr (2) select case (char (nd_scheme_id%get_rule_key ())) case ("scheme_list") nd_scheme => nd_scheme_id%get_sub_ptr () do while (associated (nd_scheme)) if (scheme == nd_scheme%get_string ()) then nd_parameters => nd_scheme_id%get_next_ptr () exit FIND_SCHEME end if nd_scheme => nd_scheme%get_next_ptr () end do case ("other") nd_parameters => nd_scheme_id%get_next_ptr () exit FIND_SCHEME case default print *, "'", char (nd_scheme_id%get_rule_key ()), "'" call msg_bug ("Model read: impossible scheme rule") end select end do FIND_SCHEME end select if (associated (nd_parameters)) then select case (char (nd_parameters%get_rule_key ())) case ("parameters") n_parblock_sub = nd_parameters%get_n_sub () if (n_parblock_sub > 0) then nd_par_def => nd_parameters%get_sub_ptr () else nd_par_def => null () end if case default n_parblock_sub = 0 nd_par_def => null () end select else n_parblock_sub = 0 nd_par_def => null () end if end subroutine select_scheme recursive subroutine count_parameters (nd_par_def_in, n_parblock, n_par) type(parse_node_t), pointer, intent(in) :: nd_par_def_in integer, intent(in) :: n_parblock integer, intent(inout) :: n_par type(parse_node_t), pointer :: nd_par_def, nd_par_key type(parse_node_t), pointer :: nd_par_def_sub integer :: n_parblock_sub integer :: i nd_par_def => nd_par_def_in do i = 1, n_parblock nd_par_key => nd_par_def%get_sub_ptr () select case (char (nd_par_key%get_rule_key ())) case ("parameter", "derived", "unused") n_par = n_par + 1 case ("scheme_block_beg") call select_scheme (nd_par_def, n_parblock_sub, nd_par_def_sub) if (n_parblock_sub > 0) then call count_parameters (nd_par_def_sub, n_parblock_sub, n_par) end if case default print *, "'", char (nd_par_key%get_rule_key ()), "'" call msg_bug ("Model read: impossible parameter rule") end select nd_par_def => parse_node_get_next_ptr (nd_par_def) end do end subroutine count_parameters recursive subroutine handle_parameters (nd_par_def_in, n_parblock, i_par) type(parse_node_t), pointer, intent(in) :: nd_par_def_in integer, intent(in) :: n_parblock integer, intent(inout) :: i_par type(parse_node_t), pointer :: nd_par_def, nd_par_key type(parse_node_t), pointer :: nd_par_def_sub integer :: n_parblock_sub integer :: i nd_par_def => nd_par_def_in do i = 1, n_parblock nd_par_key => nd_par_def%get_sub_ptr () select case (char (nd_par_key%get_rule_key ())) case ("parameter") i_par = i_par + 1 call model%read_parameter (i_par, nd_par_def) case ("derived") i_par = i_par + 1 call model%read_derived (i_par, nd_par_def) case ("unused") i_par = i_par + 1 call model%read_unused (i_par, nd_par_def) case ("scheme_block_beg") call select_scheme (nd_par_def, n_parblock_sub, nd_par_def_sub) if (n_parblock_sub > 0) then call handle_parameters (nd_par_def_sub, n_parblock_sub, i_par) end if end select nd_par_def => parse_node_get_next_ptr (nd_par_def) end do end subroutine handle_parameters subroutine handle_external (nd_ext_def, n_par, n_ext) type(parse_node_t), pointer, intent(inout) :: nd_ext_def integer, intent(in) :: n_par, n_ext integer :: i do i = n_par + 1, n_par + n_ext call model%read_external (i, nd_ext_def) nd_ext_def => parse_node_get_next_ptr (nd_ext_def) end do ! real(c_default_float), dimension(:), allocatable :: par ! if (associated (model%init_external_parameters)) then ! allocate (par (model%get_n_real ())) ! call model%real_parameters_to_c_array (par) ! call model%init_external_parameters (par) ! call model%real_parameters_from_c_array (par) ! end if end subroutine handle_external subroutine handle_fields (nd_prt, n_prt) type(parse_node_t), pointer, intent(inout) :: nd_prt integer, intent(in) :: n_prt integer :: i do i = 1, n_prt call model%read_field (i, nd_prt) nd_prt => parse_node_get_next_ptr (nd_prt) end do end subroutine handle_fields subroutine handle_vertices (nd_vtx, n_vtx) type(parse_node_t), pointer, intent(inout) :: nd_vtx integer, intent(in) :: n_vtx integer :: i do i = 1, n_vtx call model%read_vertex (i, nd_vtx) nd_vtx => parse_node_get_next_ptr (nd_vtx) end do end subroutine handle_vertices end subroutine model_read @ %def model_read @ Parameters are real values (literal) with an optional unit. <>= procedure, private :: read_parameter => model_read_parameter <>= subroutine model_read_parameter (model, i, node) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(parse_node_t), intent(in), target :: node type(parse_node_t), pointer :: node_name, node_val type(string_t) :: name node_name => parse_node_get_sub_ptr (node, 2) name = parse_node_get_string (node_name) node_val => parse_node_get_next_ptr (node_name, 2) call model%set_parameter_parse_node (i, name, node_val, constant=.true.) end subroutine model_read_parameter @ %def model_read_parameter @ Derived parameters have any numeric expression as their definition. Don't evaluate the expression, yet. <>= procedure, private :: read_derived => model_read_derived <>= subroutine model_read_derived (model, i, node) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(parse_node_t), intent(in), target :: node type(string_t) :: name type(parse_node_t), pointer :: pn_expr name = parse_node_get_string (parse_node_get_sub_ptr (node, 2)) pn_expr => parse_node_get_sub_ptr (node, 4) call model%set_parameter_parse_node (i, name, pn_expr, constant=.false.) end subroutine model_read_derived @ %def model_read_derived @ External parameters have no definition; they are handled by an external library. <>= procedure, private :: read_external => model_read_external <>= subroutine model_read_external (model, i, node) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(parse_node_t), intent(in), target :: node type(string_t) :: name name = parse_node_get_string (parse_node_get_sub_ptr (node, 2)) call model%set_parameter_external (i, name) end subroutine model_read_external @ %def model_read_external @ Ditto for unused parameters, they are there just for reserving the name. <>= procedure, private :: read_unused => model_read_unused <>= subroutine model_read_unused (model, i, node) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(parse_node_t), intent(in), target :: node type(string_t) :: name name = parse_node_get_string (parse_node_get_sub_ptr (node, 2)) call model%set_parameter_unused (i, name) end subroutine model_read_unused @ %def model_read_unused <>= procedure, private :: read_field => model_read_field <>= subroutine model_read_field (model, i, node) class(model_t), intent(inout), target :: model integer, intent(in) :: i type(parse_node_t), intent(in) :: node type(parse_node_t), pointer :: nd_src, nd_props, nd_prop type(string_t) :: longname integer :: pdg type(string_t) :: name_src type(string_t), dimension(:), allocatable :: name type(field_data_t), pointer :: field, field_src longname = parse_node_get_string (parse_node_get_sub_ptr (node, 2)) pdg = parse_node_get_integer (parse_node_get_sub_ptr (node, 3)) field => model%get_field_ptr_by_index (i) call field%init (longname, pdg) nd_src => parse_node_get_sub_ptr (node, 4) if (associated (nd_src)) then if (parse_node_get_rule_key (nd_src) == "prt_src") then name_src = parse_node_get_string (parse_node_get_sub_ptr (nd_src, 2)) field_src => model%get_field_ptr (name_src, check=.true.) call field%copy_from (field_src) nd_props => parse_node_get_sub_ptr (nd_src, 3) else nd_props => nd_src end if nd_prop => parse_node_get_sub_ptr (nd_props) do while (associated (nd_prop)) select case (char (parse_node_get_rule_key (nd_prop))) case ("invisible") call field%set (is_visible=.false.) case ("parton") call field%set (is_parton=.true.) case ("gauge") call field%set (is_gauge=.true.) case ("left") call field%set (is_left_handed=.true.) case ("right") call field%set (is_right_handed=.true.) case ("prt_name") call read_names (nd_prop, name) call field%set (name=name) case ("prt_anti") call read_names (nd_prop, name) call field%set (anti=name) case ("prt_tex_name") call field%set ( & tex_name = parse_node_get_string & (parse_node_get_sub_ptr (nd_prop, 2))) case ("prt_tex_anti") call field%set ( & tex_anti = parse_node_get_string & (parse_node_get_sub_ptr (nd_prop, 2))) case ("prt_spin") call field%set ( & spin_type = read_frac & (parse_node_get_sub_ptr (nd_prop, 2), 2)) case ("prt_isospin") call field%set ( & isospin_type = read_frac & (parse_node_get_sub_ptr (nd_prop, 2), 2)) case ("prt_charge") call field%set ( & charge_type = read_frac & (parse_node_get_sub_ptr (nd_prop, 2), 3)) case ("prt_color") call field%set ( & color_type = parse_node_get_integer & (parse_node_get_sub_ptr (nd_prop, 2))) case ("prt_mass") call field%set ( & mass_data = model%get_par_data_ptr & (parse_node_get_string & (parse_node_get_sub_ptr (nd_prop, 2)))) case ("prt_width") call field%set ( & width_data = model%get_par_data_ptr & (parse_node_get_string & (parse_node_get_sub_ptr (nd_prop, 2)))) case default call msg_bug (" Unknown particle property '" & // char (parse_node_get_rule_key (nd_prop)) // "'") end select if (allocated (name)) deallocate (name) nd_prop => parse_node_get_next_ptr (nd_prop) end do end if call field%freeze () end subroutine model_read_field @ %def model_read_field <>= procedure, private :: read_vertex => model_read_vertex <>= subroutine model_read_vertex (model, i, node) class(model_t), intent(inout) :: model integer, intent(in) :: i type(parse_node_t), intent(in) :: node type(string_t), dimension(:), allocatable :: name call read_names (node, name) call model%set_vertex (i, name) end subroutine model_read_vertex @ %def model_read_vertex <>= subroutine read_names (node, name) type(parse_node_t), intent(in) :: node type(string_t), dimension(:), allocatable, intent(inout) :: name type(parse_node_t), pointer :: nd_name integer :: n_names, i n_names = parse_node_get_n_sub (node) - 1 allocate (name (n_names)) nd_name => parse_node_get_sub_ptr (node, 2) do i = 1, n_names name(i) = parse_node_get_string (nd_name) nd_name => parse_node_get_next_ptr (nd_name) end do end subroutine read_names @ %def read_names <>= function read_frac (nd_frac, base) result (qn_type) integer :: qn_type type(parse_node_t), intent(in) :: nd_frac integer, intent(in) :: base type(parse_node_t), pointer :: nd_num, nd_den integer :: num, den nd_num => parse_node_get_sub_ptr (nd_frac) nd_den => parse_node_get_next_ptr (nd_num) select case (char (parse_node_get_rule_key (nd_num))) case ("integer_literal") num = parse_node_get_integer (nd_num) case ("neg_int") num = - parse_node_get_integer (parse_node_get_sub_ptr (nd_num, 2)) case ("pos_int") num = parse_node_get_integer (parse_node_get_sub_ptr (nd_num, 2)) case default call parse_tree_bug (nd_num, "int|neg_int|pos_int") end select if (associated (nd_den)) then den = parse_node_get_integer (parse_node_get_sub_ptr (nd_den, 2)) else den = 1 end if if (den == 1) then qn_type = sign (1 + abs (num) * base, num) else if (den == base) then qn_type = sign (abs (num) + 1, num) else call parse_node_write_rec (nd_frac) call msg_fatal (" Fractional quantum number: wrong denominator") end if end function read_frac @ %def read_frac @ Append field (PDG-array) variables to the variable list, based on the field content. <>= procedure, private :: append_field_vars => model_append_field_vars <>= subroutine model_append_field_vars (model) class(model_t), intent(inout) :: model type(pdg_array_t) :: aval type(field_data_t), dimension(:), pointer :: field_array type(field_data_t), pointer :: field type(string_t) :: name type(string_t), dimension(:), allocatable :: name_array integer, dimension(:), allocatable :: pdg logical, dimension(:), allocatable :: mask integer :: i, j field_array => model%get_field_array_ptr () aval = UNDEFINED call var_list_append_pdg_array & (model%var_list, var_str ("particle"), & aval, locked = .true., intrinsic=.true.) do i = 1, size (field_array) aval = field_array(i)%get_pdg () name = field_array(i)%get_longname () call var_list_append_pdg_array & (model%var_list, name, aval, locked=.true., intrinsic=.true.) call field_array(i)%get_name_array (.false., name_array) do j = 1, size (name_array) call var_list_append_pdg_array & (model%var_list, name_array(j), & aval, locked=.true., intrinsic=.true.) end do model%max_field_name_length = & max (model%max_field_name_length, len (name_array(1))) aval = - field_array(i)%get_pdg () call field_array(i)%get_name_array (.true., name_array) do j = 1, size (name_array) call var_list_append_pdg_array & (model%var_list, name_array(j), & aval, locked=.true., intrinsic=.true.) end do if (size (name_array) > 0) then model%max_field_name_length = & max (model%max_field_name_length, len (name_array(1))) end if end do call model%get_all_pdg (pdg) allocate (mask (size (pdg))) do i = 1, size (pdg) field => model%get_field_ptr (pdg(i)) mask(i) = field%get_charge_type () /= 1 end do aval = pack (pdg, mask) call var_list_append_pdg_array & (model%var_list, var_str ("charged"), & aval, locked = .true., intrinsic=.true.) do i = 1, size (pdg) field => model%get_field_ptr (pdg(i)) mask(i) = field%get_charge_type () == 1 end do aval = pack (pdg, mask) call var_list_append_pdg_array & (model%var_list, var_str ("neutral"), & aval, locked = .true., intrinsic=.true.) do i = 1, size (pdg) field => model%get_field_ptr (pdg(i)) mask(i) = field%get_color_type () /= 1 end do aval = pack (pdg, mask) call var_list_append_pdg_array & (model%var_list, var_str ("colored"), & aval, locked = .true., intrinsic=.true.) end subroutine model_append_field_vars @ %def model_append_field_vars @ \subsection{Test models} <>= public :: create_test_model <>= subroutine create_test_model (model_name, test_model) type(string_t), intent(in) :: model_name type(model_t), intent(out), pointer :: test_model type(os_data_t) :: os_data type(model_list_t) :: model_list call syntax_model_file_init () call os_data%init () call model_list%read_model & (model_name, model_name // var_str (".mdl"), os_data, test_model) end subroutine create_test_model @ %def create_test_model @ \subsection{Model list} List of currently active models <>= type, extends (model_t) :: model_entry_t type(model_entry_t), pointer :: next => null () end type model_entry_t @ %def model_entry_t <>= public :: model_list_t <>= type :: model_list_t type(model_entry_t), pointer :: first => null () type(model_entry_t), pointer :: last => null () type(model_list_t), pointer :: context => null () contains <> end type model_list_t @ %def model_list_t @ Write an account of the model list. We write linked lists first, starting from the global context. <>= procedure :: write => model_list_write <>= recursive subroutine model_list_write (object, unit, verbose, follow_link) class(model_list_t), intent(in) :: object integer, intent(in), optional :: unit logical, intent(in), optional :: verbose logical, intent(in), optional :: follow_link type(model_entry_t), pointer :: current logical :: rec integer :: u u = given_output_unit (unit); if (u < 0) return rec = .true.; if (present (follow_link)) rec = follow_link if (rec .and. associated (object%context)) then call object%context%write (unit, verbose, follow_link) end if current => object%first if (associated (current)) then do while (associated (current)) call current%write (unit, verbose) current => current%next if (associated (current)) write (u, *) end do end if end subroutine model_list_write @ %def model_list_write @ Link this list to another one. <>= procedure :: link => model_list_link <>= subroutine model_list_link (model_list, context) class(model_list_t), intent(inout) :: model_list type(model_list_t), intent(in), target :: context model_list%context => context end subroutine model_list_link @ %def model_list_link @ (Private, used below:) Append an existing model, for which we have allocated a pointer entry, to the model list. The original pointer becomes disassociated, and the model should now be considered as part of the list. We assume that this model is not yet part of the list. If we provide a [[model]] argument, this returns a pointer to the new entry. <>= procedure, private :: import => model_list_import <>= subroutine model_list_import (model_list, current, model) class(model_list_t), intent(inout) :: model_list type(model_entry_t), pointer, intent(inout) :: current type(model_t), optional, pointer, intent(out) :: model if (associated (current)) then if (associated (model_list%first)) then model_list%last%next => current else model_list%first => current end if model_list%last => current if (present (model)) model => current%model_t current => null () end if end subroutine model_list_import @ %def model_list_import @ Currently test only: Add a new model with given [[name]] to the list, if it does not yet exist. If successful, return a pointer to the new model. <>= procedure :: add => model_list_add <>= subroutine model_list_add (model_list, & name, os_data, n_par, n_prt, n_vtx, model) class(model_list_t), intent(inout) :: model_list type(string_t), intent(in) :: name type(os_data_t), intent(in) :: os_data integer, intent(in) :: n_par, n_prt, n_vtx type(model_t), pointer :: model type(model_entry_t), pointer :: current if (model_list%model_exists (name, follow_link=.false.)) then model => null () else allocate (current) call current%init (name, var_str (""), os_data, & n_par, n_prt, n_vtx) call model_list%import (current, model) end if end subroutine model_list_add @ %def model_list_add @ Read a new model from file and add to the list, if it does not yet exist. Finalize the model by allocating the vertex table. Return a pointer to the new model. If unsuccessful, return the original pointer. The model is always inserted in the last link of a chain of model lists. This way, we avoid loading models twice from different contexts. When a model is modified, we should first allocate a local copy. <>= procedure :: read_model => model_list_read_model <>= subroutine model_list_read_model & (model_list, name, filename, os_data, model, & scheme, ufo, ufo_path, rebuild_mdl) class(model_list_t), intent(inout), target :: model_list type(string_t), intent(in) :: name, filename type(os_data_t), intent(in) :: os_data type(model_t), pointer, intent(inout) :: model type(string_t), intent(in), optional :: scheme logical, intent(in), optional :: ufo type(string_t), intent(in), optional :: ufo_path logical, intent(in), optional :: rebuild_mdl class(model_list_t), pointer :: global_model_list type(model_entry_t), pointer :: current logical :: exist if (.not. model_list%model_exists (name, & scheme, ufo, ufo_path, follow_link=.true.)) then allocate (current) call current%read (filename, os_data, exist, & scheme=scheme, ufo=ufo, ufo_path_requested=ufo_path, & rebuild_mdl=rebuild_mdl) if (.not. exist) return if (current%get_name () /= name) then call msg_fatal ("Model file '" // char (filename) // & "' contains model '" // char (current%get_name ()) // & "' instead of '" // char (name) // "'") call current%final (); deallocate (current) return end if global_model_list => model_list do while (associated (global_model_list%context)) global_model_list => global_model_list%context end do call global_model_list%import (current, model) else model => model_list%get_model_ptr (name, scheme, ufo, ufo_path) end if end subroutine model_list_read_model @ %def model_list_read_model @ Append a copy of an existing model to a model list. Optionally, return pointer to the new entry. <>= procedure :: append_copy => model_list_append_copy <>= subroutine model_list_append_copy (model_list, orig, model) class(model_list_t), intent(inout) :: model_list type(model_t), intent(in), target :: orig type(model_t), intent(out), pointer, optional :: model type(model_entry_t), pointer :: copy allocate (copy) call copy%init_instance (orig) call model_list%import (copy, model) end subroutine model_list_append_copy @ %def model_list_append_copy @ Check if a model exists by examining the list. Check recursively unless told otherwise. <>= procedure :: model_exists => model_list_model_exists <>= recursive function model_list_model_exists & (model_list, name, scheme, ufo, ufo_path, follow_link) result (exists) class(model_list_t), intent(in) :: model_list logical :: exists type(string_t), intent(in) :: name type(string_t), intent(in), optional :: scheme logical, intent(in), optional :: ufo type(string_t), intent(in), optional :: ufo_path logical, intent(in), optional :: follow_link type(model_entry_t), pointer :: current logical :: rec rec = .true.; if (present (follow_link)) rec = follow_link current => model_list%first do while (associated (current)) if (current%matches (name, scheme, ufo, ufo_path)) then exists = .true. return end if current => current%next end do if (rec .and. associated (model_list%context)) then exists = model_list%context%model_exists (name, & scheme, ufo, ufo_path, follow_link) else exists = .false. end if end function model_list_model_exists @ %def model_list_model_exists @ Return a pointer to a named model. Search recursively unless told otherwise. <>= procedure :: get_model_ptr => model_list_get_model_ptr <>= recursive function model_list_get_model_ptr & (model_list, name, scheme, ufo, ufo_path, follow_link) result (model) class(model_list_t), intent(in) :: model_list type(model_t), pointer :: model type(string_t), intent(in) :: name type(string_t), intent(in), optional :: scheme logical, intent(in), optional :: ufo type(string_t), intent(in), optional :: ufo_path logical, intent(in), optional :: follow_link type(model_entry_t), pointer :: current logical :: rec rec = .true.; if (present (follow_link)) rec = follow_link current => model_list%first do while (associated (current)) if (current%matches (name, scheme, ufo, ufo_path)) then model => current%model_t return end if current => current%next end do if (rec .and. associated (model_list%context)) then model => model_list%context%get_model_ptr (name, & scheme, ufo, ufo_path, follow_link) else model => null () end if end function model_list_get_model_ptr @ %def model_list_get_model_ptr @ Delete the list of models. No recursion. <>= procedure :: final => model_list_final <>= subroutine model_list_final (model_list) class(model_list_t), intent(inout) :: model_list type(model_entry_t), pointer :: current model_list%last => null () do while (associated (model_list%first)) current => model_list%first model_list%first => model_list%first%next call current%final () deallocate (current) end do end subroutine model_list_final @ %def model_list_final @ \subsection{Model instances} A model instance is a copy of a model object. The parameters are true copies. The particle data and the variable list pointers should point to the copy, so modifying the parameters has only a local effect. Hence, we build them up explicitly. The vertex array is also rebuilt, it contains particle pointers. Finally, the vertex hash table can be copied directly since it contains no pointers. The [[multiplicity]] entry depends on the association of the [[mass_data]] entry and therefore has to be set at the end. The instance must carry the [[target]] attribute. Parameters: the [[copy_parameter]] method essentially copies the parameter decorations (parse node, expression etc.). The current parameter values are part of the [[model_data_t]] base type and are copied afterwards via its [[copy_from]] method. Note: the parameter set is initialized for real parameters only. <>= procedure :: init_instance => model_copy <>= subroutine model_copy (model, orig) class(model_t), intent(out), target :: model type(model_t), intent(in) :: orig integer :: n_par, n_prt, n_vtx integer :: i n_par = orig%get_n_real () n_prt = orig%get_n_field () n_vtx = orig%get_n_vtx () call model%basic_init (orig%get_name (), n_par, n_prt, n_vtx) if (allocated (orig%schemes)) then model%schemes = orig%schemes if (allocated (orig%selected_scheme)) then model%selected_scheme = orig%selected_scheme call model%set_scheme_num (orig%get_scheme_num ()) end if end if model%md5sum = orig%md5sum if (allocated (orig%par)) then do i = 1, n_par call model%copy_parameter (i, orig%par(i)) end do end if model%init_external_parameters => orig%init_external_parameters call model%model_data_t%copy_from (orig) model%max_par_name_length = orig%max_par_name_length call model%append_field_vars () end subroutine model_copy @ %def model_copy @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[models_ut.f90]]>>= <> module models_ut use unit_tests use models_uti <> <> contains <> end module models_ut @ %def models_ut @ <<[[models_uti.f90]]>>= <> module models_uti <> <> use file_utils, only: delete_file use physics_defs, only: SCALAR, SPINOR use os_interface use model_data use variables use models <> <> contains <> end module models_uti @ %def models_ut @ API: driver for the unit tests below. <>= public :: models_test <>= subroutine models_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine models_test @ %def models_tests @ \subsubsection{Construct a Model} Here, we construct a toy model explicitly without referring to a file. <>= call test (models_1, "models_1", & "construct model", & u, results) <>= public :: models_1 <>= subroutine models_1 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_list_t) :: model_list type(model_t), pointer :: model type(string_t) :: model_name type(string_t) :: x_longname type(string_t), dimension(2) :: parname type(string_t), dimension(2) :: x_name type(string_t), dimension(1) :: x_anti type(string_t) :: x_tex_name, x_tex_anti type(string_t) :: y_longname type(string_t), dimension(2) :: y_name type(string_t) :: y_tex_name type(field_data_t), pointer :: field write (u, "(A)") "* Test output: models_1" write (u, "(A)") "* Purpose: create a model" write (u, *) model_name = "Test model" call model_list%add (model_name, os_data, 2, 2, 3, model) parname(1) = "mx" parname(2) = "coup" call model%set_parameter_constant (1, parname(1), 10._default) call model%set_parameter_constant (2, parname(2), 1.3_default) x_longname = "X_LEPTON" x_name(1) = "X" x_name(2) = "x" x_anti(1) = "Xbar" x_tex_name = "X^+" x_tex_anti = "X^-" field => model%get_field_ptr_by_index (1) call field%init (x_longname, 99) call field%set ( & .true., .false., .false., .false., .false., & name=x_name, anti=x_anti, tex_name=x_tex_name, tex_anti=x_tex_anti, & spin_type=SPINOR, isospin_type=-3, charge_type=2, & mass_data=model%get_par_data_ptr (parname(1))) y_longname = "Y_COLORON" y_name(1) = "Y" y_name(2) = "yc" y_tex_name = "Y^0" field => model%get_field_ptr_by_index (2) call field%init (y_longname, 97) call field%set ( & .false., .false., .true., .false., .false., & name=y_name, tex_name=y_tex_name, & spin_type=SCALAR, isospin_type=2, charge_type=1, color_type=8) call model%set_vertex (1, [99, 99, 99]) call model%set_vertex (2, [99, 99, 99, 99]) call model%set_vertex (3, [99, 97, 99]) call model_list%write (u) call model_list%final () write (u, *) write (u, "(A)") "* Test output end: models_1" end subroutine models_1 @ %def models_1 @ \subsubsection{Read a Model} Read a predefined model from file. <>= call test (models_2, "models_2", & "read model", & u, results) <>= public :: models_2 <>= subroutine models_2 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_list_t) :: model_list type(var_list_t), pointer :: var_list type(model_t), pointer :: model write (u, "(A)") "* Test output: models_2" write (u, "(A)") "* Purpose: read a model from file" write (u, *) call syntax_model_file_init () call os_data%init () call model_list%read_model (var_str ("Test"), var_str ("Test.mdl"), & os_data, model) call model_list%write (u) write (u, *) write (u, "(A)") "* Variable list" write (u, *) var_list => model%get_var_list_ptr () call var_list%write (u) write (u, *) write (u, "(A)") "* Cleanup" call model_list%final () call syntax_model_file_final () write (u, *) write (u, "(A)") "* Test output end: models_2" end subroutine models_2 @ %def models_2 @ \subsubsection{Model Instance} Read a predefined model from file and create an instance. <>= call test (models_3, "models_3", & "model instance", & u, results) <>= public :: models_3 <>= subroutine models_3 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_list_t) :: model_list type(model_t), pointer :: model type(var_list_t), pointer :: var_list type(model_t), pointer :: instance write (u, "(A)") "* Test output: models_3" write (u, "(A)") "* Purpose: create a model instance" write (u, *) call syntax_model_file_init () call os_data%init () call model_list%read_model (var_str ("Test"), var_str ("Test.mdl"), & os_data, model) allocate (instance) call instance%init_instance (model) call model%write (u) write (u, *) write (u, "(A)") "* Variable list" write (u, *) var_list => instance%get_var_list_ptr () call var_list%write (u) write (u, *) write (u, "(A)") "* Cleanup" call instance%final () deallocate (instance) call model_list%final () call syntax_model_file_final () write (u, *) write (u, "(A)") "* Test output end: models_3" end subroutine models_3 @ %def models_test @ \subsubsection{Unstable and Polarized Particles} Read a predefined model from file and define decays and polarization. <>= call test (models_4, "models_4", & "handle decays and polarization", & u, results) <>= public :: models_4 <>= subroutine models_4 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_list_t) :: model_list type(model_t), pointer :: model, model_instance character(32) :: md5sum write (u, "(A)") "* Test output: models_4" write (u, "(A)") "* Purpose: set and unset decays and polarization" write (u, *) call syntax_model_file_init () call os_data%init () write (u, "(A)") "* Read model from file" call model_list%read_model (var_str ("Test"), var_str ("Test.mdl"), & os_data, model) md5sum = model%get_parameters_md5sum () write (u, *) write (u, "(1x,3A)") "MD5 sum (parameters) = '", md5sum, "'" write (u, *) write (u, "(A)") "* Set particle decays and polarization" write (u, *) call model%set_unstable (25, [var_str ("dec1"), var_str ("dec2")]) call model%set_polarized (6) call model%set_unstable (-6, [var_str ("fdec")]) call model%write (u) md5sum = model%get_parameters_md5sum () write (u, *) write (u, "(1x,3A)") "MD5 sum (parameters) = '", md5sum, "'" write (u, *) write (u, "(A)") "* Create a model instance" allocate (model_instance) call model_instance%init_instance (model) write (u, *) write (u, "(A)") "* Revert particle decays and polarization" write (u, *) call model%set_stable (25) call model%set_unpolarized (6) call model%set_stable (-6) call model%write (u) md5sum = model%get_parameters_md5sum () write (u, *) write (u, "(1x,3A)") "MD5 sum (parameters) = '", md5sum, "'" write (u, *) write (u, "(A)") "* Show the model instance" write (u, *) call model_instance%write (u) md5sum = model_instance%get_parameters_md5sum () write (u, *) write (u, "(1x,3A)") "MD5 sum (parameters) = '", md5sum, "'" write (u, *) write (u, "(A)") "* Cleanup" call model_instance%final () deallocate (model_instance) call model_list%final () call syntax_model_file_final () write (u, *) write (u, "(A)") "* Test output end: models_4" end subroutine models_4 @ %def models_4 @ \subsubsection{Model Variables} Read a predefined model from file and modify some parameters. Note that the MD5 sum is not modified by this. <>= call test (models_5, "models_5", & "handle parameters", & u, results) <>= public :: models_5 <>= subroutine models_5 (u) integer, intent(in) :: u type(os_data_t) :: os_data type(model_list_t) :: model_list type(model_t), pointer :: model, model_instance character(32) :: md5sum write (u, "(A)") "* Test output: models_5" write (u, "(A)") "* Purpose: access and modify model variables" write (u, *) call syntax_model_file_init () call os_data%init () write (u, "(A)") "* Read model from file" call model_list%read_model (var_str ("Test"), var_str ("Test.mdl"), & os_data, model) write (u, *) call model%write (u, & show_md5sum = .true., & show_variables = .true., & show_parameters = .true., & show_particles = .false., & show_vertices = .false.) write (u, *) write (u, "(A)") "* Check parameter status" write (u, *) write (u, "(1x,A,L1)") "xy exists = ", model%var_exists (var_str ("xx")) write (u, "(1x,A,L1)") "ff exists = ", model%var_exists (var_str ("ff")) write (u, "(1x,A,L1)") "mf exists = ", model%var_exists (var_str ("mf")) write (u, "(1x,A,L1)") "ff locked = ", model%var_is_locked (var_str ("ff")) write (u, "(1x,A,L1)") "mf locked = ", model%var_is_locked (var_str ("mf")) write (u, *) write (u, "(1x,A,F6.2)") "ff = ", model%get_rval (var_str ("ff")) write (u, "(1x,A,F6.2)") "mf = ", model%get_rval (var_str ("mf")) write (u, *) write (u, "(A)") "* Modify parameter" write (u, *) call model%set_real (var_str ("ff"), 1._default) call model%write (u, & show_md5sum = .true., & show_variables = .true., & show_parameters = .true., & show_particles = .false., & show_vertices = .false.) write (u, *) write (u, "(A)") "* Cleanup" call model_list%final () call syntax_model_file_final () write (u, *) write (u, "(A)") "* Test output end: models_5" end subroutine models_5 @ %def models_5 @ \subsubsection{Read model with disordered parameters} Read a model from file where the ordering of independent and derived parameters is non-canonical. <>= call test (models_6, "models_6", & "read model parameters", & u, results) <>= public :: models_6 <>= subroutine models_6 (u) integer, intent(in) :: u integer :: um character(80) :: buffer type(os_data_t) :: os_data type(model_list_t) :: model_list type(var_list_t), pointer :: var_list type(model_t), pointer :: model write (u, "(A)") "* Test output: models_6" write (u, "(A)") "* Purpose: read a model from file & &with non-canonical parameter ordering" write (u, *) open (newunit=um, file="Test6.mdl", status="replace", action="readwrite") write (um, "(A)") 'model "Test6"' write (um, "(A)") ' parameter a = 1.000000000000E+00' write (um, "(A)") ' derived b = 2 * a' write (um, "(A)") ' parameter c = 3.000000000000E+00' write (um, "(A)") ' unused d' rewind (um) do read (um, "(A)", end=1) buffer write (u, "(A)") trim (buffer) end do 1 continue close (um) call syntax_model_file_init () call os_data%init () call model_list%read_model (var_str ("Test6"), var_str ("Test6.mdl"), & os_data, model) write (u, *) write (u, "(A)") "* Variable list" write (u, *) var_list => model%get_var_list_ptr () call var_list%write (u) write (u, *) write (u, "(A)") "* Cleanup" call model_list%final () call syntax_model_file_final () write (u, *) write (u, "(A)") "* Test output end: models_6" end subroutine models_6 @ %def models_6 @ \subsubsection{Read model with schemes} Read a model from file which supports scheme selection in the parameter list. <>= call test (models_7, "models_7", & "handle schemes", & u, results) <>= public :: models_7 <>= subroutine models_7 (u) integer, intent(in) :: u integer :: um character(80) :: buffer type(os_data_t) :: os_data type(model_list_t) :: model_list type(var_list_t), pointer :: var_list type(model_t), pointer :: model write (u, "(A)") "* Test output: models_7" write (u, "(A)") "* Purpose: read a model from file & &with scheme selection" write (u, *) open (newunit=um, file="Test7.mdl", status="replace", action="readwrite") write (um, "(A)") 'model "Test7"' write (um, "(A)") ' schemes = "foo", "bar", "gee"' write (um, "(A)") '' write (um, "(A)") ' select scheme' write (um, "(A)") ' scheme "foo"' write (um, "(A)") ' parameter a = 1' write (um, "(A)") ' derived b = 2 * a' write (um, "(A)") ' scheme other' write (um, "(A)") ' parameter b = 4' write (um, "(A)") ' derived a = b / 2' write (um, "(A)") ' end select' write (um, "(A)") '' write (um, "(A)") ' parameter c = 3' write (um, "(A)") '' write (um, "(A)") ' select scheme' write (um, "(A)") ' scheme "foo", "gee"' write (um, "(A)") ' derived d = b + c' write (um, "(A)") ' scheme other' write (um, "(A)") ' unused d' write (um, "(A)") ' end select' rewind (um) do read (um, "(A)", end=1) buffer write (u, "(A)") trim (buffer) end do 1 continue close (um) call syntax_model_file_init () call os_data%init () write (u, *) write (u, "(A)") "* Model output, default scheme (= foo)" write (u, *) call model_list%read_model (var_str ("Test7"), var_str ("Test7.mdl"), & os_data, model) call model%write (u, show_md5sum=.false.) call show_var_list () call show_par_array () call model_list%final () write (u, *) write (u, "(A)") "* Model output, scheme foo" write (u, *) call model_list%read_model (var_str ("Test7"), var_str ("Test7.mdl"), & os_data, model, scheme = var_str ("foo")) call model%write (u, show_md5sum=.false.) call show_var_list () call show_par_array () call model_list%final () write (u, *) write (u, "(A)") "* Model output, scheme bar" write (u, *) call model_list%read_model (var_str ("Test7"), var_str ("Test7.mdl"), & os_data, model, scheme = var_str ("bar")) call model%write (u, show_md5sum=.false.) call show_var_list () call show_par_array () call model_list%final () write (u, *) write (u, "(A)") "* Model output, scheme gee" write (u, *) call model_list%read_model (var_str ("Test7"), var_str ("Test7.mdl"), & os_data, model, scheme = var_str ("gee")) call model%write (u, show_md5sum=.false.) call show_var_list () call show_par_array () write (u, *) write (u, "(A)") "* Cleanup" call model_list%final () call syntax_model_file_final () write (u, *) write (u, "(A)") "* Test output end: models_7" contains subroutine show_var_list () write (u, *) write (u, "(A)") "* Variable list" write (u, *) var_list => model%get_var_list_ptr () call var_list%write (u) end subroutine show_var_list subroutine show_par_array () real(default), dimension(:), allocatable :: par integer :: n write (u, *) write (u, "(A)") "* Parameter array" write (u, *) n = model%get_n_real () allocate (par (n)) call model%real_parameters_to_array (par) write (u, 1) par 1 format (1X,F6.3) end subroutine show_par_array end subroutine models_7 @ %def models_7 @ \subsubsection{Read and handle UFO model} Read a model from file which is considered as an UFO model. In fact, it is a mock model file which just follows our naming convention for UFO models. Compare this to an equivalent non-UFO model. <>= call test (models_8, "models_8", & "handle UFO-derived models", & u, results) <>= public :: models_8 <>= subroutine models_8 (u) integer, intent(in) :: u integer :: um character(80) :: buffer type(os_data_t) :: os_data type(model_list_t) :: model_list type(string_t) :: model_name type(model_t), pointer :: model write (u, "(A)") "* Test output: models_8" write (u, "(A)") "* Purpose: distinguish models marked as UFO-derived" write (u, *) call os_data%init () call show_model_list_status () model_name = "models_8_M" write (u, *) write (u, "(A)") "* Write WHIZARD model" write (u, *) open (newunit=um, file=char (model_name // ".mdl"), & status="replace", action="readwrite") write (um, "(A)") 'model "models_8_M"' write (um, "(A)") ' parameter a = 1' rewind (um) do read (um, "(A)", end=1) buffer write (u, "(A)") trim (buffer) end do 1 continue close (um) write (u, *) write (u, "(A)") "* Write UFO model" write (u, *) open (newunit=um, file=char (model_name // ".ufo.mdl"), & status="replace", action="readwrite") write (um, "(A)") 'model "models_8_M"' write (um, "(A)") ' parameter a = 2' rewind (um) do read (um, "(A)", end=2) buffer write (u, "(A)") trim (buffer) end do 2 continue close (um) call syntax_model_file_init () call os_data%init () write (u, *) write (u, "(A)") "* Read WHIZARD model" write (u, *) call model_list%read_model (model_name, model_name // ".mdl", & os_data, model) call model%write (u, show_md5sum=.false.) call show_model_list_status () write (u, *) write (u, "(A)") "* Read UFO model" write (u, *) call model_list%read_model (model_name, model_name // ".ufo.mdl", & os_data, model, ufo=.true., rebuild_mdl = .false.) call model%write (u, show_md5sum=.false.) call show_model_list_status () write (u, *) write (u, "(A)") "* Reload WHIZARD model" write (u, *) call model_list%read_model (model_name, model_name // ".mdl", & os_data, model) call model%write (u, show_md5sum=.false.) call show_model_list_status () write (u, *) write (u, "(A)") "* Reload UFO model" write (u, *) call model_list%read_model (model_name, model_name // ".ufo.mdl", & os_data, model, ufo=.true., rebuild_mdl = .false.) call model%write (u, show_md5sum=.false.) call show_model_list_status () write (u, *) write (u, "(A)") "* Cleanup" call model_list%final () call syntax_model_file_final () write (u, *) write (u, "(A)") "* Test output end: models_8" contains subroutine show_model_list_status () write (u, "(A)") "* Model list status" write (u, *) write (u, "(A,1x,L1)") "WHIZARD model exists =", & model_list%model_exists (model_name) write (u, "(A,1x,L1)") "UFO model exists =", & model_list%model_exists (model_name, ufo=.true.) end subroutine show_model_list_status end subroutine models_8 @ %def models_8 @ \subsubsection{Generate UFO model file} Generate the necessary [[.ufo.mdl]] file from source, calling OMega, and load the model. Note: There must not be another unit test which works with the same UFO model. The model file is deleted explicitly at the end of this test. <>= call test (models_9, "models_9", & "generate UFO-derived model file", & u, results) <>= public :: models_9 <>= subroutine models_9 (u) integer, intent(in) :: u integer :: um character(80) :: buffer type(os_data_t) :: os_data type(model_list_t) :: model_list type(string_t) :: model_name, model_file_name type(model_t), pointer :: model write (u, "(A)") "* Test output: models_9" write (u, "(A)") "* Purpose: enable the UFO Standard Model (test version)" write (u, *) call os_data%init () call syntax_model_file_init () os_data%whizard_modelpath_ufo = "../models/UFO" model_name = "SM" model_file_name = model_name // ".models_9" // ".ufo.mdl" write (u, "(A)") "* Generate and read UFO model" write (u, *) call delete_file (char (model_file_name)) call model_list%read_model (model_name, model_file_name, os_data, model, ufo=.true.) call model%write (u, show_md5sum=.false.) write (u, *) write (u, "(A)") "* Cleanup" call model_list%final () call syntax_model_file_final () write (u, *) write (u, "(A)") "* Test output end: models_9" end subroutine models_9 @ %def models_9 @ \clearpage %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \section{The SUSY Les Houches Accord} The SUSY Les Houches Accord defines a standard interfaces for storing the physics data of SUSY models. Here, we provide the means for reading, storing, and writing such data. <<[[slha_interface.f90]]>>= <> module slha_interface <> <> use io_units use constants use string_utils, only: upper_case use system_defs, only: VERSION_STRING use system_defs, only: EOF use diagnostics use os_interface use ifiles use lexers use syntax_rules use parser use variables use models <> <> <> <> save contains <> <> end module slha_interface @ %def slha_interface @ \subsection{Preprocessor} SLHA is a mixed-format standard. It should be read in assuming free format (but line-oriented), but it has some fixed-format elements. To overcome this difficulty, we implement a preprocessing step which transforms the SLHA into a format that can be swallowed by our generic free-format lexer and parser. Each line with a blank first character is assumed to be a data line. We prepend a 'DATA' keyword to these lines. Furthermore, to enforce line-orientation, each line is appended a '\$' key which is recognized by the parser. To do this properly, we first remove trailing comments, and skip lines consisting only of comments. The preprocessor reads from a stream and puts out an [[ifile]]. Blocks that are not recognized are skipped. For some blocks, data items are quoted, so they can be read as strings if necessary. <>= integer, parameter :: MODE_SKIP = 0, MODE_DATA = 1, MODE_INFO = 2 @ %def MODE_SKIP = 0, MODE_DATA = 1, MODE_INFO = 2 <>= subroutine slha_preprocess (stream, ifile) type(stream_t), intent(inout), target :: stream type(ifile_t), intent(out) :: ifile type(string_t) :: buffer, line, item integer :: iostat integer :: mode mode = MODE SCAN_FILE: do call stream_get_record (stream, buffer, iostat) select case (iostat) case (0) call split (buffer, line, "#") if (len_trim (line) == 0) cycle SCAN_FILE select case (char (extract (line, 1, 1))) case ("B", "b") mode = check_block_handling (line) call ifile_append (ifile, line // "$") case ("D", "d") mode = MODE_DATA call ifile_append (ifile, line // "$") case (" ") select case (mode) case (MODE_DATA) call ifile_append (ifile, "DATA" // line // "$") case (MODE_INFO) line = adjustl (line) call split (line, item, " ") call ifile_append (ifile, "INFO" // " " // item // " " & // '"' // trim (adjustl (line)) // '" $') end select case default call msg_message (char (line)) call msg_fatal ("SLHA: Incomprehensible line") end select case (EOF) exit SCAN_FILE case default call msg_fatal ("SLHA: I/O error occured while reading SLHA input") end select end do SCAN_FILE end subroutine slha_preprocess @ %def slha_preprocess @ Return the mode that we should treat this block with. We need to recognize only those blocks that we actually use. <>= function check_block_handling (line) result (mode) integer :: mode type(string_t), intent(in) :: line type(string_t) :: buffer, key, block_name buffer = trim (line) call split (buffer, key, " ") buffer = adjustl (buffer) call split (buffer, block_name, " ") block_name = trim (adjustl (upper_case (block_name))) select case (char (block_name)) case ("MODSEL", "MINPAR", "SMINPUTS") mode = MODE_DATA case ("MASS") mode = MODE_DATA case ("NMIX", "UMIX", "VMIX", "STOPMIX", "SBOTMIX", "STAUMIX") mode = MODE_DATA case ("NMHMIX", "NMAMIX", "NMNMIX", "NMSSMRUN") mode = MODE_DATA case ("ALPHA", "HMIX") mode = MODE_DATA case ("AU", "AD", "AE") mode = MODE_DATA case ("SPINFO", "DCINFO") mode = MODE_INFO case default mode = MODE_SKIP end select end function check_block_handling @ %def check_block_handling @ \subsection{Lexer and syntax} <>= type(syntax_t), target :: syntax_slha @ %def syntax_slha <>= public :: syntax_slha_init <>= subroutine syntax_slha_init () type(ifile_t) :: ifile call define_slha_syntax (ifile) call syntax_init (syntax_slha, ifile) call ifile_final (ifile) end subroutine syntax_slha_init @ %def syntax_slha_init <>= public :: syntax_slha_final <>= subroutine syntax_slha_final () call syntax_final (syntax_slha) end subroutine syntax_slha_final @ %def syntax_slha_final <>= public :: syntax_slha_write <>= subroutine syntax_slha_write (unit) integer, intent(in), optional :: unit call syntax_write (syntax_slha, unit) end subroutine syntax_slha_write @ %def syntax_slha_write <>= subroutine define_slha_syntax (ifile) type(ifile_t), intent(inout) :: ifile call ifile_append (ifile, "SEQ slha = chunk*") call ifile_append (ifile, "ALT chunk = block_def | decay_def") call ifile_append (ifile, "SEQ block_def = " & // "BLOCK block_spec '$' block_line*") call ifile_append (ifile, "KEY BLOCK") call ifile_append (ifile, "SEQ block_spec = block_name qvalue?") call ifile_append (ifile, "IDE block_name") call ifile_append (ifile, "SEQ qvalue = qname '=' real") call ifile_append (ifile, "IDE qname") call ifile_append (ifile, "KEY '='") call ifile_append (ifile, "REA real") call ifile_append (ifile, "KEY '$'") call ifile_append (ifile, "ALT block_line = block_data | block_info") call ifile_append (ifile, "SEQ block_data = DATA data_line '$'") call ifile_append (ifile, "KEY DATA") call ifile_append (ifile, "SEQ data_line = data_item+") call ifile_append (ifile, "ALT data_item = signed_number | number") call ifile_append (ifile, "SEQ signed_number = sign number") call ifile_append (ifile, "ALT sign = '+' | '-'") call ifile_append (ifile, "ALT number = integer | real") call ifile_append (ifile, "INT integer") call ifile_append (ifile, "KEY '-'") call ifile_append (ifile, "KEY '+'") call ifile_append (ifile, "SEQ block_info = INFO info_line '$'") call ifile_append (ifile, "KEY INFO") call ifile_append (ifile, "SEQ info_line = integer string_literal") call ifile_append (ifile, "QUO string_literal = '""'...'""'") call ifile_append (ifile, "SEQ decay_def = " & // "DECAY decay_spec '$' decay_data*") call ifile_append (ifile, "KEY DECAY") call ifile_append (ifile, "SEQ decay_spec = pdg_code data_item") call ifile_append (ifile, "ALT pdg_code = signed_integer | integer") call ifile_append (ifile, "SEQ signed_integer = sign integer") call ifile_append (ifile, "SEQ decay_data = DATA decay_line '$'") call ifile_append (ifile, "SEQ decay_line = data_item integer pdg_code+") end subroutine define_slha_syntax @ %def define_slha_syntax @ The SLHA specification allows for string data items in certain places. Currently, we do not interpret them, but the strings, which are not quoted, must be parsed somehow. The hack for this problem is to allow essentially all characters as special characters, so the string can be read before it is discarded. <>= public :: lexer_init_slha <>= subroutine lexer_init_slha (lexer) type(lexer_t), intent(out) :: lexer call lexer_init (lexer, & comment_chars = "#", & quote_chars = '"', & quote_match = '"', & single_chars = "+-=$", & special_class = [ "" ], & keyword_list = syntax_get_keyword_list_ptr (syntax_slha), & upper_case_keywords = .true.) ! $ end subroutine lexer_init_slha @ %def lexer_init_slha @ \subsection{Interpreter} \subsubsection{Find blocks} From the parse tree, find the node that represents a particular block. If [[required]] is true, issue an error if not found. Since [[block_name]] is always invoked with capital letters, we have to capitalize [[pn_block_name]]. <>= function slha_get_block_ptr & (parse_tree, block_name, required) result (pn_block) type(parse_node_t), pointer :: pn_block type(parse_tree_t), intent(in) :: parse_tree type(string_t), intent(in) :: block_name logical, intent(in) :: required type(parse_node_t), pointer :: pn_root, pn_block_spec, pn_block_name pn_root => parse_tree%get_root_ptr () pn_block => parse_node_get_sub_ptr (pn_root) do while (associated (pn_block)) select case (char (parse_node_get_rule_key (pn_block))) case ("block_def") pn_block_spec => parse_node_get_sub_ptr (pn_block, 2) pn_block_name => parse_node_get_sub_ptr (pn_block_spec) if (trim (adjustl (upper_case (parse_node_get_string & (pn_block_name)))) == block_name) then return end if end select pn_block => parse_node_get_next_ptr (pn_block) end do if (required) then call msg_fatal ("SLHA: block '" // char (block_name) // "' not found") end if end function slha_get_block_ptr @ %def slha_get_blck_ptr @ Scan the file for the first/next DECAY block. <>= function slha_get_first_decay_ptr (parse_tree) result (pn_decay) type(parse_node_t), pointer :: pn_decay type(parse_tree_t), intent(in) :: parse_tree type(parse_node_t), pointer :: pn_root pn_root => parse_tree%get_root_ptr () pn_decay => parse_node_get_sub_ptr (pn_root) do while (associated (pn_decay)) select case (char (parse_node_get_rule_key (pn_decay))) case ("decay_def") return end select pn_decay => parse_node_get_next_ptr (pn_decay) end do end function slha_get_first_decay_ptr function slha_get_next_decay_ptr (pn_block) result (pn_decay) type(parse_node_t), pointer :: pn_decay type(parse_node_t), intent(in), target :: pn_block pn_decay => parse_node_get_next_ptr (pn_block) do while (associated (pn_decay)) select case (char (parse_node_get_rule_key (pn_decay))) case ("decay_def") return end select pn_decay => parse_node_get_next_ptr (pn_decay) end do end function slha_get_next_decay_ptr @ %def slha_get_next_decay_ptr @ \subsubsection{Extract and transfer data from blocks} Given the parse node of a block, find the parse node of a particular switch or data line. Return this node and the node of the data item following the integer code. <>= subroutine slha_find_index_ptr (pn_block, pn_data, pn_item, code) type(parse_node_t), intent(in), target :: pn_block type(parse_node_t), intent(out), pointer :: pn_data type(parse_node_t), intent(out), pointer :: pn_item integer, intent(in) :: code pn_data => parse_node_get_sub_ptr (pn_block, 4) call slha_next_index_ptr (pn_data, pn_item, code) end subroutine slha_find_index_ptr subroutine slha_find_index_pair_ptr (pn_block, pn_data, pn_item, code1, code2) type(parse_node_t), intent(in), target :: pn_block type(parse_node_t), intent(out), pointer :: pn_data type(parse_node_t), intent(out), pointer :: pn_item integer, intent(in) :: code1, code2 pn_data => parse_node_get_sub_ptr (pn_block, 4) call slha_next_index_pair_ptr (pn_data, pn_item, code1, code2) end subroutine slha_find_index_pair_ptr @ %def slha_find_index_ptr slha_find_index_pair_ptr @ Starting from the pointer to a data line, find a data line with the given integer code. <>= subroutine slha_next_index_ptr (pn_data, pn_item, code) type(parse_node_t), intent(inout), pointer :: pn_data integer, intent(in) :: code type(parse_node_t), intent(out), pointer :: pn_item type(parse_node_t), pointer :: pn_line, pn_code do while (associated (pn_data)) pn_line => parse_node_get_sub_ptr (pn_data, 2) pn_code => parse_node_get_sub_ptr (pn_line) select case (char (parse_node_get_rule_key (pn_code))) case ("integer") if (parse_node_get_integer (pn_code) == code) then pn_item => parse_node_get_next_ptr (pn_code) return end if end select pn_data => parse_node_get_next_ptr (pn_data) end do pn_item => null () end subroutine slha_next_index_ptr @ %def slha_next_index_ptr @ Starting from the pointer to a data line, find a data line with the given integer code pair. <>= subroutine slha_next_index_pair_ptr (pn_data, pn_item, code1, code2) type(parse_node_t), intent(inout), pointer :: pn_data integer, intent(in) :: code1, code2 type(parse_node_t), intent(out), pointer :: pn_item type(parse_node_t), pointer :: pn_line, pn_code1, pn_code2 do while (associated (pn_data)) pn_line => parse_node_get_sub_ptr (pn_data, 2) pn_code1 => parse_node_get_sub_ptr (pn_line) select case (char (parse_node_get_rule_key (pn_code1))) case ("integer") if (parse_node_get_integer (pn_code1) == code1) then pn_code2 => parse_node_get_next_ptr (pn_code1) if (associated (pn_code2)) then select case (char (parse_node_get_rule_key (pn_code2))) case ("integer") if (parse_node_get_integer (pn_code2) == code2) then pn_item => parse_node_get_next_ptr (pn_code2) return end if end select end if end if end select pn_data => parse_node_get_next_ptr (pn_data) end do pn_item => null () end subroutine slha_next_index_pair_ptr @ %def slha_next_index_pair_ptr @ \subsubsection{Handle info data} Return all strings with index [[i]]. The result is an allocated string array. Since we do not know the number of matching entries in advance, we build an intermediate list which is transferred to the final array and deleted before exiting. <>= subroutine retrieve_strings_in_block (pn_block, code, str_array) type(parse_node_t), intent(in), target :: pn_block integer, intent(in) :: code type(string_t), dimension(:), allocatable, intent(out) :: str_array type(parse_node_t), pointer :: pn_data, pn_item type :: str_entry_t type(string_t) :: str type(str_entry_t), pointer :: next => null () end type str_entry_t type(str_entry_t), pointer :: first => null () type(str_entry_t), pointer :: current => null () integer :: n n = 0 call slha_find_index_ptr (pn_block, pn_data, pn_item, code) if (associated (pn_item)) then n = n + 1 allocate (first) first%str = parse_node_get_string (pn_item) current => first do while (associated (pn_data)) pn_data => parse_node_get_next_ptr (pn_data) call slha_next_index_ptr (pn_data, pn_item, code) if (associated (pn_item)) then n = n + 1 allocate (current%next) current => current%next current%str = parse_node_get_string (pn_item) end if end do allocate (str_array (n)) n = 0 do while (associated (first)) n = n + 1 current => first str_array(n) = current%str first => first%next deallocate (current) end do else allocate (str_array (0)) end if end subroutine retrieve_strings_in_block @ %def retrieve_strings_in_block @ \subsubsection{Transfer data from SLHA to variables} Extract real parameter with index [[i]]. If it does not exist, retrieve it from the variable list, using the given name. <>= function get_parameter_in_block (pn_block, code, name, var_list) result (var) real(default) :: var type(parse_node_t), intent(in), target :: pn_block integer, intent(in) :: code type(string_t), intent(in) :: name type(var_list_t), intent(in), target :: var_list type(parse_node_t), pointer :: pn_data, pn_item call slha_find_index_ptr (pn_block, pn_data, pn_item, code) if (associated (pn_item)) then var = get_real_parameter (pn_item) else var = var_list%get_rval (name) end if end function get_parameter_in_block @ %def get_parameter_in_block @ Extract a real data item with index [[i]]. If it does exist, set it in the variable list, using the given name. If the variable is not present in the variable list, ignore it. <>= subroutine set_data_item (pn_block, code, name, var_list) type(parse_node_t), intent(in), target :: pn_block integer, intent(in) :: code type(string_t), intent(in) :: name type(var_list_t), intent(inout), target :: var_list type(parse_node_t), pointer :: pn_data, pn_item call slha_find_index_ptr (pn_block, pn_data, pn_item, code) if (associated (pn_item)) then call var_list%set_real (name, get_real_parameter (pn_item), & is_known=.true., ignore=.true.) end if end subroutine set_data_item @ %def set_data_item @ Extract a real matrix element with index [[i,j]]. If it does exists, set it in the variable list, using the given name. If the variable is not present in the variable list, ignore it. <>= subroutine set_matrix_element (pn_block, code1, code2, name, var_list) type(parse_node_t), intent(in), target :: pn_block integer, intent(in) :: code1, code2 type(string_t), intent(in) :: name type(var_list_t), intent(inout), target :: var_list type(parse_node_t), pointer :: pn_data, pn_item call slha_find_index_pair_ptr (pn_block, pn_data, pn_item, code1, code2) if (associated (pn_item)) then call var_list%set_real (name, get_real_parameter (pn_item), & is_known=.true., ignore=.true.) end if end subroutine set_matrix_element @ %def set_matrix_element @ \subsubsection{Transfer data from variables to SLHA} Get a real/integer parameter with index [[i]] from the variable list and write it to the current output file. In the integer case, we account for the fact that the variable is type real. If it does not exist, do nothing. <>= subroutine write_integer_data_item (u, code, name, var_list, comment) integer, intent(in) :: u integer, intent(in) :: code type(string_t), intent(in) :: name type(var_list_t), intent(in) :: var_list character(*), intent(in) :: comment integer :: item if (var_list%contains (name)) then item = nint (var_list%get_rval (name)) call write_integer_parameter (u, code, item, comment) end if end subroutine write_integer_data_item subroutine write_real_data_item (u, code, name, var_list, comment) integer, intent(in) :: u integer, intent(in) :: code type(string_t), intent(in) :: name type(var_list_t), intent(in) :: var_list character(*), intent(in) :: comment real(default) :: item if (var_list%contains (name)) then item = var_list%get_rval (name) call write_real_parameter (u, code, item, comment) end if end subroutine write_real_data_item @ %def write_real_data_item @ Get a real data item with two integer indices from the variable list and write it to the current output file. If it does not exist, do nothing. <>= subroutine write_matrix_element (u, code1, code2, name, var_list, comment) integer, intent(in) :: u integer, intent(in) :: code1, code2 type(string_t), intent(in) :: name type(var_list_t), intent(in) :: var_list character(*), intent(in) :: comment real(default) :: item if (var_list%contains (name)) then item = var_list%get_rval (name) call write_real_matrix_element (u, code1, code2, item, comment) end if end subroutine write_matrix_element @ %def write_matrix_element @ \subsection{Auxiliary function} Write a block header. <>= subroutine write_block_header (u, name, comment) integer, intent(in) :: u character(*), intent(in) :: name, comment write (u, "(A,1x,A,3x,'#',1x,A)") "BLOCK", name, comment end subroutine write_block_header @ %def write_block_header @ Extract a real parameter that may be defined real or integer, signed or unsigned. <>= function get_real_parameter (pn_item) result (var) real(default) :: var type(parse_node_t), intent(in), target :: pn_item type(parse_node_t), pointer :: pn_sign, pn_var integer :: sign select case (char (parse_node_get_rule_key (pn_item))) case ("signed_number") pn_sign => parse_node_get_sub_ptr (pn_item) pn_var => parse_node_get_next_ptr (pn_sign) select case (char (parse_node_get_key (pn_sign))) case ("+"); sign = +1 case ("-"); sign = -1 end select case default sign = +1 pn_var => pn_item end select select case (char (parse_node_get_rule_key (pn_var))) case ("integer"); var = sign * parse_node_get_integer (pn_var) case ("real"); var = sign * parse_node_get_real (pn_var) end select end function get_real_parameter @ %def get_real_parameter @ Auxiliary: Extract an integer parameter that may be defined signed or unsigned. A real value is an error. <>= function get_integer_parameter (pn_item) result (var) integer :: var type(parse_node_t), intent(in), target :: pn_item type(parse_node_t), pointer :: pn_sign, pn_var integer :: sign select case (char (parse_node_get_rule_key (pn_item))) case ("signed_integer") pn_sign => parse_node_get_sub_ptr (pn_item) pn_var => parse_node_get_next_ptr (pn_sign) select case (char (parse_node_get_key (pn_sign))) case ("+"); sign = +1 case ("-"); sign = -1 end select case ("integer") sign = +1 pn_var => pn_item case default call parse_node_write (pn_var) call msg_error ("SLHA: Integer parameter expected") var = 0 return end select var = sign * parse_node_get_integer (pn_var) end function get_integer_parameter @ %def get_real_parameter @ Write an integer parameter with a single index directly to file, using the required output format. <>= subroutine write_integer_parameter (u, code, item, comment) integer, intent(in) :: u integer, intent(in) :: code integer, intent(in) :: item character(*), intent(in) :: comment 1 format (1x, I9, 3x, 3x, I9, 4x, 3x, '#', 1x, A) write (u, 1) code, item, comment end subroutine write_integer_parameter @ %def write_integer_parameter @ Write a real parameter with two indices directly to file, using the required output format. <>= subroutine write_real_parameter (u, code, item, comment) integer, intent(in) :: u integer, intent(in) :: code real(default), intent(in) :: item character(*), intent(in) :: comment 1 format (1x, I9, 3x, 1P, E16.8, 0P, 3x, '#', 1x, A) write (u, 1) code, item, comment end subroutine write_real_parameter @ %def write_real_parameter @ Write a real parameter with a single index directly to file, using the required output format. <>= subroutine write_real_matrix_element (u, code1, code2, item, comment) integer, intent(in) :: u integer, intent(in) :: code1, code2 real(default), intent(in) :: item character(*), intent(in) :: comment 1 format (1x, I2, 1x, I2, 3x, 1P, E16.8, 0P, 3x, '#', 1x, A) write (u, 1) code1, code2, item, comment end subroutine write_real_matrix_element @ %def write_real_matrix_element @ \subsubsection{The concrete SLHA interpreter} SLHA codes for particular physics models <>= integer, parameter :: MDL_MSSM = 0 integer, parameter :: MDL_NMSSM = 1 @ %def MDL_MSSM MDL_NMSSM @ Take the parse tree and extract relevant data. Select the correct model and store all data that is present in the appropriate variable list. Finally, update the variable record. Public for use in unit test. <>= public :: slha_interpret_parse_tree <>= subroutine slha_interpret_parse_tree & (parse_tree, model, input, spectrum, decays) type(parse_tree_t), intent(in) :: parse_tree type(model_t), intent(inout), target :: model logical, intent(in) :: input, spectrum, decays logical :: errors integer :: mssm_type call slha_handle_MODSEL (parse_tree, model, mssm_type) if (input) then call slha_handle_SMINPUTS (parse_tree, model) call slha_handle_MINPAR (parse_tree, model, mssm_type) end if if (spectrum) then call slha_handle_info_block (parse_tree, "SPINFO", errors) if (errors) return call slha_handle_MASS (parse_tree, model) call slha_handle_matrix_block (parse_tree, "NMIX", "mn_", 4, 4, model) call slha_handle_matrix_block (parse_tree, "NMNMIX", "mixn_", 5, 5, model) call slha_handle_matrix_block (parse_tree, "UMIX", "mu_", 2, 2, model) call slha_handle_matrix_block (parse_tree, "VMIX", "mv_", 2, 2, model) call slha_handle_matrix_block (parse_tree, "STOPMIX", "mt_", 2, 2, model) call slha_handle_matrix_block (parse_tree, "SBOTMIX", "mb_", 2, 2, model) call slha_handle_matrix_block (parse_tree, "STAUMIX", "ml_", 2, 2, model) call slha_handle_matrix_block (parse_tree, "NMHMIX", "mixh0_", 3, 3, model) call slha_handle_matrix_block (parse_tree, "NMAMIX", "mixa0_", 2, 3, model) call slha_handle_ALPHA (parse_tree, model) call slha_handle_HMIX (parse_tree, model) call slha_handle_NMSSMRUN (parse_tree, model) call slha_handle_matrix_block (parse_tree, "AU", "Au_", 3, 3, model) call slha_handle_matrix_block (parse_tree, "AD", "Ad_", 3, 3, model) call slha_handle_matrix_block (parse_tree, "AE", "Ae_", 3, 3, model) end if if (decays) then call slha_handle_info_block (parse_tree, "DCINFO", errors) if (errors) return call slha_handle_decays (parse_tree, model) end if end subroutine slha_interpret_parse_tree @ %def slha_interpret_parse_tree @ \subsubsection{Info blocks} Handle the informational blocks SPINFO and DCINFO. The first two items are program name and version. Items with index 3 are warnings. Items with index 4 are errors. We reproduce these as WHIZARD warnings and errors. <>= subroutine slha_handle_info_block (parse_tree, block_name, errors) type(parse_tree_t), intent(in) :: parse_tree character(*), intent(in) :: block_name logical, intent(out) :: errors type(parse_node_t), pointer :: pn_block type(string_t), dimension(:), allocatable :: msg integer :: i pn_block => slha_get_block_ptr & (parse_tree, var_str (block_name), required=.true.) if (.not. associated (pn_block)) then call msg_error ("SLHA: Missing info block '" & // trim (block_name) // "'; ignored.") errors = .true. return end if select case (block_name) case ("SPINFO") call msg_message ("SLHA: SUSY spectrum program info:") case ("DCINFO") call msg_message ("SLHA: SUSY decay program info:") end select call retrieve_strings_in_block (pn_block, 1, msg) do i = 1, size (msg) call msg_message ("SLHA: " // char (msg(i))) end do call retrieve_strings_in_block (pn_block, 2, msg) do i = 1, size (msg) call msg_message ("SLHA: " // char (msg(i))) end do call retrieve_strings_in_block (pn_block, 3, msg) do i = 1, size (msg) call msg_warning ("SLHA: " // char (msg(i))) end do call retrieve_strings_in_block (pn_block, 4, msg) do i = 1, size (msg) call msg_error ("SLHA: " // char (msg(i))) end do errors = size (msg) > 0 end subroutine slha_handle_info_block @ %def slha_handle_info_block @ \subsubsection{MODSEL} Handle the overall model definition. Only certain models are recognized. The soft-breaking model templates that determine the set of input parameters: <>= integer, parameter :: MSSM_GENERIC = 0 integer, parameter :: MSSM_SUGRA = 1 integer, parameter :: MSSM_GMSB = 2 integer, parameter :: MSSM_AMSB = 3 @ %def MSSM_GENERIC MSSM_MSUGRA MSSM_GMSB MSSM_AMSB <>= subroutine slha_handle_MODSEL (parse_tree, model, mssm_type) type(parse_tree_t), intent(in) :: parse_tree type(model_t), intent(in), target :: model integer, intent(out) :: mssm_type type(parse_node_t), pointer :: pn_block, pn_data, pn_item type(string_t) :: model_name pn_block => slha_get_block_ptr & (parse_tree, var_str ("MODSEL"), required=.true.) call slha_find_index_ptr (pn_block, pn_data, pn_item, 1) if (associated (pn_item)) then mssm_type = get_integer_parameter (pn_item) else mssm_type = MSSM_GENERIC end if call slha_find_index_ptr (pn_block, pn_data, pn_item, 3) if (associated (pn_item)) then select case (parse_node_get_integer (pn_item)) case (MDL_MSSM); model_name = "MSSM" case (MDL_NMSSM); model_name = "NMSSM" case default call msg_fatal ("SLHA: unknown model code in MODSEL") return end select else model_name = "MSSM" end if call slha_find_index_ptr (pn_block, pn_data, pn_item, 4) if (associated (pn_item)) then call msg_fatal (" R-parity violation is currently not supported by WHIZARD.") end if call slha_find_index_ptr (pn_block, pn_data, pn_item, 5) if (associated (pn_item)) then call msg_fatal (" CP violation is currently not supported by WHIZARD.") end if select case (char (model_name)) case ("MSSM") select case (char (model%get_name ())) case ("MSSM","MSSM_CKM","MSSM_Grav","MSSM_Hgg") model_name = model%get_name () case default call msg_fatal ("Selected model '" & // char (model%get_name ()) // "' does not match model '" & // char (model_name) // "' in SLHA input file.") return end select case ("NMSSM") select case (char (model%get_name ())) case ("NMSSM","NMSSM_CKM","NMSSM_Hgg") model_name = model%get_name () case default call msg_fatal ("Selected model '" & // char (model%get_name ()) // "' does not match model '" & // char (model_name) // "' in SLHA input file.") return end select case default call msg_bug ("SLHA model name '" & // char (model_name) // "' not recognized.") return end select call msg_message ("SLHA: Initializing model '" // char (model_name) // "'") end subroutine slha_handle_MODSEL @ %def slha_handle_MODSEL @ Write a MODSEL block, based on the contents of the current model. <>= subroutine slha_write_MODSEL (u, model, mssm_type) integer, intent(in) :: u type(model_t), intent(in), target :: model integer, intent(out) :: mssm_type type(var_list_t), pointer :: var_list integer :: model_id type(string_t) :: mtype_string var_list => model%get_var_list_ptr () if (var_list%contains (var_str ("mtype"))) then mssm_type = nint (var_list%get_rval (var_str ("mtype"))) else call msg_error ("SLHA: parameter 'mtype' (SUSY breaking scheme) " & // "is unknown in current model, no SLHA output possible") mssm_type = -1 return end if call write_block_header (u, "MODSEL", "SUSY model selection") select case (mssm_type) case (0); mtype_string = "Generic MSSM" case (1); mtype_string = "SUGRA" case (2); mtype_string = "GMSB" case (3); mtype_string = "AMSB" case default mtype_string = "unknown" end select call write_integer_parameter (u, 1, mssm_type, & "SUSY-breaking scheme: " // char (mtype_string)) select case (char (model%get_name ())) case ("MSSM"); model_id = MDL_MSSM case ("NMSSM"); model_id = MDL_NMSSM case default model_id = 0 end select call write_integer_parameter (u, 3, model_id, & "SUSY model type: " // char (model%get_name ())) end subroutine slha_write_MODSEL @ %def slha_write_MODSEL @ \subsubsection{SMINPUTS} Read SM parameters and update the variable list accordingly. If a parameter is not defined in the block, we use the previous value from the model variable list. For the basic parameters we have to do a small recalculation, since SLHA uses the $G_F$-$\alpha$-$m_Z$ scheme, while \whizard\ derives them from $G_F$, $m_W$, and $m_Z$. <>= subroutine slha_handle_SMINPUTS (parse_tree, model) type(parse_tree_t), intent(in) :: parse_tree type(model_t), intent(inout), target :: model type(parse_node_t), pointer :: pn_block real(default) :: alpha_em_i, GF, alphas, mZ real(default) :: ee, vv, cw_sw, cw2, mW real(default) :: mb, mtop, mtau type(var_list_t), pointer :: var_list var_list => model%get_var_list_ptr () pn_block => slha_get_block_ptr & (parse_tree, var_str ("SMINPUTS"), required=.true.) if (.not. (associated (pn_block))) return alpha_em_i = & get_parameter_in_block (pn_block, 1, var_str ("alpha_em_i"), var_list) GF = get_parameter_in_block (pn_block, 2, var_str ("GF"), var_list) alphas = & get_parameter_in_block (pn_block, 3, var_str ("alphas"), var_list) mZ = get_parameter_in_block (pn_block, 4, var_str ("mZ"), var_list) mb = get_parameter_in_block (pn_block, 5, var_str ("mb"), var_list) mtop = get_parameter_in_block (pn_block, 6, var_str ("mtop"), var_list) mtau = get_parameter_in_block (pn_block, 7, var_str ("mtau"), var_list) ee = sqrt (4 * pi / alpha_em_i) vv = 1 / sqrt (sqrt (2._default) * GF) cw_sw = ee * vv / (2 * mZ) if (2*cw_sw <= 1) then cw2 = (1 + sqrt (1 - 4 * cw_sw**2)) / 2 mW = mZ * sqrt (cw2) call var_list%set_real (var_str ("GF"), GF, .true.) call var_list%set_real (var_str ("mZ"), mZ, .true.) call var_list%set_real (var_str ("mW"), mW, .true.) call var_list%set_real (var_str ("mtau"), mtau, .true.) call var_list%set_real (var_str ("mb"), mb, .true.) call var_list%set_real (var_str ("mtop"), mtop, .true.) call var_list%set_real (var_str ("alphas"), alphas, .true.) else call msg_fatal ("SLHA: Unphysical SM parameter values") return end if end subroutine slha_handle_SMINPUTS @ %def slha_handle_SMINPUTS @ Write a SMINPUTS block. <>= subroutine slha_write_SMINPUTS (u, model) integer, intent(in) :: u type(model_t), intent(in), target :: model type(var_list_t), pointer :: var_list var_list => model%get_var_list_ptr () call write_block_header (u, "SMINPUTS", "SM input parameters") call write_real_data_item (u, 1, var_str ("alpha_em_i"), var_list, & "Inverse electromagnetic coupling alpha (Z pole)") call write_real_data_item (u, 2, var_str ("GF"), var_list, & "Fermi constant") call write_real_data_item (u, 3, var_str ("alphas"), var_list, & "Strong coupling alpha_s (Z pole)") call write_real_data_item (u, 4, var_str ("mZ"), var_list, & "Z mass") call write_real_data_item (u, 5, var_str ("mb"), var_list, & "b running mass (at mb)") call write_real_data_item (u, 6, var_str ("mtop"), var_list, & "top mass") call write_real_data_item (u, 7, var_str ("mtau"), var_list, & "tau mass") end subroutine slha_write_SMINPUTS @ %def slha_write_SMINPUTS @ \subsubsection{MINPAR} The block of SUSY input parameters. They are accessible to WHIZARD, but they only get used when an external spectrum generator is invoked. The precise set of parameters depends on the type of SUSY breaking, which by itself is one of the parameters. <>= subroutine slha_handle_MINPAR (parse_tree, model, mssm_type) type(parse_tree_t), intent(in) :: parse_tree type(model_t), intent(inout), target :: model integer, intent(in) :: mssm_type type(var_list_t), pointer :: var_list type(parse_node_t), pointer :: pn_block var_list => model%get_var_list_ptr () call var_list%set_real & (var_str ("mtype"), real(mssm_type, default), is_known=.true.) pn_block => slha_get_block_ptr & (parse_tree, var_str ("MINPAR"), required=.true.) select case (mssm_type) case (MSSM_SUGRA) call set_data_item (pn_block, 1, var_str ("m_zero"), var_list) call set_data_item (pn_block, 2, var_str ("m_half"), var_list) call set_data_item (pn_block, 3, var_str ("tanb"), var_list) call set_data_item (pn_block, 4, var_str ("sgn_mu"), var_list) call set_data_item (pn_block, 5, var_str ("A0"), var_list) case (MSSM_GMSB) call set_data_item (pn_block, 1, var_str ("Lambda"), var_list) call set_data_item (pn_block, 2, var_str ("M_mes"), var_list) call set_data_item (pn_block, 3, var_str ("tanb"), var_list) call set_data_item (pn_block, 4, var_str ("sgn_mu"), var_list) call set_data_item (pn_block, 5, var_str ("N_5"), var_list) call set_data_item (pn_block, 6, var_str ("c_grav"), var_list) case (MSSM_AMSB) call set_data_item (pn_block, 1, var_str ("m_zero"), var_list) call set_data_item (pn_block, 2, var_str ("m_grav"), var_list) call set_data_item (pn_block, 3, var_str ("tanb"), var_list) call set_data_item (pn_block, 4, var_str ("sgn_mu"), var_list) case default call set_data_item (pn_block, 3, var_str ("tanb"), var_list) end select end subroutine slha_handle_MINPAR @ %def slha_handle_MINPAR @ Write a MINPAR block as appropriate for the current model type. <>= subroutine slha_write_MINPAR (u, model, mssm_type) integer, intent(in) :: u type(model_t), intent(in), target :: model integer, intent(in) :: mssm_type type(var_list_t), pointer :: var_list var_list => model%get_var_list_ptr () call write_block_header (u, "MINPAR", "Basic SUSY input parameters") select case (mssm_type) case (MSSM_SUGRA) call write_real_data_item (u, 1, var_str ("m_zero"), var_list, & "Common scalar mass") call write_real_data_item (u, 2, var_str ("m_half"), var_list, & "Common gaugino mass") call write_real_data_item (u, 3, var_str ("tanb"), var_list, & "tan(beta)") call write_integer_data_item (u, 4, & var_str ("sgn_mu"), var_list, & "Sign of mu") call write_real_data_item (u, 5, var_str ("A0"), var_list, & "Common trilinear coupling") case (MSSM_GMSB) call write_real_data_item (u, 1, var_str ("Lambda"), var_list, & "Soft-breaking scale") call write_real_data_item (u, 2, var_str ("M_mes"), var_list, & "Messenger scale") call write_real_data_item (u, 3, var_str ("tanb"), var_list, & "tan(beta)") call write_integer_data_item (u, 4, & var_str ("sgn_mu"), var_list, & "Sign of mu") call write_integer_data_item (u, 5, var_str ("N_5"), var_list, & "Messenger index") call write_real_data_item (u, 6, var_str ("c_grav"), var_list, & "Gravitino mass factor") case (MSSM_AMSB) call write_real_data_item (u, 1, var_str ("m_zero"), var_list, & "Common scalar mass") call write_real_data_item (u, 2, var_str ("m_grav"), var_list, & "Gravitino mass") call write_real_data_item (u, 3, var_str ("tanb"), var_list, & "tan(beta)") call write_integer_data_item (u, 4, & var_str ("sgn_mu"), var_list, & "Sign of mu") case default call write_real_data_item (u, 3, var_str ("tanb"), var_list, & "tan(beta)") end select end subroutine slha_write_MINPAR @ %def slha_write_MINPAR @ \subsubsection{Mass spectrum} Set masses. Since the particles are identified by PDG code, read the line and try to set the appropriate particle mass in the current model. At the end, update parameters, just in case the $W$ or $Z$ mass was included. <>= subroutine slha_handle_MASS (parse_tree, model) type(parse_tree_t), intent(in) :: parse_tree type(model_t), intent(inout), target :: model type(parse_node_t), pointer :: pn_block, pn_data, pn_line, pn_code type(parse_node_t), pointer :: pn_mass integer :: pdg real(default) :: mass pn_block => slha_get_block_ptr & (parse_tree, var_str ("MASS"), required=.true.) if (.not. (associated (pn_block))) return pn_data => parse_node_get_sub_ptr (pn_block, 4) do while (associated (pn_data)) pn_line => parse_node_get_sub_ptr (pn_data, 2) pn_code => parse_node_get_sub_ptr (pn_line) if (associated (pn_code)) then pdg = get_integer_parameter (pn_code) pn_mass => parse_node_get_next_ptr (pn_code) if (associated (pn_mass)) then mass = get_real_parameter (pn_mass) call model%set_field_mass (pdg, mass) else call msg_error ("SLHA: Block MASS: Missing mass value") end if else call msg_error ("SLHA: Block MASS: Missing PDG code") end if pn_data => parse_node_get_next_ptr (pn_data) end do end subroutine slha_handle_MASS @ %def slha_handle_MASS @ \subsubsection{Widths} Set widths. For each DECAY block, extract the header, read the PDG code and width, and try to set the appropriate particle width in the current model. <>= subroutine slha_handle_decays (parse_tree, model) type(parse_tree_t), intent(in) :: parse_tree type(model_t), intent(inout), target :: model type(parse_node_t), pointer :: pn_decay, pn_decay_spec, pn_code, pn_width integer :: pdg real(default) :: width pn_decay => slha_get_first_decay_ptr (parse_tree) do while (associated (pn_decay)) pn_decay_spec => parse_node_get_sub_ptr (pn_decay, 2) pn_code => parse_node_get_sub_ptr (pn_decay_spec) pdg = get_integer_parameter (pn_code) pn_width => parse_node_get_next_ptr (pn_code) width = get_real_parameter (pn_width) call model%set_field_width (pdg, width) pn_decay => slha_get_next_decay_ptr (pn_decay) end do end subroutine slha_handle_decays @ %def slha_handle_decays @ \subsubsection{Mixing matrices} Read mixing matrices. We can treat all matrices by a single procedure if we just know the block name, variable prefix, and matrix dimension. The matrix dimension must be less than 10. For the pseudoscalar Higgses in NMSSM-type models we need off-diagonal matrices, so we generalize the definition. <>= subroutine slha_handle_matrix_block & (parse_tree, block_name, var_prefix, dim1, dim2, model) type(parse_tree_t), intent(in) :: parse_tree character(*), intent(in) :: block_name, var_prefix integer, intent(in) :: dim1, dim2 type(model_t), intent(inout), target :: model type(parse_node_t), pointer :: pn_block type(var_list_t), pointer :: var_list integer :: i, j character(len=len(var_prefix)+2) :: var_name var_list => model%get_var_list_ptr () pn_block => slha_get_block_ptr & (parse_tree, var_str (block_name), required=.false.) if (.not. (associated (pn_block))) return do i = 1, dim1 do j = 1, dim2 write (var_name, "(A,I1,I1)") var_prefix, i, j call set_matrix_element (pn_block, i, j, var_str (var_name), var_list) end do end do end subroutine slha_handle_matrix_block @ %def slha_handle_matrix_block @ \subsubsection{Higgs data} Read the block ALPHA which holds just the Higgs mixing angle. <>= subroutine slha_handle_ALPHA (parse_tree, model) type(parse_tree_t), intent(in) :: parse_tree type(model_t), intent(inout), target :: model type(parse_node_t), pointer :: pn_block, pn_line, pn_data, pn_item type(var_list_t), pointer :: var_list real(default) :: al_h var_list => model%get_var_list_ptr () pn_block => slha_get_block_ptr & (parse_tree, var_str ("ALPHA"), required=.false.) if (.not. (associated (pn_block))) return pn_data => parse_node_get_sub_ptr (pn_block, 4) pn_line => parse_node_get_sub_ptr (pn_data, 2) pn_item => parse_node_get_sub_ptr (pn_line) if (associated (pn_item)) then al_h = get_real_parameter (pn_item) call var_list%set_real (var_str ("al_h"), al_h, & is_known=.true., ignore=.true.) end if end subroutine slha_handle_ALPHA @ %def slha_handle_matrix_block @ Read the block HMIX for the Higgs mixing parameters <>= subroutine slha_handle_HMIX (parse_tree, model) type(parse_tree_t), intent(in) :: parse_tree type(model_t), intent(inout), target :: model type(parse_node_t), pointer :: pn_block type(var_list_t), pointer :: var_list var_list => model%get_var_list_ptr () pn_block => slha_get_block_ptr & (parse_tree, var_str ("HMIX"), required=.false.) if (.not. (associated (pn_block))) return call set_data_item (pn_block, 1, var_str ("mu_h"), var_list) call set_data_item (pn_block, 2, var_str ("tanb_h"), var_list) end subroutine slha_handle_HMIX @ %def slha_handle_HMIX @ Read the block NMSSMRUN for the specific NMSSM parameters <>= subroutine slha_handle_NMSSMRUN (parse_tree, model) type(parse_tree_t), intent(in) :: parse_tree type(model_t), intent(inout), target :: model type(parse_node_t), pointer :: pn_block type(var_list_t), pointer :: var_list var_list => model%get_var_list_ptr () pn_block => slha_get_block_ptr & (parse_tree, var_str ("NMSSMRUN"), required=.false.) if (.not. (associated (pn_block))) return call set_data_item (pn_block, 1, var_str ("ls"), var_list) call set_data_item (pn_block, 2, var_str ("ks"), var_list) call set_data_item (pn_block, 3, var_str ("a_ls"), var_list) call set_data_item (pn_block, 4, var_str ("a_ks"), var_list) call set_data_item (pn_block, 5, var_str ("nmu"), var_list) end subroutine slha_handle_NMSSMRUN @ %def slha_handle_NMSSMRUN @ \subsection{Parser} Read a SLHA file from stream, including preprocessing, and make up a parse tree. <>= subroutine slha_parse_stream (stream, parse_tree) type(stream_t), intent(inout), target :: stream type(parse_tree_t), intent(out) :: parse_tree type(ifile_t) :: ifile type(lexer_t) :: lexer type(stream_t), target :: stream_tmp call slha_preprocess (stream, ifile) call stream_init (stream_tmp, ifile) call lexer_init_slha (lexer) call lexer_assign_stream (lexer, stream_tmp) call parse_tree_init (parse_tree, syntax_slha, lexer) call lexer_final (lexer) call stream_final (stream_tmp) call ifile_final (ifile) end subroutine slha_parse_stream @ %def slha_parse_stream @ Read a SLHA file chosen by name. Check first the current directory, then the directory where SUSY input files should be located. Required for test: <>= public :: slha_parse_file <>= subroutine slha_parse_file (file, os_data, parse_tree) type(string_t), intent(in) :: file type(os_data_t), intent(in) :: os_data type(parse_tree_t), intent(out) :: parse_tree logical :: exist type(string_t) :: filename type(stream_t), target :: stream call msg_message ("Reading SLHA input file '" // char (file) // "'") filename = file inquire (file=char(filename), exist=exist) if (.not. exist) then filename = os_data%whizard_susypath // "/" // file inquire (file=char(filename), exist=exist) if (.not. exist) then call msg_fatal ("SLHA input file '" // char (file) // "' not found") return end if end if call stream_init (stream, char (filename)) call slha_parse_stream (stream, parse_tree) call stream_final (stream) end subroutine slha_parse_file @ %def slha_parse_file @ \subsection{API} Read the SLHA file, parse it, and interpret the parse tree. The model parameters retrieved from the file will be inserted into the appropriate model, which is loaded and modified in the background. The pointer to this model is returned as the last argument. <>= public :: slha_read_file <>= subroutine slha_read_file & (file, os_data, model, input, spectrum, decays) type(string_t), intent(in) :: file type(os_data_t), intent(in) :: os_data type(model_t), intent(inout), target :: model logical, intent(in) :: input, spectrum, decays type(parse_tree_t) :: parse_tree call slha_parse_file (file, os_data, parse_tree) if (associated (parse_tree%get_root_ptr ())) then call slha_interpret_parse_tree & (parse_tree, model, input, spectrum, decays) call parse_tree_final (parse_tree) call model%update_parameters () end if end subroutine slha_read_file @ %def slha_read_file @ Write the SLHA contents, as far as possible, to external file. <>= public :: slha_write_file <>= subroutine slha_write_file (file, model, input, spectrum, decays) type(string_t), intent(in) :: file type(model_t), target, intent(in) :: model logical, intent(in) :: input, spectrum, decays integer :: mssm_type integer :: u u = free_unit () call msg_message ("Writing SLHA output file '" // char (file) // "'") open (unit=u, file=char(file), action="write", status="replace") write (u, "(A)") "# SUSY Les Houches Accord" write (u, "(A)") "# Output generated by " // trim (VERSION_STRING) call slha_write_MODSEL (u, model, mssm_type) if (input) then call slha_write_SMINPUTS (u, model) call slha_write_MINPAR (u, model, mssm_type) end if if (spectrum) then call msg_bug ("SLHA: spectrum output not supported yet") end if if (decays) then call msg_bug ("SLHA: decays output not supported yet") end if close (u) end subroutine slha_write_file @ %def slha_write_file @ \subsection{Dispatch} <>= public :: dispatch_slha <>= subroutine dispatch_slha (var_list, input, spectrum, decays) type(var_list_t), intent(inout), target :: var_list logical, intent(out) :: input, spectrum, decays input = var_list%get_lval (var_str ("?slha_read_input")) spectrum = var_list%get_lval (var_str ("?slha_read_spectrum")) decays = var_list%get_lval (var_str ("?slha_read_decays")) end subroutine dispatch_slha @ %def dispatch_slha @ \subsection{Unit tests} Test module, followed by the corresponding implementation module. <<[[slha_interface_ut.f90]]>>= <> module slha_interface_ut use unit_tests use slha_interface_uti <> <> contains <> end module slha_interface_ut @ %def slha_interface_ut @ <<[[slha_interface_uti.f90]]>>= <> module slha_interface_uti <> use io_units use os_interface use parser use model_data use variables use models use slha_interface <> <> contains <> end module slha_interface_uti @ %def slha_interface_ut @ API: driver for the unit tests below. <>= public :: slha_test <>= subroutine slha_test (u, results) integer, intent(in) :: u type(test_results_t), intent(inout) :: results <> end subroutine slha_test @ %def slha_test @ Checking the basics of the SLHA interface. <>= call test (slha_1, "slha_1", & "check SLHA interface", & u, results) <>= public :: slha_1 <>= subroutine slha_1 (u) integer, intent(in) :: u type(os_data_t), pointer :: os_data => null () type(parse_tree_t), pointer :: parse_tree => null () integer :: u_file, iostat character(80) :: buffer character(*), parameter :: file_slha = "slha_test.dat" type(model_list_t) :: model_list type(model_t), pointer :: model => null () write (u, "(A)") "* Test output: SLHA Interface" write (u, "(A)") "* Purpose: test SLHA file reading and writing" write (u, "(A)") write (u, "(A)") "* Initializing" write (u, "(A)") allocate (os_data) allocate (parse_tree) call os_data%init () call syntax_model_file_init () call model_list%read_model & (var_str("MSSM"), var_str("MSSM.mdl"), os_data, model) call syntax_slha_init () write (u, "(A)") "* Reading SLHA file sps1ap_decays.slha" write (u, "(A)") call slha_parse_file (var_str ("sps1ap_decays.slha"), os_data, parse_tree) write (u, "(A)") "* Writing the parse tree:" write (u, "(A)") call parse_tree_write (parse_tree, u) write (u, "(A)") "* Interpreting the parse tree" write (u, "(A)") call slha_interpret_parse_tree (parse_tree, model, & input=.true., spectrum=.true., decays=.true.) call parse_tree_final (parse_tree) write (u, "(A)") "* Writing out the list of variables (reals only):" write (u, "(A)") call var_list_write (model%get_var_list_ptr (), & only_type = V_REAL, unit = u) write (u, "(A)") write (u, "(A)") "* Writing SLHA output to '" // file_slha // "'" write (u, "(A)") call slha_write_file (var_str (file_slha), model, input=.true., & spectrum=.false., decays=.false.) u_file = free_unit () open (u_file, file = file_slha, action = "read", status = "old") do read (u_file, "(A)", iostat = iostat) buffer if (buffer(1:37) == "# Output generated by WHIZARD version") then buffer = "[...]" end if if (iostat /= 0) exit write (u, "(A)") trim (buffer) end do close (u_file) write (u, "(A)") write (u, "(A)") "* Cleanup" write (u, "(A)") call parse_tree_final (parse_tree) deallocate (parse_tree) deallocate (os_data) write (u, "(A)") "* Test output end: slha_1" write (u, "(A)") end subroutine slha_1 @ %def slha_1 @ \subsubsection{SLHA interface} This rather trivial sets all input values for the SLHA interface to [[false]]. <>= call test (slha_2, "slha_2", & "SLHA interface", & u, results) <>= public :: slha_2 <>= subroutine slha_2 (u) integer, intent(in) :: u type(var_list_t) :: var_list logical :: input, spectrum, decays write (u, "(A)") "* Test output: slha_2" write (u, "(A)") "* Purpose: SLHA interface settings" write (u, "(A)") write (u, "(A)") "* Default settings" write (u, "(A)") call var_list%init_defaults (0) call dispatch_slha (var_list, & input = input, spectrum = spectrum, decays = decays) write (u, "(A,1x,L1)") " slha_read_input =", input write (u, "(A,1x,L1)") " slha_read_spectrum =", spectrum write (u, "(A,1x,L1)") " slha_read_decays =", decays call var_list%final () call var_list%init_defaults (0) write (u, "(A)") write (u, "(A)") "* Set all entries to [false]" write (u, "(A)") call var_list%set_log (var_str ("?slha_read_input"), & .false., is_known = .true.) call var_list%set_log (var_str ("?slha_read_spectrum"), & .false., is_known = .true.) call var_list%set_log (var_str ("?slha_read_decays"), & .false., is_known = .true.) call dispatch_slha (var_list, & input = input, spectrum = spectrum, decays = decays) write (u, "(A,1x,L1)") " slha_read_input =", input write (u, "(A,1x,L1)") " slha_read_spectrum =", spectrum write (u, "(A,1x,L1)") " slha_read_decays =", decays call var_list%final () write (u, "(A)") write (u, "(A)") "* Test output end: slha_2" end subroutine slha_2 @ %def slha_2 Index: trunk/omega/src/sets.ml =================================================================== --- trunk/omega/src/sets.ml (revision 0) +++ trunk/omega/src/sets.ml (revision 8253) @@ -0,0 +1,27 @@ +(* sets.ml -- + + Copyright (C) 2019- by + + Wolfgang Kilian + Thorsten Ohl + Juergen Reuter + + WHIZARD is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + WHIZARD is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) + +module String = + Set.Make (struct type t = string let compare = compare end) + +module Int = + Set.Make (struct type t = int let compare = compare end) Index: trunk/omega/src/omega.tex =================================================================== --- trunk/omega/src/omega.tex (revision 8252) +++ trunk/omega/src/omega.tex (revision 8253) @@ -1,1175 +1,1177 @@ % omega.tex -- %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \NeedsTeXFormat{LaTeX2e} \RequirePackage{ifpdf} \ifpdf \documentclass[a4paper,notitlepage,chapters]{flex} \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} \setlength{\unitlength}{1mm} \empaddtoTeX{\usepackage{amsmath,amssymb}} \empaddtoTeX{\usepackage{thophys,thohacks}} \empaddtoprelude{input graph;} \empaddtoprelude{input boxes;} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% %%% 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{\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 \begin{itemize} \item Wolfgang~Kilian ~\texttt{} \item Thorsten~Ohl~\texttt{} \item J\"urgen~Reuter~\texttt{} \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 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{Color} \label{sec:color} \module{color} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Fusions} \label{sec:fusion} \module{fusion} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Lorentz Representations, Couplings, Models and Targets} \label{sec:coupling} \signature{coupling} \signature{model} \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{UFO Models} \label{sec:ufo} \section{Abstract Expression Syntax} \module{UFOx_syntax} \section{Expression Lexer} \lexer{UFOx} \section{Expression Parser} \parser{UFOx} \section{Expressions} \module{UFOx} \section{Abstract Syntax} \module{UFO_syntax} \section{Lexer} \lexer{UFO} \section{Parser} \parser{UFO} \section{Models} \module{UFO} - +\section{Targets} +\module{UFO_targets} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Hardcoded Targets} \label{sec:targets} +\module{format_Fortran} \module{targets} \module{targets_Kmatrix} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Phase Space} \label{sec:phasespace} \module{phasespace} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Whizard} \label{sec:whizard} Talk to~\cite{Kilian:WHIZARD}. \module{whizard} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{Applications} \label{sec:omega} \section{Sample} {\small\verbatiminput{sample.prc}} \module{omega} %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{O'Giga: O'Mega Graphical Interface for Generation and Analysis} %%% \label{sec:ogiga} %%% {\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} %%% %%% \application{ogiga} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \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. \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} \end{thebibliography} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \appendix %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \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{More On Arrays} \label{sec:thoarray} \module{thoArray} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \chapter{More On Strings} \label{sec:thostring} \module{thoString} %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% \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{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{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/test_ufo.sh =================================================================== --- trunk/omega/src/test_ufo.sh (revision 0) +++ trunk/omega/src/test_ufo.sh (revision 8253) @@ -0,0 +1,9 @@ +#! /bin/sh +jobs=12 +UFO=$HOME/physics/SM/ +root=$HOME/physics/whizard +build=$root/_build + +make -j $jobs -C $build/omega/src || exit 1 +make -j $jobs -C $build/omega/tests ufo_unit || exit 1 +$build/omega/tests/ufo_unit "$@" Property changes on: trunk/omega/src/test_ufo.sh ___________________________________________________________________ Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: trunk/omega/src/UFOx_lexer.mll =================================================================== --- trunk/omega/src/UFOx_lexer.mll (revision 8252) +++ trunk/omega/src/UFOx_lexer.mll (revision 8253) @@ -1,73 +1,73 @@ (* vertex_lexer.mll -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) { open Lexing open UFOx_parser let string_of_char c = String.make 1 c let int_of_char c = int_of_string (string_of_char 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 } | ',' { COMMA } | '*' '*' { POWER } | '*' { TIMES } | '/' { DIV } | '+' { PLUS } | '-' { MINUS } - | ( '-'? digit+ as i ) ( '.' '0'* )? + | ( digit+ as i ) ( '.' '0'* )? { INT (int_of_string i) } - | '-'? digit* '.' digit+ ( ['E''e'] '-'? digit+ )? as x + | digit* '.' digit+ ( ['E''e'] '-'? digit+ )? as x { FLOAT (float_of_string x) } | char word* ('.' char word+ )? as s { ID s } | _ as c { failwith ("invalid character at `" ^ string_of_char c ^ "'") } | eof { END } Index: trunk/omega/src/combinatorics.ml =================================================================== --- trunk/omega/src/combinatorics.ml (revision 8252) +++ trunk/omega/src/combinatorics.ml (revision 8253) @@ -1,480 +1,504 @@ (* combinatorics.ml -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) 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 (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) +let permute_cyclic l = + let rec permute_cyclic' acc l1 = function + | [] -> List.rev acc + | x :: rest as l2 -> + permute_cyclic' ((l2 @ List.rev l1) :: acc) (x :: l1) rest + in + permute_cyclic' [] [] 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=Pervasives.compare) l = List.fold_right (insert_inorder_signed cmp) l (1, []) let sign ?(cmp=Pervasives.compare) l = let eps, _ = sort_signed ~cmp l in eps let sign2 ?(cmp=Pervasives.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 suite_permute = + "permute" >::: + [ "cyclic []" >:: + (fun () -> assert_equal [] (permute_cyclic [])); + "cyclic [1]" >:: + (fun () -> assert_equal [[1]] (permute_cyclic [1])); + "cyclic [1;2;3]" >:: + (fun () -> + assert_equal [[1;2;3]; [2;3;1]; [3;1;2]] (permute_cyclic [1;2;3])); + "cyclic [1;2;3;4]" >:: + (fun () -> + assert_equal + [[1;2;3;4]; [2;3;4;1]; [3;4;1;2]; [4;1;2;3]] + (permute_cyclic [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_sort_signed] + [suite_permute; + suite_sort_signed] end (*i * Local Variables: * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/thoList.mli =================================================================== --- trunk/omega/src/thoList.mli (revision 8252) +++ trunk/omega/src/thoList.mli (revision 8253) @@ -1,156 +1,173 @@ (* thoList.mli -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) (* [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 (* [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 (* [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! *) +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 (* [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 val clone : int -> 'a -> 'a list val multiply : int -> 'a list -> 'a list (* \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 (* 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 +val to_string : ('a -> string) -> 'a list -> string + +module Test : sig val suite : OUnit.test end + (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/thoArray.mli =================================================================== --- trunk/omega/src/thoArray.mli (revision 8252) +++ trunk/omega/src/thoArray.mli (revision 8253) @@ -1,67 +1,72 @@ (* thoArray.mli -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) (* 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 (*i * Local Variables: * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/permutation.mli =================================================================== --- trunk/omega/src/permutation.mli (revision 8252) +++ trunk/omega/src/permutation.mli (revision 8253) @@ -1,42 +1,49 @@ (* permutation.mli -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from cf. main AUTHORS file WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) module type T = sig type t val of_list : int list -> t val of_array : int array -> t val inverse : t -> t val compose : 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 + (* Assuming fewer than 10 elements! *) + val to_string : t -> string end module Using_Lists : T module Using_Arrays : T module Default : T module Test : functor (P : T) -> sig val suite : OUnit.test val time : unit -> unit end Index: trunk/omega/src/UFOx.ml =================================================================== --- trunk/omega/src/UFOx.ml (revision 8252) +++ trunk/omega/src/UFOx.ml (revision 8253) @@ -1,774 +1,869 @@ (* vertex.ml -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) let error_in_string text start_pos end_pos = let i = max 0 start_pos.Lexing.pos_cnum in let j = min (String.length text) (max (i + 1) end_pos.Lexing.pos_cnum) in String.sub text i (j - i) let error_in_file name start_pos end_pos = Printf.sprintf "%s:%d.%d-%d.%d" name start_pos.Lexing.pos_lnum (start_pos.Lexing.pos_cnum - start_pos.Lexing.pos_bol) end_pos.Lexing.pos_lnum (end_pos.Lexing.pos_cnum - end_pos.Lexing.pos_bol) module 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 | 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 substitute name value = function | Integer _ | Float _ as e -> e | Variable s as e -> if s = name then value else e | Sum (e1, e2) -> Sum (substitute name value e1, substitute name value e2) | Difference (e1, e2) -> Difference (substitute name value e1, substitute name value e2) | Product (e1, e2) -> Product (substitute name value e1, substitute name value e2) | Quotient (e1, e2) -> Quotient (substitute name value e1, substitute name value e2) | Power (e1, e2) -> Power (substitute name value e1, substitute name value e2) | Application (s, el) -> Application (s, List.map (substitute name value) el) let half name = Quotient (Variable name, Integer 2) end let positive integers = List.filter (fun (i, _) -> i > 0) integers let not_positive integers = List.filter (fun (i, _) -> i <= 0) integers let int_list_to_string is = "[" ^ String.concat ", " (List.map string_of_int is) ^ "]" -module Q = Algebra.Small_Rational - module type Index = sig + (* 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 : (int * 'r) list -> (int * 'r) list + + (* [summation indices] returns all summation indices in the + list [indices], i.\,e.~all negative indices. *) val summation : (int * 'r) list -> (int * 'r) list + val classes_to_string : ('r -> string) -> (int * 'r) list -> string + end module Index : Index = struct let free i = positive i let summation i = not_positive i 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) ^ "=" ^ (int_list_to_string (List.map fst (List.filter (fun (_, r') -> r = r') index_classes)))) reps) ^ "]" end module type Atom = sig type t + val map_indices : (int -> int) -> t -> t val of_expr : string -> UFOx_syntax.expr list -> t val to_string : t -> string type r val classify_indices : t list -> (int * r) list val rep_to_string : r -> string val rep_of_int : int -> r val rep_conjugate : r -> r val rep_trivial : r -> bool type r_omega val omega : r -> r_omega end module type Tensor = sig type atom - type t = (atom list * Q.t) list + type t = (atom list * Algebra.Q.t) list + val map_atoms : (atom -> atom) -> t -> t + val map_indices : (int -> int) -> t -> t 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 -> (int * r) list val rep_to_string : r -> string val rep_of_int : int -> r val rep_conjugate : r -> r val rep_trivial : r -> bool type r_omega val omega : r -> r_omega end module Tensor (A : Atom) : Tensor with type atom = A.t and type r = A.r and type r_omega = A.r_omega = struct module S = UFOx_syntax + module Q = Algebra.Q type atom = A.t type t = (atom list * Q.t) list + let map_atoms f t = + List.map (fun (atoms, q) -> (List.map f atoms, q)) t + + let map_indices f t = + map_atoms (A.map_indices f) t + let multiply (t1, c1) (t2, c2) = (List.sort compare (t1 @ t2), Q.mul c1 c2) let compress terms = List.map (fun (t, cs) -> (t, Q.sum cs)) (ThoList.factorize terms) let rec of_expr e = compress (of_expr' e) and of_expr' = function | S.Integer i -> [([], Q.make i 1)] | S.Float _ -> invalid_arg "UFOx.Tensor.of_expr: unexpected float" | S.Variable name -> invalid_arg ("UFOx.Tensor.of_expr: unexpected variable '" ^ name ^ "'") | S.Application (name, args) -> [([A.of_expr name args], Q.unit)] | S.Sum (e1, e2) -> of_expr e1 @ of_expr e2 | S.Difference (e1, e2) -> of_expr e1 @ of_expr (S.Product (S.Integer (-1), e2)) | S.Product (e1, e2) -> Product.list2 multiply (of_expr e1) (of_expr e2) | S.Quotient (n, d) -> begin match of_expr d with | [([], q)] -> List.map (fun (t, c) -> (t, Q.div c q)) (of_expr n) | [] -> failwith "UFOx.Tensor.of_expr: zero denominator" | _ -> failwith "UFOx.Tensor.of_expr: only integer denominators allowed" end | S.Power (e, p) -> begin match of_expr e, of_expr p with | [([], q)], [([], p)] -> if Q.is_integer p then [([], Q.pow q (Q.to_integer p))] else failwith "UFOx.Tensor.of_expr: rational power" | [([], q)], _ -> failwith "UFOx.Tensor.of_expr: non-numeric power" + | t, [([], p)] -> + if Q.is_null (Q.sub p (Q.make 2 1)) then + Product.list2 multiply t t + else + failwith "UFOx.Tensor.of_expr: only 2 as power of tensor allowed" | _ -> failwith "UFOx.Tensor.of_expr: power of tensor" end type r = A.r let rep_to_string = A.rep_to_string let rep_of_int = A.rep_of_int let rep_conjugate = A.rep_conjugate let rep_trivial = A.rep_trivial let classify_indices' filter tensors = ThoList.uniq (List.sort compare (List.map (fun (t, c) -> filter (A.classify_indices t)) 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 = - let free_indices = classify_indices' Index.free tensors - and summation_indices = classify_indices' Index.summation tensors in - match free_indices, summation_indices with - | [], _ -> failwith "UFOx.Tensor.classify_indices: can't happen!" - | [f], [s] -> f - | [_], _ -> - invalid_arg - "UFOx.Tensor.classify_indices: superfluous summation indices!" - | _, _ -> + 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 of_expr e = let t = of_expr e in let free = classify_indices t in t let of_string s = of_expr (Expr.of_string s) let of_strings s = of_expr (Expr.of_strings s) let term_to_string (tensors, c) = if Q.is_null c then "" else (if Q.is_negative c then " - " else " + ") ^ (let c = Q.abs c in if Q.is_unit c && tensors = [] then "" else Q.to_string c) ^ (match tensors with | [] -> "" | tensors -> (if Q.is_unit (Q.abs c) then "" else "*") ^ String.concat "*" (List.map A.to_string tensors)) let term_to_string (tensors, c) = if Q.is_null c then "" else (if Q.is_negative c then " - " else " + ") ^ (let c = Q.abs c in match tensors with | [] -> Q.to_string c | tensors -> String.concat "*" ((if Q.is_unit c then [] else [Q.to_string c]) @ List.map A.to_string tensors)) let to_string terms = String.concat "" (List.map term_to_string terms) type r_omega = A.r_omega let omega = A.omega end module type Lorentz_Atom = sig - type t = private + + type dirac = private | C of int * int - | Epsilon of int * int * int * int | Gamma of int * int * int | Gamma5 of int * int | Identity of int * int - | Metric of int * int - | P 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 t = private + | Dirac of dirac + | Vector of vector + end module Lorentz_Atom = struct - type t = + + type dirac = | C of int * int - | Epsilon of int * int * int * int | Gamma of int * int * int | Gamma5 of int * int | Identity of int * int - | Metric of int * int - | P 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 t = + | Dirac of dirac + | Vector of vector + 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 to_string = function + 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 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 map_indices f = function + | Dirac d -> Dirac (map_indices_dirac f d) + | Vector v -> Vector (map_indices_vector f v) + + let dirac_to_string = function | C (i, j) -> Printf.sprintf "C(%d,%d)" i j - | Epsilon (mu, nu, ka, la) -> - Printf.sprintf "Epsilon(%d,%d,%d,%d)" mu nu ka la | Gamma (mu, i, j) -> Printf.sprintf "Gamma(%d,%d,%d)" mu i j | Gamma5 (i, j) -> Printf.sprintf "Gamma5(%d,%d)" i j | Identity (i, j) -> Printf.sprintf "Identity(%d,%d)" i j - | Metric (mu, nu) -> - Printf.sprintf "Metric(%d,%d)" mu nu - | P (mu, n) -> - Printf.sprintf "P(%d,%d)" mu n | ProjP (i, j) -> Printf.sprintf "ProjP(%d,%d)" i j | ProjM (i, j) -> Printf.sprintf "ProjM(%d,%d)" i j | Sigma (mu, nu, i, j) -> Printf.sprintf "Sigma(%d,%d,%d,%d)" mu nu i j + let vector_to_string = function + | Epsilon (mu, nu, ka, la) -> + Printf.sprintf "Epsilon(%d,%d,%d,%d)" mu nu ka la + | Metric (mu, nu) -> + Printf.sprintf "Metric(%d,%d)" mu nu + | P (mu, n) -> + Printf.sprintf "P(%d,%d)" mu n + + let to_string = function + | Dirac d -> dirac_to_string d + | Vector v -> vector_to_string v + module S = UFOx_syntax let of_expr name args = match name, args with - | "C", [S.Integer i; S.Integer j] -> C (i, j) + | "C", [S.Integer i; S.Integer j] -> Dirac (C (i, j)) | "C", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to C()" | "Epsilon", [S.Integer mu; S.Integer nu; S.Integer ka; S.Integer la] -> - Epsilon (mu, nu, ka, la) + Vector (Epsilon (mu, nu, ka, la)) | "Epsilon", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Epsilon()" | "Gamma", [S.Integer mu; S.Integer i; S.Integer j] -> - Gamma (mu, i, j) + Dirac (Gamma (mu, i, j)) | "Gamma", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Gamma()" - | "Gamma5", [S.Integer i; S.Integer j] -> Gamma5 (i, j) + | "Gamma5", [S.Integer i; S.Integer j] -> Dirac (Gamma5 (i, j)) | "Gamma5", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Gamma5()" - | "Identity", [S.Integer i; S.Integer j] -> Identity (i, j) + | "Identity", [S.Integer i; S.Integer j] -> Dirac (Identity (i, j)) | "Identity", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Identity()" - | "Metric", [S.Integer mu; S.Integer nu] -> Metric (mu, nu) + | "Metric", [S.Integer mu; S.Integer nu] -> Vector (Metric (mu, nu)) | "Metric", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Metric()" - | "P", [S.Integer mu; S.Integer n] -> P (mu, n) + | "P", [S.Integer mu; S.Integer n] -> Vector (P (mu, n)) | "P", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to P()" - | "ProjP", [S.Integer i; S.Integer j] -> ProjP (i, j) + | "ProjP", [S.Integer i; S.Integer j] -> Dirac (ProjP (i, j)) | "ProjP", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to ProjP()" - | "ProjM", [S.Integer i; S.Integer j] -> ProjM (i, j) + | "ProjM", [S.Integer i; S.Integer j] -> Dirac (ProjM (i, j)) | "ProjM", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to ProjM()" | "Sigma", [S.Integer mu; S.Integer nu; S.Integer i; S.Integer j] -> - Sigma (mu, nu, i, j) + if mu <> nu then + Dirac (Sigma (mu, nu, i, j)) + else + invalid_arg "UFOx.Lorentz.of_expr: implausible arguments to Sigma()" | "Sigma", _ -> invalid_arg "UFOx.Lorentz.of_expr: invalid arguments to Sigma()" | name, _ -> invalid_arg ("UFOx.Lorentz.of_expr: invalid tensor '" ^ name ^ "'") type r = S | V | Sp | CSp | Ghost let rep_trivial = function | S | Ghost -> true | V | Sp | CSp-> false let rep_to_string = function | S -> "0" | V -> "1" | Sp -> "1/2" | CSp-> "1/2bar" | Ghost -> "Ghost" let rep_of_int = function | -1 -> Ghost | 1 -> S | 2 -> Sp | 3 -> V | _ -> invalid_arg "UFOx.Lorentz: impossible representation!" let rep_conjugate = function | S -> S | V -> V | Sp -> CSp (* ??? *) | CSp -> Sp (* ??? *) | Ghost -> Ghost - let classify_indices1 = function + 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)] - | Epsilon (mu, nu, ka, la) -> [(mu, V); (nu, V); (ka, V); (la, V)] | Gamma (mu, i, j) -> [(mu, V); (i, CSp); (j, Sp)] - | Metric (mu, nu) -> [(mu, V); (nu, V)] - | P (mu, n) -> [(mu, V)] | 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 + let classify_indices tensors = List.sort compare (List.fold_right (fun v acc -> classify_indices1 v @ acc) tensors []) type r_omega = Coupling.lorentz let omega = function | S -> Coupling.Scalar | V -> Coupling.Vector | Sp -> Coupling.Spinor | CSp-> Coupling.ConjSpinor | Ghost -> Coupling.Scalar end module Lorentz = Tensor(Lorentz_Atom') module type Color_Atom = sig - type t = private + type t = (* private *) | Identity of int * int + | Identity8 of int * int | T of int * int * int | F of int * int * int | D of int * int * int | Epsilon of int * int * int | EpsilonBar of int * int * int | T6 of int * int * int | K6 of int * int * int | K6Bar of int * int * int end module Color_Atom = struct type t = | Identity of int * int + | Identity8 of int * int | T of int * int * int | F of int * int * int | D of int * int * int | Epsilon of int * int * int | EpsilonBar of int * int * int | T6 of int * int * int | K6 of int * int * int | K6Bar of int * int * int end module Color_Atom' : Atom with type t = Color_Atom.t and type r_omega = Color.t = struct type t = Color_Atom.t module S = UFOx_syntax open Color_Atom + let map_indices f = function + | Identity (i, j) -> Identity (f i, f j) + | Identity8 (a, b) -> Identity8 (f a, f b) + | T (a, i, j) -> T (f a, f i, f j) + | F (a, i, j) -> F (f a, f i, f j) + | D (a, i, j) -> D (f a, f i, f j) + | Epsilon (i, j, k) -> Epsilon (f i, f j, f k) + | EpsilonBar (i, j, k) -> EpsilonBar (f i, f j, f k) + | T6 (a, i', j') -> T6 (f a, f i', f j') + | K6 (i', j, k) -> K6 (f i', f j, f k) + | K6Bar (i', j, k) -> K6Bar (f i', f j, f k) + let of_expr name args = match name, args with | "Identity", [S.Integer i; S.Integer j] -> Identity (i, j) | "Identity", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to Identity()" | "T", [S.Integer a; S.Integer i; S.Integer j] -> T (a, i, j) | "T", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to T()" | "f", [S.Integer a; S.Integer b; S.Integer c] -> F (a, b, c) | "f", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to f()" | "d", [S.Integer a; S.Integer b; S.Integer c] -> D (a, b, c) | "d", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to d()" | "Epsilon", [S.Integer i; S.Integer j; S.Integer k] -> Epsilon (i, j, k) | "Epsilon", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to Epsilon()" | "EpsilonBar", [S.Integer i; S.Integer j; S.Integer k] -> EpsilonBar (i, j, k) | "EpsilonBar", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to EpsilonBar()" | "T6", [S.Integer a; S.Integer i'; S.Integer j'] -> T6 (a, i', j') | "T6", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to T6()" | "K6", [S.Integer i'; S.Integer j; S.Integer k] -> K6 (i', j, k) | "K6", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to K6()" | "K6Bar", [S.Integer i'; S.Integer j; S.Integer k] -> K6Bar (i', j, k) | "K6Bar", _ -> invalid_arg "UFOx.Color.of_expr: invalid arguments to K6Bar()" | name, _ -> invalid_arg ("UFOx.Color.of_expr: invalid tensor '" ^ name ^ "'") let to_string = function | Identity (i, j) -> Printf.sprintf "Identity(%d,%d)" i j + | Identity8 (a, b) -> Printf.sprintf "Identity8(%d,%d)" a b | T (a, i, j) -> Printf.sprintf "T(%d,%d,%d)" a i j | F (a, b, c) -> Printf.sprintf "f(%d,%d,%d)" a b c | D (a, b, c) -> Printf.sprintf "d(%d,%d,%d)" a b c | Epsilon (i, j, k) -> Printf.sprintf "Epsilon(%d,%d,%d)" i j k | EpsilonBar (i, j, k) -> Printf.sprintf "EpsilonBar(%d,%d,%d)" i j k | T6 (a, i', j') -> Printf.sprintf "T6(%d,%d,%d)" a i' j' | K6 (i', j, k) -> Printf.sprintf "K6(%d,%d,%d)" i' j k | K6Bar (i', j, k) -> Printf.sprintf "K6Bar(%d,%d,%d)" i' j k type r = S | Sbar | F | C | A let rep_trivial = function | S | Sbar -> true | F | C | A-> false let rep_to_string = function | S -> "1" | Sbar -> "1bar" | F -> "3" | C -> "3bar" | A-> "8" let rep_of_int = function | 1 -> S | -1 -> Sbar (* UFO appears to use this for colorless antiparticles!. *) | 3 -> F | -3 -> C | 8 -> A | 6 | -6 -> failwith "UFOx.Color: sextets not supported yet!" | _ -> invalid_arg "UFOx.Color: impossible representation!" let rep_conjugate = function | Sbar -> S | S -> Sbar | C -> F | F -> C | A -> A let classify_indices1 = function | Identity (i, j) -> [(i, C); (j, F)] + | Identity8 (a, b) -> [(a, A); (b, A)] | T (a, i, j) -> [(i, F); (j, C); (a, A)] | Color_Atom.F (a, b, c) | D (a, b, c) -> [(a, A); (b, A); (c, A)] | Epsilon (i, j, k) -> [(i, F); (j, F); (k, F)] | EpsilonBar (i, j, k) -> [(i, C); (j, C); (k, C)] | T6 (a, i', j') -> failwith "UFOx.Color: sextets not supported yet!" | K6 (i', j, k) -> failwith "UFOx.Color: sextets not supported yet!" | K6Bar (i', j, k) -> failwith "UFOx.Color: sextets not supported yet!" let classify_indices tensors = List.sort compare (List.fold_right (fun v acc -> classify_indices1 v @ acc) tensors []) type r_omega = Color.t let omega = function | S | Sbar -> Color.Singlet | F -> Color.SUN (3) | C -> Color.SUN (-3) | A-> Color.AdjSUN (3) end module Color = Tensor(Color_Atom') module Value = struct module S = UFOx_syntax + module Q = Algebra.Q type builtin = | Sqrt | Cos | Sin + | Exp | Conj let builtin_to_string = function | Sqrt -> "sqrt" | Cos -> "cos" | Sin -> "sin" + | Exp -> "exp" | Conj -> "conjg" let builtin_of_string = function | "cmath.sqrt" -> Sqrt | "cmath.cos" -> Cos | "cmath.sin" -> Sin + | "cmath.exp" -> Exp | "complexconjugate" -> Conj | name -> failwith ("UFOx.Value: unsupported function: " ^ name) type t = | Integer of int | Rational of Q.t | Real of float | Complex of float * float | Variable of string | Sum of t list | Difference of t * t | Product of t list | Quotient of t * t | Power of t * t | Application of builtin * t list let rec to_string = function | Integer i -> string_of_int i | Rational q -> Q.to_string q | Real x -> string_of_float x | Complex (0.0, 1.0) -> "I" | Complex (0.0, -1.0) -> "-I" | Complex (0.0, i) -> string_of_float i ^ "*I" | Complex (r, 1.0) -> string_of_float r ^ "+I" | Complex (r, -1.0) -> string_of_float r ^ "-I" | Complex (r, i) -> string_of_float r ^ (if i < 0.0 then "-" else "+") ^ string_of_float (abs_float i) ^ "*I" | Variable s -> s | Sum [] -> "0" | Sum [e] -> to_string e | Sum es -> "(" ^ String.concat "+" (List.map maybe_parentheses es) ^ ")" | Difference (e1, e2) -> to_string e1 ^ "-" ^ maybe_parentheses e2 | Product [] -> "1" | Product ((Integer (-1) | Real (-1.)) :: es) -> "-" ^ maybe_parentheses (Product es) | Product es -> String.concat "*" (List.map maybe_parentheses es) | Quotient (e1, e2) -> to_string e1 ^ "/" ^ maybe_parentheses e2 | Power (e1, e2) -> maybe_parentheses e1 ^ "^" ^ maybe_parentheses e2 | Application (f, [Integer i]) -> to_string (Application (f, [Real (float i)])) | Application (f, es) -> builtin_to_string f ^ "(" ^ String.concat "," (List.map to_string es) ^ ")" and maybe_parentheses = function | Integer i as e -> if i < 0 then "(" ^ to_string e ^ ")" else to_string e | Real x as e -> if x < 0.0 then "(" ^ to_string e ^ ")" else to_string e | Complex (x, 0.0) -> to_string (Real x) | Complex (0.0, 1.0) -> "I" | Variable _ | Power (_, _) | Application (_, _) as e -> to_string e | Sum [e] -> to_string e | Product [e] -> maybe_parentheses e | e -> "(" ^ to_string e ^ ")" let rec to_coupling atom = function | Integer i -> Coupling.Const i | Rational q -> let n, d = Q.to_ratio q in Coupling.Quot (Coupling.Const n, Coupling.Const d) | Real x -> Coupling.Atom (atom (string_of_float x)) | Product es -> Coupling.Prod (List.map (to_coupling atom) es) | Variable s -> Coupling.Atom (atom s) | Complex (r, i) -> Coupling.Sum [Coupling.Atom (atom (string_of_float r)); Coupling.Prod [Coupling.I; Coupling.Atom (atom (string_of_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 (Sin, [e]) -> Coupling.Sin (to_coupling atom e) | Application (Cos, [e]) -> Coupling.Cos (to_coupling atom e) + | Application (Exp, [e]) -> Coupling.Exp (to_coupling atom e) | Application (Sqrt, [e]) -> Coupling.Sqrt (to_coupling atom e) | Application (Conj, [e]) -> Coupling.Conj (to_coupling atom e) - | Power (e1, _) -> - invalid_arg "UFOx.Value.to_coupling: non-integer power" - | Application (_, _) -> + | Application (_, []) -> + failwith "UFOx.Value.to_coupling: empty argument list" + | Application (_, _::_) -> failwith "UFOx.Value.to_coupling: more than one argument list" 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.Variable name -> Variable name | S.Sum (e1, e2) -> begin match of_expr e1, of_expr e2 with | (Integer 0 | Real 0.), e -> e | e, (Integer 0 | Real 0.) -> e | Sum e1, Sum e2 -> Sum (e1 @ e2) | e1, Sum e2 -> Sum (e1 :: e2) | Sum e1, e2 -> Sum (e2 :: e1) | e1, e2 -> Sum [e1; e2] end | S.Difference (e1, e2) -> begin match of_expr e1, of_expr e2 with | e1, (Integer 0 | Real 0.) -> e1 | e1, e2 -> Difference (e1, e2) end | S.Product (e1, e2) -> begin match of_expr e1, of_expr e2 with | (Integer 0 | Real 0.), _ -> Integer 0 | _, (Integer 0 | Real 0.) -> Integer 0 | (Integer 1 | Real 1.), e -> e | e, (Integer 1 | Real 1.) -> e | Product e1, Product e2 -> Product (e1 @ e2) | e1, Product e2 -> Product (e1 :: e2) | Product e1, e2 -> Product (e2 :: e1) | e1, e2 -> Product [e1; e2] end | S.Quotient (e1, e2) -> begin match of_expr e1, of_expr e2 with | e1, (Integer 0 | Real 0.) -> invalid_arg "UFOx.Value: divide by 0" | e1, (Integer 1 | Real 1.) -> e1 | e1, e2 -> Quotient (e1, e2) end | S.Power (e, p) -> begin match of_expr e, of_expr p with | (Integer 0 | Real 0.), (Integer 0 | Real 0.) -> invalid_arg "UFOx.Value: 0^0" | _, (Integer 0 | Real 0.) -> Integer 1 | e, (Integer 1 | Real 1.) -> e | 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 module type Test = sig val example : unit -> unit val suite : OUnit.test end Index: trunk/omega/src/sets.mli =================================================================== --- trunk/omega/src/sets.mli (revision 0) +++ trunk/omega/src/sets.mli (revision 8253) @@ -0,0 +1,24 @@ +(* sets.mli -- + + Copyright (C) 2019- by + + Wolfgang Kilian + Thorsten Ohl + Juergen Reuter + + WHIZARD is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + WHIZARD is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) + +module String : Set.S with type elt = string +module Int : Set.S with type elt = int Index: trunk/omega/src/algebra.ml =================================================================== --- trunk/omega/src/algebra.ml (revision 8252) +++ trunk/omega/src/algebra.ml (revision 8253) @@ -1,415 +1,477 @@ (* algebra.ml -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) (* The terms will be small and there's no need to be fancy and/or efficient. It's more important to have a unique representation. *) module PM = Pmap.List (* \thocwmodulesection{Coefficients} *) (* For our algebra, we need coefficient rings. *) module type CRing = sig type t val null : t val unit : t val mul : t -> t -> t val add : t -> t -> t val sub : t -> t -> t val neg : t -> t val to_string : t -> string end (* And rational numbers provide a particularly important example: *) module type Rational = sig include CRing val is_null : t -> bool val is_unit : t -> bool val is_positive : t -> bool val is_negative : t -> bool val is_integer : t -> bool val make : int -> int -> t val abs : t -> t val inv : t -> t val div : t -> t -> t val pow : t -> int -> t val sum : t list -> t val to_ratio : t -> int * int val to_float : t -> float val to_integer : t -> int end (* \thocwmodulesection{Naive Rational Arithmetic} *) (* \begin{dubious} This \emph{is} dangerous and will overflow even for simple applications. The production code will have to be linked to a library for large integer arithmetic. \end{dubious} *) (* Anyway, here's Euclid's algorithm: *) let rec gcd i1 i2 = if i2 = 0 then abs i1 else gcd i2 (i1 mod i2) let lcm i1 i2 = (i1 / gcd i1 i2) * i2 module Small_Rational : Rational = struct type t = int * int let is_null (n, _) = (n = 0) let is_unit (n, d) = (n <> 0) && (n = d) let is_positive (n, d) = n * d > 0 let is_negative (n, d) = n * d < 0 let is_integer (n, d) = (gcd n d = d) let null = (0, 1) let unit = (1, 1) let make n d = let c = gcd n d in (n / c, d / c) let abs (n, d) = (abs n, abs d) let inv (n, d) = (d, n) let mul (n1, d1) (n2, d2) = make (n1 * n2) (d1 * d2) let div q1 q2 = mul q1 (inv q2) let add (n1, d1) (n2, d2) = make (n1 * d2 + n2 * d1) (d1 * d2) let sub (n1, d1) (n2, d2) = make (n1 * d2 - n2 * d1) (d1 * d2) let neg (n, d) = (- n, d) let rec pow q p = if p = 0 then unit else if p < 0 then pow (inv q) (-p) else mul q (pow q (pred p)) let sum qs = List.fold_right add qs null let to_ratio (n, d) = if d < 0 then (-n, -d) else (n, d) let to_float (n, d) = float n /. float d let to_string (n, d) = if d = 1 then Printf.sprintf "%d" n else let n, d = to_ratio (n, d) in Printf.sprintf "(%d/%d)" n d let to_integer (n, d) = if is_integer (n, d) then n else invalid_arg "Algebra.Small_Rational.to_integer" end +module Q = Small_Rational + +(* \thocwmodulesection{Rational Complex Numbers} *) + +module type QComplex = + sig + + type q + type t + + val make : q -> q -> t + val null : t + val one : t + + val real : t -> q + val imag : t -> q + + val conj : t -> t + val neg : t -> t + + val add : t -> t -> t + val sub : t -> t -> t + val mul : t -> t -> t + + 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 one = { re = Q.unit; im = Q.null } + + let real z = z.re + let imag z = z.im + let conj z = { re = z.re; im = Q.neg z.im } + + let neg z = { re = Q.neg z.re; im = Q.neg z.im } + let add z1 z2 = { re = Q.add z1.re z2.re; im = Q.add z1.im z2.im } + let sub z1 z2 = { re = Q.sub z1.re z2.re; im = Q.sub z1.im z2.im } + +(* 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 } + + end + +module QC = QComplex(Q) + (* \thocwmodulesection{Expressions: Terms, Rings and Linear Combinations} *) (* The tensor algebra will be spanned by an abelian monoid: *) module type Term = sig type 'a t val unit : unit -> 'a t val is_unit : 'a t -> bool val atom : 'a -> 'a t val power : int -> 'a t -> 'a t val mul : 'a t -> 'a t -> 'a t val map : ('a -> 'b) -> 'a t -> 'b t val to_string : ('a -> string) -> 'a t -> string val derive : ('a -> 'b option) -> 'a t -> ('b * int * 'a t) list val product : 'a t list -> 'a t val atoms : 'a t -> 'a list end module type Ring = sig module C : Rational type 'a t val null : unit -> 'a t val unit : unit -> 'a t val is_null : 'a t -> bool val is_unit : 'a t -> bool val atom : 'a -> 'a t val scale : C.t -> 'a t -> 'a t val add : 'a t -> 'a t -> 'a t val sub : 'a t -> 'a t -> 'a t val mul : 'a t -> 'a t -> 'a t val neg : 'a t -> 'a t val derive_inner : ('a -> 'a t) -> 'a t -> 'a t (* this? *) val derive_inner' : ('a -> 'a t option) -> 'a t -> 'a t (* or that? *) val derive_outer : ('a -> 'b option) -> 'a t -> ('b * 'a t) list val sum : 'a t list -> 'a t val product : 'a t list -> 'a t val atoms : 'a t -> 'a list val to_string : ('a -> string) -> 'a t -> string end module type Linear = sig module C : Ring type ('a, 'c) t val null : unit -> ('a, 'c) t val atom : 'a -> ('a, 'c) t val singleton : 'c C.t -> 'a -> ('a, 'c) t val scale : 'c C.t -> ('a, 'c) t -> ('a, 'c) t val add : ('a, 'c) t -> ('a, 'c) t -> ('a, 'c) t val sub : ('a, 'c) t -> ('a, 'c) t -> ('a, 'c) t val partial : ('c -> ('a, 'c) t) -> 'c C.t -> ('a, 'c) t val linear : (('a, 'c) t * 'c C.t) list -> ('a, 'c) t val map : ('a -> 'c C.t -> ('b, 'd) t) -> ('a, 'c) t -> ('b, 'd) t val sum : ('a, 'c) t list -> ('a, 'c) t val atoms : ('a, 'c) t -> 'a list * 'c list val to_string : ('a -> string) -> ('c -> string) -> ('a, 'c) t -> string end module Term : Term = struct module M = PM type 'a t = ('a, int) M.t let unit () = M.empty let is_unit = M.is_empty let atom f = M.singleton f 1 let power p x = M.map (( * ) p) x let insert1 binop f p term = let p' = binop (try M.find compare f term with Not_found -> 0) p in if p' = 0 then M.remove compare f term else M.add compare f p' term let mul1 f p term = insert1 (+) f p term let mul x y = M.fold mul1 x y let map f term = M.fold (fun t -> mul1 (f t)) term M.empty let to_string fmt term = String.concat "*" (M.fold (fun f p acc -> (if p = 0 then "1" else if p = 1 then fmt f else "[" ^ fmt f ^ "]^" ^ string_of_int p) :: acc) term []) let derive derive1 x = M.fold (fun f p dx -> if p <> 0 then match derive1 f with | Some df -> (df, p, mul1 f (pred p) (M.remove compare f x)) :: dx | None -> dx else dx) x [] let product factors = List.fold_left mul (unit ()) factors let atoms t = List.map fst (PM.elements t) end module Make_Ring (C : Rational) (T : Term) : Ring = struct module C = C let one = C.unit module M = PM type 'a t = ('a T.t, C.t) M.t let null () = M.empty let is_null = M.is_empty let power t p = M.singleton t p let unit () = power (T.unit ()) one let is_unit t = unit () = t (* \begin{dubious} The following should be correct too, but produces to many false positives instead! What's going on? \end{dubious} *) let broken__is_unit t = match M.elements t with | [(t, p)] -> T.is_unit t || C.is_null p | _ -> false let atom t = power (T.atom t) one let scale c x = M.map (C.mul c) x let insert1 binop t c sum = let c' = binop (try M.find compare t sum with Not_found -> C.null) c in if C.is_null c' then M.remove compare t sum else M.add compare t c' sum let add x y = M.fold (insert1 C.add) x y let sub x y = M.fold (insert1 C.sub) y x (* One might be tempted to use [Product.outer_self M.fold] instead, but this would require us to combine~[tx] and~[cx] to~[(tx, cx)]. *) let fold2 f x y = M.fold (fun tx cx -> M.fold (f tx cx) y) x let mul x y = fold2 (fun tx cx ty cy -> insert1 C.add (T.mul tx ty) (C.mul cx cy)) x y (null ()) let neg x = sub (null ()) x let neg x = scale (C.neg C.unit) x (* Multiply the [derivatives] by [c] and add the result to [dx]. *) let add_derivatives derivatives c dx = List.fold_left (fun acc (df, dt_c, dt_t) -> add (mul df (power dt_t (C.mul c (C.make dt_c 1)))) acc) dx derivatives let derive_inner derive1 x = M.fold (fun t -> add_derivatives (T.derive (fun f -> Some (derive1 f)) t)) x (null ()) let derive_inner' derive1 x = M.fold (fun t -> add_derivatives (T.derive derive1 t)) x (null ()) let collect_derivatives derivatives c dx = List.fold_left (fun acc (df, dt_c, dt_t) -> (df, power dt_t (C.mul c (C.make dt_c 1))) :: acc) dx derivatives let derive_outer derive1 x = M.fold (fun t -> collect_derivatives (T.derive derive1 t)) x [] let sum terms = List.fold_left add (null ()) terms let product factors = List.fold_left mul (unit ()) factors let atoms t = ThoList.uniq (List.sort compare (ThoList.flatmap (fun (t, _) -> T.atoms t) (PM.elements t))) let to_string fmt sum = "(" ^ String.concat " + " (M.fold (fun t c acc -> if C.is_null c then acc else if C.is_unit c then T.to_string fmt t :: acc else if C.is_unit (C.neg c) then ("(-" ^ T.to_string fmt t ^ ")") :: acc else (C.to_string c ^ "*[" ^ T.to_string fmt t ^ "]") :: acc) sum []) ^ ")" end module Make_Linear (C : Ring) : Linear with module C = C = struct module C = C module M = PM type ('a, 'c) t = ('a, 'c C.t) M.t let null () = M.empty let is_null = M.is_empty let atom a = M.singleton a (C.unit ()) let singleton c a = M.singleton a c let scale c x = M.map (C.mul c) x let insert1 binop t c sum = let c' = binop (try M.find compare t sum with Not_found -> C.null ()) c in if C.is_null c' then M.remove compare t sum else M.add compare t c' sum let add x y = M.fold (insert1 C.add) x y let sub x y = M.fold (insert1 C.sub) y x let map f t = M.fold (fun a c -> add (f a c)) t M.empty let sum terms = List.fold_left add (null ()) terms let linear terms = List.fold_left (fun acc (a, c) -> add (scale c a) acc) (null ()) terms let partial derive t = let d t' = let dt' = derive t' in if is_null dt' then None else Some dt' in linear (C.derive_outer d t) let atoms t = let a, c = List.split (PM.elements t) in (a, ThoList.uniq (List.sort compare (ThoList.flatmap C.atoms c))) let to_string fmt cfmt sum = "(" ^ String.concat " + " (M.fold (fun t c acc -> if C.is_null c then acc else if C.is_unit c then fmt t :: acc else if C.is_unit (C.neg c) then ("(-" ^ fmt t ^ ")") :: acc else (C.to_string cfmt c ^ "*" ^ fmt t) :: acc) sum []) ^ ")" end (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/run_fortran_unit.sh =================================================================== --- trunk/omega/src/run_fortran_unit.sh (revision 0) +++ trunk/omega/src/run_fortran_unit.sh (revision 8253) @@ -0,0 +1,46 @@ +#! /bin/sh +######################################################################## +# This script is for developers only and needs not to be portable. +# This script assumes an opam installation with many versions of +# O'Caml available as switches. +######################################################################## +# tl;dr : don't try this at home, kids ;) +######################################################################## + +src=$(dirname $(realpath $0)) +tmp=$(mktemp -d) + +trap "rm -fr $tmp" 0 1 2 3 15 + +cd $tmp || exit 2 + +cp -a \ + $src/fortran_unit.ml \ + $src/format_Fortran.mli $src/format_Fortran*.ml \ + $src/OUnit.mli $src/OUnit.ml \ + . + +compile_and_run () { + switch=$1 + tag=$2 + flags="-w -D $3" + opam switch $switch >/dev/null || exit 2 + opam switch show + eval $(opam env) + rm -f fortran_unit *.o *.cm[iox] + ocamlopt OUnit.mli format_Fortran.mli + ocamlopt $flags -o fortran_unit -I $src unix.cmxa \ + OUnit.ml format_Fortran$tag.ml fortran_unit.ml + ./fortran_unit # -verbose +} + +### Here we will loop over compiler/library versions +compile_and_run 3.12.0 "" +compile_and_run 4.01.0 "" +compile_and_run 4.02.3 "" +compile_and_run 4.03.0 "" +compile_and_run 4.05.0 "" +compile_and_run 4.06.1 "" -unsafe-string +compile_and_run 4.07.1 "" -unsafe-string + +exit 0 Property changes on: trunk/omega/src/run_fortran_unit.sh ___________________________________________________________________ Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: trunk/omega/src/algebra.mli =================================================================== --- trunk/omega/src/algebra.mli (revision 8252) +++ trunk/omega/src/algebra.mli (revision 8253) @@ -1,195 +1,223 @@ (* algebra.mli -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) (* \thocwmodulesection{Coefficients} *) (* For our algebra, we need coefficient rings. *) module type CRing = sig type t val null : t val unit : t val mul : t -> t -> t val add : t -> t -> t val sub : t -> t -> t val neg : t -> t val to_string : t -> string end (* And rational numbers provide a particularly important example: *) module type Rational = sig include CRing val is_null : t -> bool val is_unit : t -> bool val is_positive : t -> bool val is_negative : t -> bool val is_integer : t -> bool val make : int -> int -> t val abs : t -> t val inv : t -> t val div : t -> t -> t val pow : t -> int -> t val sum : t list -> t val to_ratio : t -> int * int val to_float : t -> float val to_integer : t -> int 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 + + val make : q -> q -> t + val null : t + val one : t + + val real : t -> q + val imag : t -> q + + val conj : t -> t + val neg : t -> t + + val add : t -> t -> t + val sub : t -> t -> t + val mul : t -> t -> t + + end + +module QComplex : functor (Q' : Rational) -> QComplex with type q = Q'.t +module QC : QComplex with type q = Q.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 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 (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * compile-command:"ocamlc -o vertex thoList.ml{i,} pmap.ml{i,} vertex.ml" * End: i*) Index: trunk/omega/src/vertex.ml =================================================================== --- trunk/omega/src/vertex.ml (revision 8252) +++ trunk/omega/src/vertex.ml (revision 8253) @@ -1,1694 +1,1695 @@ (* vertex.ml -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) module type 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 = Pervasives.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 = Pervasives.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 = Pervasives.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; rhs2] = rhs in + 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/UFO_targets.ml =================================================================== --- trunk/omega/src/UFO_targets.ml (revision 0) +++ trunk/omega/src/UFO_targets.ml (revision 8253) @@ -0,0 +1,1657 @@ +(* uFO_targets.ml -- + + Copyright (C) 1999-2017 by + + Wolfgang Kilian + Thorsten Ohl + Juergen Reuter + with contributions from + Christian Speckner + + WHIZARD is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + WHIZARD is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) + +let (@@) f g x = + f (g x) + +(* \thocwmodulesection{Dirac $\gamma$-matrices} *) + +module type Dirac = + sig + + (* Matrices with complex rational entries. *) + type qc = Algebra.QC.t + type t = qc array array + + (* Complex rational constants. *) + val zero : qc + val one : qc + val minus_one : qc + val i : qc + val minus_i : qc + + (* Basic $\gamma$-matrices. *) + val unit : t + val null : t + val gamma0 : t + val gamma1 : t + val gamma2 : t + val gamma3 : t + val gamma5 : t + + (* $(\gamma_0,\gamma_1,\gamma_2,\gamma_3)$ *) + val gamma : t array + + (* Charge conjugation *) + val cc : t + + (* Algebraic operations on $\gamma$-matrices *) + val neg : t -> t + val add : t -> t -> t + val sub : t -> t -> t + val mul : t -> t -> t + val times : qc -> t -> t + val transpose : t -> t + val adjoint : t -> t + val conj : t -> t + val product : t list -> t + + (* Unit tests *) + val test_suite : OUnit.test + end + +(* Chiral representation *) +module Dirac : Dirac = + struct + + module Q = Algebra.Q + module QC = Algebra.QC + + type qc = QC.t + type t = qc array array + + let zero = QC.null + let one = QC.one + let minus_one = QC.neg one + let i = QC.make Q.null Q.unit + let minus_i = QC.conj i + + let null = + [| [| zero; zero; zero; zero |]; + [| zero; zero; zero; zero |]; + [| zero; zero; zero; zero |]; + [| zero; zero; zero; zero |] |] + + let unit = + [| [| one; zero; zero; zero |]; + [| zero; one; zero; zero |]; + [| zero; zero; one; zero |]; + [| zero; zero; zero; one |] |] + + let gamma0 = + [| [| zero; zero; one; zero |]; + [| zero; zero; zero; one |]; + [| one; zero; zero; zero |]; + [| zero; one; zero; zero |] |] + + let gamma1 = + [| [| zero; zero; zero; one |]; + [| zero; zero; one; zero |]; + [| zero; minus_one; zero; zero |]; + [| minus_one; zero; zero; zero |] |] + + let gamma2 = + [| [| zero; zero; zero; minus_i |]; + [| zero; zero; i; zero |]; + [| zero; i; zero; zero |]; + [| minus_i; zero; zero; zero |] |] + + let gamma3 = + [| [| zero; zero; one; zero |]; + [| zero; zero; zero; minus_one |]; + [| minus_one; zero; zero; zero |]; + [| zero; one; zero; zero |] |] + + let gamma5 = + [| [| minus_one; zero; zero; zero |]; + [| zero; minus_one; zero; zero |]; + [| zero; zero; one; zero |]; + [| zero; zero; zero; one |] |] + + let gamma = + [| gamma0; gamma1; gamma2; gamma3 |] + + let cc = + [| [| zero; minus_one; zero; zero |]; + [| one; zero; zero; zero |]; + [| zero; zero; zero; one |]; + [| zero; zero; minus_one; zero |] |] + + 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 + + open OUnit + + let two = QC.make (Q.make 2 1) Q.null + let half = QC.make (Q.make 1 2) Q.null + let two_unit = times two unit + + let ac_lhs mu nu = + add (mul gamma.(mu) gamma.(nu)) (mul gamma.(nu) gamma.(mu)) + + let ac_rhs mu nu = + if mu = nu then + if mu = 0 then + two_unit + else + neg two_unit + else + null + + let test_ac mu nu = + (ac_lhs mu nu) = (ac_rhs mu nu) + + let ac_lhs_all = + let lhs = Array.make_matrix 4 4 null in + for mu = 0 to 3 do + for nu = 0 to 3 do + lhs.(mu).(nu) <- ac_lhs mu nu + done + done; + lhs + + let ac_rhs_all = + let rhs = Array.make_matrix 4 4 null in + for mu = 0 to 3 do + for nu = 0 to 3 do + rhs.(mu).(nu) <- ac_rhs mu nu + done + done; + rhs + + let dump2 lhs rhs = + for i = 0 to 3 do + for j = 0 to 3 do + Printf.printf + " i = %d, j =%d: %s + %s*I | %s + %s*I\n" + i j + (Q.to_string (QC.real lhs.(i).(j))) + (Q.to_string (QC.imag lhs.(i).(j))) + (Q.to_string (QC.real rhs.(i).(j))) + (Q.to_string (QC.imag rhs.(i).(j))) + done + done + + let dump2_all lhs rhs = + for mu = 0 to 3 do + for nu = 0 to 3 do + Printf.printf "mu = %d, nu =%d: \n" mu nu; + dump2 lhs.(mu).(nu) rhs.(mu).(nu) + done + done + + let anticommute = + "anticommutation relations" >:: + (fun () -> + assert_bool + "" + (if ac_lhs_all = ac_rhs_all then + true + else + begin + dump2_all ac_lhs_all ac_rhs_all; + false + end)) + + let equal_or_dump2 lhs rhs = + if lhs = rhs then + true + else + begin + dump2 lhs rhs; + false + end + + let gamma5_def = + "gamma5" >:: + (fun () -> + assert_bool + "definition" + (equal_or_dump2 + gamma5 + (times i (product [gamma0; gamma1; gamma2; gamma3])))) + + let self_adjoint = + "(anti)selfadjointness" >::: + [ "gamma0" >:: + (fun () -> + assert_bool "self" (equal_or_dump2 gamma0 (adjoint gamma0))); + "gamma1" >:: + (fun () -> + assert_bool "anti" (equal_or_dump2 gamma1 (neg (adjoint gamma1)))); + "gamma2" >:: + (fun () -> + assert_bool "anti" (equal_or_dump2 gamma2 (neg (adjoint gamma2)))); + "gamma3" >:: + (fun () -> + assert_bool "anti" (equal_or_dump2 gamma3 (neg (adjoint gamma3)))); + "gamma5" >:: + (fun () -> + assert_bool "self" (equal_or_dump2 gamma5 (adjoint gamma5))) ] + + let cc_inv = neg cc + + let cc_gamma g = + equal_or_dump2 (neg (transpose g)) (product [cc; g; cc_inv]) + + 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]))) + ] + + let test_suite = + "Dirac Matrices" >::: + [anticommute; + gamma5_def; + self_adjoint; + charge_conjugation] + + end + +(* \thocwmodulesection{Generating Code for UFO Lorentz Structures} *) + +(* O'Caml before 4.02 had a module typing bug that forces us to put this + definition outside [Lorentz_Fusion]. *) +module Q = Algebra.Q +module QC = Algebra.QC +module A = UFOx.Lorentz_Atom +module D = Dirac + +module type Lorentz_Fusion = + sig + + (* Just like [UFOx.Lorentz_Atom.dirac], but without the Dirac matrix indices. *) + type dirac = private + | Gamma5 + | ProjM + | ProjP + | Gamma of int + | Sigma of int * int + | C + + (* A sandwich of a string of $\gamma$-matrices. [bra] and [ket] are + positions of fields in the vertex, \emph{not} spinor indices. *) + type dirac_string = private + { bra : int; + ket : int; + gammas : dirac list } + + (* The Lorentz indices appearing in a term are either negative + internal summation indices or positive external polarization + indices. Note that the external + indices are not really indices, but denote the position + of the particle in the vertex. *) + type 'a term = (* private *) + { indices : int list; + atom : 'a } + + (* Split the list of indices into summation and polarization indices. *) + val classify_indices : int list -> int list * int list + + (* Replace the atom keeping the associated indices. *) + val map_atom : ('a -> 'b) -> 'a term -> 'b term + + (* A contraction consists of a (possibly empty) product of + Dirac strings and a (possibly empty) product of Lorentz + tensors with a rational coefficient. The summation + indices could be recovered by scanning the [term]s, but + we maintain a list for efficiency. *) + type contraction = private + { coeff : Q.t; + dirac : dirac_string term list; + vector : UFOx.Lorentz_Atom.vector term list } + + (* A sum. *) + type t = contraction list + + (* [parse spins lorentz] uses the [spins] to parse the + UFO [lorentz] structure as a list of [contraction]s. *) + val parse : Coupling.lorentz list -> UFOx.Lorentz.t -> t + + (* Create a readable representation for debugging and + documenting generated code. *) + val to_string : t -> string + + (* Punting \ldots *) + val dummy : t + + (* More debugging and documenting. *) + val dirac_string_to_string : dirac_string -> string + + (* [dirac_string_to_matrix substitute ds] take a string + of $\gamma$-matrices [ds], applies [substitute] to + the indices and returns the product as a matrix. *) + val dirac_string_to_matrix : (int -> int) -> dirac_string -> D.t + + end + +module Lorentz_Fusion : Lorentz_Fusion = + struct + + (* Take a [A.t list] and return the corresponding pair + [A.dirac list * A.vector list], without preserving the + order (currently, the order is reversed). *) + let split_atoms atoms = + List.fold_left + (fun (d, v) -> function + | A.Vector v' -> (d, v' :: v) + | A.Dirac d' -> (d' :: d, v)) + ([], []) atoms + + (* Just like [UFOx.Lorentz_Atom.dirac], but without the Dirac matrix indices. *) + type dirac = + | Gamma5 + | ProjM + | ProjP + | Gamma of int + | Sigma of int * int + | C + + (* A sandwich of a string of $\gamma$-matrices. [bra] and [ket] are + positions of fields in the vertex. *) + type dirac_string = + { bra : int; + ket : int; + gammas : dirac list } + + (* [dirac_string bind ds] applies the mapping [bind] to the indices + of $\gamma_\mu$ and~$\sigma_{\mu\nu}$ and multiplies the resulting + matrices in order using complex rational arithmetic. *) + module type To_Matrix = + sig + val dirac_string : (int -> int) -> dirac_string -> D.t + end + + module To_Matrix : To_Matrix = + struct + + let half = QC.make (Q.make 1 2) Q.null + let half_i = QC.make Q.null (Q.make 1 2) + + let gamma_L = D.times half (D.sub D.unit D.gamma5) + let gamma_R = D.times half (D.add D.unit D.gamma5) + + let sigma = Array.make_matrix 4 4 D.null + let () = + for mu = 0 to 3 do + for nu = 0 to 3 do + sigma.(mu).(nu) <- + D.times + half_i + (D.sub + (D.mul D.gamma.(mu) D.gamma.(nu)) + (D.mul D.gamma.(nu) D.gamma.(mu))) + done + done + + let dirac bind_indices = function + | Gamma5 -> D.gamma5 + | ProjM -> gamma_L + | ProjP -> gamma_R + | Gamma (mu) -> D.gamma.(bind_indices mu) + | Sigma (mu, nu) -> sigma.(bind_indices mu).(bind_indices nu) + | C -> D.cc + + let dirac_string bind_indices ds = + D.product (List.map (dirac bind_indices) ds.gammas) + + end + + let dirac_string_to_matrix = To_Matrix.dirac_string + + (* The Lorentz indices appearing in a term are either negative + internal summation indices or positive external polarization + indices. Note that the external + indices are not really indices, but denote the position + of the particle in the vertex. *) + type 'a term = + { indices : int list; + atom : 'a } + + let map_atom f term = + { term with atom = f term.atom } + + (* Return a pair of lists: first the (negative) summation indices, + second the (positive) external indices. *) + let classify_indices ilist = + List.partition + (fun i -> + if i < 0 then + true + else if i > 0 then + false + else + invalid_arg "classify_indices") + ilist + + (* A contraction consists of a (possibly empty) product of + Dirac strings and a (possibly empty) product of Lorentz + tensors with a rational coefficient. The summation + indices could be recovered by scanning the [term]s, but + we maintain a list for efficiency. *) + type contraction = + { coeff : Q.t; + dirac : dirac_string term list; + vector : A.vector term list } + + type t = contraction list + + let dirac_of_atom = function + | A.Identity (_, _) -> [] + | A.C (_, _) -> [C] + | A.Gamma5 (_, _) -> [Gamma5] + | A.ProjP (_, _) -> [ProjP] + | A.ProjM (_, _) -> [ProjM] + | A.Gamma (mu, _, _) -> [Gamma mu] + | A.Sigma (mu, nu, _, _) -> [Sigma (mu, nu)] + + let dirac_indices = function + | A.Identity (i, j) | A.C (i, j) + | A.Gamma5 (i, j) | A.ProjP (i, j) | A.ProjM (i, j) + | A.Gamma (_, i, j) | A.Sigma (_, _, i, j) -> (i, j) + + let rec scan_for_dirac_string stack = function + + | [] -> + (* We're done with this pass. There must be + no leftover atoms on the [stack] of spinor atoms, + but we'll check this in the calling function. *) + (None, List.rev stack) + + | atom :: atoms -> + let i, j = dirac_indices atom in + if i > 0 then + if j > 0 then + (* That's an atomic Dirac string. Collect + all atoms for further processing. *) + (Some { bra = i; ket = j; gammas = dirac_of_atom atom}, + List.rev_append stack atoms) + else + (* That's the start of a new Dirac string. Search + for the remaining elements, not forgetting matrices + that we might pushed on the [stack] earlier. *) + collect_dirac_string + i j (dirac_of_atom atom) [] (List.rev_append stack atoms) + else + (* The interior of a Dirac string. Push it on the + stack until we find the start. *) + scan_for_dirac_string (atom :: stack) atoms + + (* Complete the string starting with [i] and the current summation + index [j]. *) + and collect_dirac_string i j rev_ds stack = function + + | [] -> + (* We have consumed all atoms without finding + the end of the string. *) + invalid_arg "collect_dirac_string: open string" + + | atom :: atoms -> + let i', j' = dirac_indices atom in + if i' = j then + if j' > 0 then + (* Found the conclusion. Collect + all atoms on the [stack] for further processing. *) + (Some { bra = i; ket = j'; + gammas = List.rev_append rev_ds (dirac_of_atom atom)}, + List.rev_append stack atoms) + else + (* Found the continuation. Pop the stack of open indices, + since we're looking for a new one. *) + collect_dirac_string + i j' (dirac_of_atom atom @ rev_ds) [] (List.rev_append stack atoms) + else + (* Either the start of another Dirac string or a + non-matching continuation. Push it on the + stack until we're done with the current one. *) + collect_dirac_string i j rev_ds (atom :: stack) atoms + + let dirac_string_of_dirac_atoms atoms = + scan_for_dirac_string [] atoms + + let rec dirac_strings_of_dirac_atoms' rev_ds atoms = + match dirac_string_of_dirac_atoms atoms with + | (None, []) -> List.rev rev_ds + | (None, _) -> invalid_arg "dirac_string_of_dirac_atoms: leftover atoms" + | (Some ds, atoms) -> dirac_strings_of_dirac_atoms' (ds :: rev_ds) atoms + + let dirac_strings_of_dirac_atoms atoms = + dirac_strings_of_dirac_atoms' [] atoms + + let indices_of_vector = function + | A.Epsilon (mu1, mu2, mu3, mu4) -> [mu1; mu2; mu3; mu4] + | A.Metric (mu1, mu2) -> [mu1; mu2] + | A.P (mu, n) -> + if n > 0 then + [mu] + else + invalid_arg "indices_of_vector: invalid momentum" + + let classify_vector atom = + { indices = indices_of_vector atom; + atom } + + let indices_of_dirac = function + | Gamma5 | ProjM | ProjP | C -> [] + | Gamma (mu) -> [mu] + | Sigma (mu, nu) -> [mu; nu] + + let indices_of_dirac_string ds = + ThoList.flatmap indices_of_dirac ds.gammas + + let classify_dirac atom = + { indices = indices_of_dirac_string atom; + atom } + + let contraction_of_lorentz_atoms (atoms, coeff) = + let dirac_atoms, vector_atoms = split_atoms atoms in + let dirac = + List.map classify_dirac (dirac_strings_of_dirac_atoms dirac_atoms) + and vector = + List.map classify_vector vector_atoms in + { coeff; dirac; vector } + + type redundancy = + | Trace of int + | Replace of int * int + + let rec redundant_metric' rev_atoms = function + | [] -> (None, List.rev rev_atoms) + | { atom = A.Metric (mu, nu) } as atom :: atoms -> + if mu < 1 then + if nu = mu then + (Some (Trace mu), List.rev_append rev_atoms atoms) + else + (Some (Replace (mu, nu)), List.rev_append rev_atoms atoms) + else if nu < 0 then + (Some (Replace (nu, mu)), List.rev_append rev_atoms atoms) + else + redundant_metric' (atom :: rev_atoms) atoms + | { atom = (A.Epsilon (_, _, _, _ ) | A.P (_, _) ) } as atom :: atoms -> + redundant_metric' (atom :: rev_atoms) atoms + + let redundant_metric atoms = + redundant_metric' [] atoms + + (* Substitude any occurance of the index [mu] by the index [nu]: *) + let substitute_index_vector1 mu nu = function + | A.Epsilon (mu1, mu2, mu3, mu4) as eps -> + if mu = mu1 then + A.Epsilon (nu, mu2, mu3, mu4) + else if mu = mu2 then + A.Epsilon (mu1, nu, mu3, mu4) + else if mu = mu3 then + A.Epsilon (mu1, mu2, nu, mu4) + else if mu = mu4 then + A.Epsilon (mu1, mu2, mu3, nu) + else + eps + | A.Metric (mu1, mu2) as g -> + if mu = mu1 then + A.Metric (nu, mu2) + else if mu = mu2 then + A.Metric (mu1, nu) + else + g + | A.P (mu1, n) as p -> + if mu = mu1 then + A.P (nu, n) + else + p + + let remove a alist = + List.filter ((<>) a) alist + + let substitute_index1 mu nu mu1 = + if mu = mu1 then + nu + else + mu1 + + let substitute_index mu nu indices = + List.map (substitute_index1 mu nu) indices + + (* This assumes that [mu] is a summation index and + [nu] is a polarization index. *) + let substitute_index_vector mu nu vectors = + List.map + (fun v -> + { indices = substitute_index mu nu v.indices; + atom = substitute_index_vector1 mu nu v.atom }) + vectors + + (* Substitude any occurance of the index [mu] by the index [nu]: *) + let substitute_index_dirac1 mu nu = function + | (Gamma5 | ProjM | ProjP | C) as g -> g + | Gamma (mu1) as g -> + if mu = mu1 then + Gamma (nu) + else + g + | Sigma (mu1, mu2) as g -> + if mu = mu1 then + Sigma (nu, mu2) + else if mu = mu2 then + Sigma (mu1, nu) + else + g + + (* This assumes that [mu] is a summation index and + [nu] is a polarization index. *) + let substitute_index_dirac mu nu dirac_strings = + List.map + (fun ds -> + { indices = substitute_index mu nu ds.indices; + atom = { ds.atom with + gammas = + List.map + (substitute_index_dirac1 mu nu) + ds.atom.gammas } } ) + dirac_strings + + let trace_metric = Q.make 4 1 + + (* FIXME: can this be made typesafe by mapping to a + type that \emph{only} contains [P] and [Epsilon]? *) + let rec compress_metrics c = + match redundant_metric c.vector with + | None, _ -> c + | Some (Trace mu), vector' -> + compress_metrics + { coeff = Q.mul trace_metric c.coeff; + dirac = c.dirac; + vector = vector' } + | Some (Replace (mu, nu)), vector' -> + compress_metrics + { coeff = c.coeff; + dirac = substitute_index_dirac mu nu c.dirac; + vector = substitute_index_vector mu nu vector' } + + + let dummy = [] + + let parse1 spins atom = + compress_metrics (contraction_of_lorentz_atoms atom) + + let parse spins l = + List.map (parse1 spins) l + + let vector_to_string = function + | A.Epsilon (mu, nu, ka, la) -> + Printf.sprintf "Epsilon(%d,%d,%d,%d)" mu nu ka la + | A.Metric (mu, nu) -> + Printf.sprintf "Metric(%d,%d)" mu nu + | A.P (mu, n) -> + Printf.sprintf "P(%d,%d)" mu n + + let dirac_to_string = function + | Gamma5 -> "g5" + | ProjM -> "(1-g5)/2" + | ProjP -> "(1+g5)/2" + | Gamma (mu) -> Printf.sprintf "g(%d)" mu + | Sigma (mu, nu) -> Printf.sprintf "s(%d,%d)" mu nu + | C -> "C" + + let dirac_string_to_string ds = + match ds.gammas with + | [] -> Printf.sprintf "<%d|%d>" ds.bra ds.ket + | gammas -> + Printf.sprintf + "<%d|%s|%d>" + ds.bra (String.concat "*" (List.map dirac_to_string gammas)) ds.ket + + let contraction_to_string c = + Q.to_string c.coeff ^ " * " ^ + String.concat + " * " (List.map (fun ds -> dirac_string_to_string ds.atom) c.dirac) ^ + " * " ^ + String.concat + " * " (List.map (fun v -> vector_to_string v.atom) c.vector) + + let to_string contractions = + String.concat " + " (List.map contraction_to_string contractions) + + end + +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 -> + UFOx.Lorentz.t -> unit + + val fusion2 : + Algebra.QC.t -> string -> Coupling.lorentz3 -> + string -> string -> string -> string -> string -> Coupling.fuse2 -> unit + val fusion3 : + Algebra.QC.t -> string -> Coupling.lorentz4 -> + string -> string -> string -> string -> string -> + string -> string -> Coupling.fuse3 -> unit + val fusionn : + Algebra.QC.t -> string -> Coupling.lorentzn -> + 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 + + 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 -> "???" + | Coupling.Vector -> "a" + | Coupling.Massive_Vector -> "v" + | Coupling.Vectorspinor -> "???" + | Coupling.Tensor_1 -> "???" + | Coupling.Tensor_2 -> "???" + | Coupling.BRS l -> "???" + + let fortran_type = function + | Coupling.Scalar -> "complex(kind=default)" + | Coupling.Spinor -> "type(spinor)" + | Coupling.ConjSpinor -> "type(conjspinor)" + | Coupling.Majorana -> "type(bispinor)" + | Coupling.Maj_Ghost -> "???" + | Coupling.Vector -> "type(vector)" + | Coupling.Massive_Vector -> "type(vector)" + | Coupling.Vectorspinor -> "???" + | Coupling.Tensor_1 -> "???" + | Coupling.Tensor_2 -> "???" + | Coupling.BRS l -> "???" + + (* 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 -> 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 F = Lorentz_Fusion + + let unparse_rational q = + match Q.to_ratio q with + | 0, _ -> printf "0" + | 1, 1 -> printf "1" + | -1, 1 -> printf "-1" + | n, 1 -> printf "%d" n + | 1, d -> printf "(1/%d.0_default)" d + | -1, d -> printf "(-1/%d.0_default)" d + | n, d -> printf "(%d.0_default/%d)" n d + + let unparse_error msg = + printf " [[ERROR: %s]] " msg + + let unparse_list e o unparse_term = function + | [] -> printf "%s" e + | [t] -> unparse_term t; + | t :: tl -> + printf "("; + unparse_term t; + List.iter (fun t -> printf "%s" o; unparse_term t) tl; + printf ")" + + let unparse_product unparse_term l = + unparse_list "1" "*" unparse_term l + + let unparse_sum unparse_term l = + unparse_list "0" "+" unparse_term l + + let unparse fusion = + Lorentz_Fusion.to_string fusion + + (* Format rational ([Q.t]) and complex rational ([QC.t]) + numbers as fortran values. *) + let format_rational q = + if Q.is_integer q then + string_of_int (Q.to_integer q) + else + let n, d = Q.to_ratio q in + Printf.sprintf "%d.0_default/%d" n d + + let format_complex_rational cq = + let real = QC.real cq + and imag = QC.imag cq in + if Q.is_null imag then + begin + if Q.is_negative real then + "(" ^ format_rational real ^ ")" + else + format_rational real + end + else if Q.is_integer real && Q.is_integer imag then + Printf.sprintf "(%d, %d)" (Q.to_integer real) (Q.to_integer imag) + else + Printf.sprintf + "cmplx (%s, %s, kind=default)" + (format_rational real) (format_rational imag) + + (* Optimize the representation if used as a prefactor of + a summand in a sum. *) + let format_rational_factor q = + if Q.is_unit q then + "+" + else if Q.is_unit (Q.neg q) then + "-" + else if Q.is_negative q then + "- " ^ format_rational (Q.neg q) ^ " *" + else + "+ " ^ format_rational q ^ " *" + + let format_complex_rational_factor cq = + let real = QC.real cq + and imag = QC.imag cq in + if Q.is_null imag then + begin + if Q.is_unit real then + "+" + else if Q.is_unit (Q.neg real) then + "-" + else if Q.is_negative real then + "- " ^ format_rational (Q.neg real) ^ " *" + else + "+ " ^ format_rational real ^ " *" + end + else if Q.is_integer real && Q.is_integer imag then + Printf.sprintf "+ (%d,%d) *" (Q.to_integer real) (Q.to_integer imag) + else + Printf.sprintf + "+ cmplx (%s, %s, kind=default) *" + (format_rational real) (format_rational imag) + + (* Append a formatted list of indices to [name]. *) + let append_indices name = function + | [] -> name + | indices -> + name ^ "(" ^ String.concat "," (List.map string_of_int indices) ^ ")" + + (* Dirac string variables and their names. *) + type dsv = + | Ket of int + | Bra of int + | Braket of int + + let dsv_name = function + | Ket n -> Printf.sprintf "ket%02d" n + | Bra n -> Printf.sprintf "bra%02d" n + | Braket n -> Printf.sprintf "bkt%02d" n + + let dirac_dimension dsv indices = + let tail ilist = + String.concat "," (List.map (fun _ -> "0:3") ilist) ^ ")" in + match dsv, indices with + | Braket _, [] -> "" + | (Ket _ | Bra _), [] -> ", dimension(1:4)" + | Braket _, indices -> ", dimension(" ^ tail indices + | (Ket _ | Bra _), indices -> ", dimension(1:4," ^ tail indices + + (* Write Fortran code to [decl] and [eval]: apply the Dirac matrix + [gamma] with complex rational entries to the spinor [ket] from + the left. [ket] must be the name of a scalar variable and cannot + be an array element. The result is stored in [dsv_name (Ket n)] + which can have additional [indices]. Return [Ket n] for further + processing. *) + let dirac_ket_to_fortran_decl ff n indices = + let printf fmt = fprintf ff fmt + and nl = pp_newline ff in + let dsv = Ket n in + printf + " @[<2>complex(kind=default)%s ::@ %s@]" + (dirac_dimension dsv indices) (dsv_name dsv); + nl () + + let dirac_ket_to_fortran_eval ff n indices gamma ket = + let printf fmt = fprintf ff fmt + and nl = pp_newline ff in + let dsv = Ket n in + for i = 0 to 3 do + let name = append_indices (dsv_name dsv) (succ i :: indices) in + printf " @[<%d>%s = 0" (String.length name + 5) name; + for j = 0 to 3 do + if gamma.(i).(j) <> QC.null then + printf + "@ %s %s%%a(%d)" + (format_complex_rational_factor gamma.(i).(j)) + ket.name (succ j) + done; + printf "@]"; + nl () + done; + dsv + + (* The same as [dirac_bra_to_fortran], but apply the Dirac matrix + [gamma] to [bra] from the right and return [Bra n]. *) + let dirac_bra_to_fortran_decl ff n indices = + let printf fmt = fprintf ff fmt + and nl = pp_newline ff in + let dsv = Bra n in + printf + " @[<2>complex(kind=default)%s ::@ %s@]" + (dirac_dimension dsv indices) (dsv_name dsv); + nl () + + let dirac_bra_to_fortran_eval ff n indices bra gamma = + let printf fmt = fprintf ff fmt + and nl = pp_newline ff in + let dsv = Bra n in + for j = 0 to 3 do + let name = append_indices (dsv_name dsv) (succ j :: indices) in + printf " @[<%d>%s = 0" (String.length name + 5) name; + for i = 0 to 3 do + if gamma.(i).(j) <> QC.null then + printf + "@ %s %s%%a(%d)" + (format_complex_rational_factor gamma.(i).(j)) + bra.name (succ i) + done; + printf "@]"; + nl () + done; + dsv + + (* More of the same, but evaluating a spinor sandwich and + returning [Braket n]. *) + let dirac_braket_to_fortran_decl ff n indices = + let printf fmt = fprintf ff fmt + and nl = pp_newline ff in + let dsv = Braket n in + printf + " @[<2>complex(kind=default)%s ::@ %s@]" + (dirac_dimension dsv indices) (dsv_name dsv); + nl () + + let dirac_braket_to_fortran_eval ff n indices bra gamma ket = + let printf fmt = fprintf ff fmt + and nl = pp_newline ff in + let dsv = Braket n in + let name = append_indices (dsv_name dsv) indices in + printf " @[<%d>%s = 0" (String.length name + 5) name; + for i = 0 to 3 do + for j = 0 to 3 do + if gamma.(i).(j) <> QC.null then + printf + "@ %s %s%%a(%d)*%s%%a(%d)" + (format_complex_rational_factor gamma.(i).(j)) + bra.name (succ i) ket.name (succ j) + done + done; + printf "@]"; + nl (); + dsv + + (* Choose among the previous functions according to the position + of [bra] and [ket] among the wavefunctions. If any is in the + first position evaluate the spinor expression with the + corresponding spinor removed, otherwise evaluate the + spinir sandwich. *) + let dirac_bra_or_ket_to_fortran_decl ff n indices bra ket = + if bra = 1 then + dirac_ket_to_fortran_decl ff n indices + else if ket = 1 then + dirac_bra_to_fortran_decl ff n indices + else + dirac_braket_to_fortran_decl ff n indices + + let dirac_bra_or_ket_to_fortran_eval ff n indices wfs bra gamma ket = + if bra = 1 then + dirac_ket_to_fortran_eval ff n indices gamma wfs.(pred ket) + else if ket = 1 then + dirac_bra_to_fortran_eval ff n indices wfs.(pred bra) gamma + else + dirac_braket_to_fortran_eval + ff n indices wfs.(pred bra) gamma wfs.(pred ket) + + (* UFO summation indices are negative integers. Derive a valid Fortran + variable name. *) + let prefix_summation = "mu" + let prefix_polarization = "nu" + let index_spinor = "alpha" + + let index_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 + + (* Write the [i]th Dirac string [ds] as Fortran code to [eval], including + a shorthand representation as a comment. Return [ds] with + [ds.F.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.F.atom.F.bra + and ket = ds.F.atom.F.ket in + pp_divide ~indent:4 eval (); + begin match ds.F.indices with + | [] -> + printf " ! %s" (F.dirac_string_to_string ds.F.atom); nl (); + let gamma = F.dirac_string_to_matrix (fun _ -> 0) ds.F.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 + F.map_atom (fun _ -> DS dsv) ds + | indices -> + printf + " ! %s" + (F.dirac_string_to_string ds.F.atom); nl (); + 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 = + F.dirac_string_to_matrix substitute ds.F.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] -> F.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 = + F.classify_indices + (ThoList.flatmap (fun ds -> ds.F.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) + + let format_dsv dsv indices = + match dsv, indices with + | Braket _, [] -> dsv_name dsv + | Braket _, ilist -> + Printf.sprintf "%s(%s)" (dsv_name dsv) (format_indices indices) + | (Bra _ | Ket _), [] -> + Printf.sprintf "%s(%s)" (dsv_name dsv) index_spinor + | (Bra _ | Ket _), ilist -> + Printf.sprintf + "%s(%s,%s)" (dsv_name dsv) index_spinor (format_indices indices) + + let format_tensor t = + let indices = t.F.indices in + match t.F.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!" + + let rec multiply_tensors ~decl ~eval = function + | [] -> fprintf eval "1"; + | [t] -> fprintf eval "%s" (format_tensor t) + | t :: tensors -> + fprintf eval "%s@ * " (format_tensor t); + multiply_tensors ~decl ~eval tensors + + let contract_indices ~decl ~eval indent wf_index wfs (q, contractees) = + let printf fmt = fprintf eval fmt + and nl = pp_newline eval in + let sum_var = + begin match wf_index with + | None -> wfs.(0).name + | Some i -> + begin match wfs.(0).local_array with + | None -> Printf.sprintf "%s%%a(%s)" wfs.(0).name i + | Some a -> Printf.sprintf "%s(%s)" a i + end + end in + let indices = + List.filter (fun i -> 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_rational_factor q); + List.iter (fun i -> printf "@ g4_(%s) *" (index_variable i)) indices; + printf "@ ("; + multiply_tensors ~decl ~eval contractees; + printf ")@]"); + printf "@]"; + nl () + + let external_wf_loop ~decl ~eval ~indent wfs contractees = + pp_divide ~indent eval (); + match wfs.(0).spin with + | Coupling.Scalar -> + contract_indices ~decl ~eval 2 None wfs contractees + | Coupling.Spinor | Coupling.ConjSpinor -> + let idx = index_spinor in + fprintf eval "%*s@[<2>do %s = 1, 4@]" indent "" idx; pp_newline eval (); + contract_indices ~decl ~eval 4 (Some idx) wfs contractees; + fprintf eval "%*send do@]" indent ""; pp_newline eval () + | Coupling.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 (Some idx) wfs contractees; + fprintf eval "%*send do@]" indent ""; pp_newline eval () + | _ -> failwith "external_wf_loop: incomplete" + + 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 wfs = + let printf fmt = fprintf ff fmt + and nl = pp_newline ff in + pp_divide ~indent:4 ff (); + printf " @[<2>%s = %s * %s" wfs.(0).name g wfs.(0).name; + 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 () + + (* FIXME: can be retired starting from O'Caml 4.02.0! *) + let iset_of_list list = + List.fold_right Sets.Int.add list Sets.Int.empty + + 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.F.dirac + and vectors = + List.fold_left + (fun acc wf -> + match wf.local_array with + | None -> acc + | Some a -> { F.atom = V a; F.indices = [wf.pos] } :: acc) + [] (List.tl (Array.to_list wfs)) + and tensors = + List.map (F.map_atom (fun t -> T t)) fusion.F.vector in + let contractees' = dirac_strings @ vectors @ tensors in + let indices_seen' = + iset_of_list (indices_of_contractions contractees') in + (max_dsv', + Sets.Int.union indices_seen indices_seen', + (fusion.F.coeff, contractees') :: contractees) + + (* FIXME: add indices for vector wave functions and tensors. (???) *) + let fusions_to_fortran ~decl ~eval wfs fusions = + local_vector_copies ~decl ~eval wfs; + local_momentum_copies ~decl ~eval wfs; + let _, 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 -> + fprintf decl " @[<2>integer ::@ %s@]" index_spinor; + pp_newline decl () + | _ -> () + end; + pp_divide ~indent:4 eval (); + begin match wfs.(0).local_array with + | Some a -> fprintf eval " %s = 0" a + | None -> + match wfs.(0).spin with + | Coupling.Spinor | Coupling.ConjSpinor -> + fprintf eval " %s%%a = 0" wfs.(0).name + | Coupling.Scalar -> fprintf eval " %s = 0" wfs.(0).name + | _ -> failwith "fusions_to_fortran" + end; + pp_newline eval (); + List.iter (external_wf_loop ~decl ~eval ~indent:4 wfs) contractions; + 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 fusion = + try + Lorentz_Fusion.parse (Array.to_list spins) lorentz + with + | Failure msg -> + begin + prerr_endline msg; + Lorentz_Fusion.dummy + end 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 wfs fusion; + multiply_coupling_and_scalars eval "g" wfs; + pp_flush decl (); + pp_flush eval (); + pp_divide ~indent:4 ff (); + printf " ! %s" (unparse fusion); nl (); + 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 %s@]" name; nl (); + Buffer.reset decl_buf; + Buffer.reset eval_buf; + () + + let scale_coupling c g = + if c = 1 then + g + else if c = -1 then + "-" ^ g + else + Printf.sprintf "%d*%s" c g + + let scale_coupling z g = + format_complex_rational_factor z ^ g + + (* As a prototypical example consider the vertex + \begin{equation} + \bar\psi\fmslash{A}\psi = + \tr\left(\psi\otimes\bar\psi\fmslash{A}\right) + \end{equation} + encoded as \texttt{FFV} in the SM UFO file. This example + is useful, because all three fields have different type + and we can use the Fortran compiler to check our + implementation. + + In this case we need to generate the following function + calls with the arguments in the following order + \begin{center} + \begin{tabular}{lcl} + \texttt{F12}:&$\psi_1\bar\psi_2\to A$& + \texttt{FFV\_p201(g,psi1,p1,psibar2,p2)} \\ + \texttt{F21}:&$\bar\psi_1\psi_2\to A$& + \texttt{FFV\_p201(g,psi2,p2,psibar1,p1)} \\ + \texttt{F23}:&$\bar\psi_1 A_2 \to \bar\psi$& + \texttt{FFV\_p012(g,psibar1,p1,A2,p2)} \\ + \texttt{F32}:&$A_1\bar\psi_2 \to \bar\psi$& + \texttt{FFV\_p012(g,psibar2,p2,A1,p1)} \\ + \texttt{F31}:&$A_1\psi_2\to \psi$& + \texttt{FFV\_p120(g,A1,p1,psi2,p2)} \\ + \texttt{F13}:&$\psi_1A_2\to \psi$& + \texttt{FFV\_p120(g,A2,p2,psi1,p1)} + \end{tabular} + \end{center} *) + + (* Fortunately, all Fermi signs have been taken + care of by [Fusions] and we can concentrate on + injecting the wave functions into the correct slots. *) + + let fusion2 c v s g wf1 p1 wf2 p2 fuse2 = + let g = scale_coupling c g in + let open Coupling in + let perm = + begin match fuse2 with + | F12 | F21 -> "201" + | F23 | F32 -> "012" + | F31 | F13 -> "120" + end in + match fuse2 with + | F12 | F23 | F31 -> + printf "%s_p%s(%s,%s,%s,%s,%s)" v perm g wf1 p1 wf2 p2 + | F21 | F32 | F13 -> + printf "%s_p%s(%s,%s,%s,%s,%s)" v perm g wf2 p2 wf1 p1 + + let fusion3 c v s g wf1 p1 wf2 p2 wf3 p3 fuse3 = + let g = scale_coupling c g in + let open Coupling in + let perm = + begin match fuse3 with + | F234 | F243 | F432 | F342 | F324 | F423 -> "0123" + | F134 | F341 | F413 | F143 | F431 | F314 -> "1230" + | F124 | F241 | F412 | F142 | F421 | F214 -> "2301" + | F123 | F231 | F312 | F132 | F321 | F213 -> "3012" + end in + match fuse3 with + (* These are the obvious ones, b/c they're their own inverses. *) + | F234 | F341 | F412 | F123 -> + printf "%s_p%s(%s,%s,%s,%s,%s,%s,%s)" v perm g wf1 p1 wf2 p2 wf3 p3 + | F243 | F314 | F421 | F132 -> + printf "%s_p%s(%s,%s,%s,%s,%s,%s,%s)" v perm g wf1 p1 wf3 p3 wf2 p2 + | F324 | F431 | F142 | F213 -> + printf "%s_p%s(%s,%s,%s,%s,%s,%s,%s)" v perm g wf2 p2 wf1 p1 wf3 p3 + | F432 | F143 | F214 | F321 -> + printf "%s_p%s(%s,%s,%s,%s,%s,%s,%s)" v perm g wf3 p3 wf2 p2 wf1 p1 + (* TODO: Explain why we need the inverses here \ldots *) + | F342 | F413 | F124 | F231 -> + printf "%s_p%s(%s,%s,%s,%s,%s,%s,%s)" v perm g wf3 p3 wf1 p1 wf2 p2 + | F423 | F134 | F241 | F312 -> + printf "%s_p%s(%s,%s,%s,%s,%s,%s,%s)" v perm g wf2 p2 wf3 p3 wf1 p1 + + + (* \begin{dubious} + FIXME: Implement the correct permutations also for + higher order vertices! + \end{dubious} *) + + let fusionn c v s g wfs ps fusion = + let g = scale_coupling c g in + printf + "%s_p_(%s,%s)" v g + (String.concat "," (List.map2 (fun wf p -> wf ^ "," ^ p) wfs ps)) + + 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 + + end + Index: trunk/omega/src/cascade.ml =================================================================== --- trunk/omega/src/cascade.ml (revision 8252) +++ trunk/omega/src/cascade.ml (revision 8253) @@ -1,531 +1,531 @@ (* cascade.ml -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) module type T = sig 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 = () + let dummyn = Coupling.UFOn (Algebra.QC.one, "dummy", [], Color.Trivial) (* 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) 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 (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/UFOx_parser.mly =================================================================== --- trunk/omega/src/UFOx_parser.mly (revision 8252) +++ trunk/omega/src/UFOx_parser.mly (revision 8253) @@ -1,83 +1,85 @@ /* vertex_parser.mly -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. */ /* 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 %token PLUS MINUS TIMES POWER DIV %token LPAREN RPAREN COMMA DOT %token END %left PLUS MINUS %left TIMES DIV %left POWER %nonassoc UNARY %start input %type < UFOx_syntax.expr > input %% input: | expr END { $1 } ; expr: + | MINUS INT %prec UNARY { X.integer (- $2) } + | MINUS FLOAT %prec UNARY{ X.float (-. $2) } | INT { X.integer $1 } | FLOAT { X.float $1 } | ID { X.variable $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 } ; Index: trunk/omega/src/format_Fortran.mli =================================================================== --- trunk/omega/src/format_Fortran.mli (revision 0) +++ trunk/omega/src/format_Fortran.mli (revision 8253) @@ -0,0 +1,54 @@ +(* format_Fortran.mli -- Fortran90+ continuation lines etc. + + Copyright (C) 2019- by + + Wolfgang Kilian + Thorsten Ohl + Juergen Reuter + + WHIZARD is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + WHIZARD is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) + +(* Mimic parts of the [Format] API with support for Fortran + style line continuation. *) + +type formatter + +val std_formatter : formatter + +val fprintf : formatter -> ('a, Format.formatter, unit) format -> 'a +val printf : ('a, Format.formatter, unit) format -> 'a + +(* Start a new line, \emph{not} a continuation! *) +val pp_newline : formatter -> unit -> unit +val newline : unit -> unit + +val pp_flush : formatter -> unit -> unit +val flush : unit -> unit + +val formatter_of_out_channel : ?width:int -> out_channel -> formatter +val formatter_of_buffer : ?width:int -> Buffer.t -> formatter + +val pp_set_formatter_out_channel : formatter -> ?width:int -> out_channel -> unit +val set_formatter_out_channel : ?width:int -> out_channel -> unit + +(* This must be exposed for the benefit of + [Targets.Make_Fortran().print_interface], + because somebody decided to use it for the $K$-matrix + support. Is this really necessary? *) +val pp_switch_line_continuation : formatter -> bool -> unit +val switch_line_continuation : bool -> unit + +module Test : sig val suite : OUnit.test end + Index: trunk/omega/src/fusion.ml =================================================================== --- trunk/omega/src/fusion.ml (revision 8252) +++ trunk/omega/src/fusion.ml (revision 8253) @@ -1,2841 +1,2841 @@ (* fusion.ml -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner Marco Sekulla WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) module type T = sig val options : Options.t type wf val conjugate : wf -> wf type flavor type flavor_sans_color val flavor : wf -> flavor val flavor_sans_color : wf -> flavor_sans_color type p val momentum : wf -> p val momentum_list : wf -> int list val wf_tag : wf -> string option type constant type coupling type rhs type 'a children val sign : rhs -> int val coupling : rhs -> constant Coupling.t val coupling_tag : rhs -> string option type exclusions val no_exclusions : exclusions val children : rhs -> wf list type fusion val lhs : fusion -> wf val rhs : fusion -> rhs list type braket val bra : braket -> wf val ket : braket -> rhs list type amplitude type amplitude_sans_color type selectors val amplitudes : bool -> exclusions -> selectors -> flavor_sans_color list -> flavor_sans_color list -> amplitude list val amplitude_sans_color : bool -> exclusions -> selectors -> flavor_sans_color list -> flavor_sans_color list -> amplitude_sans_color val dependencies : amplitude -> wf -> (wf, coupling) Tree2.t val incoming : amplitude -> flavor list val outgoing : amplitude -> flavor list val externals : amplitude -> wf list val variables : amplitude -> wf list val fusions : amplitude -> fusion list val brakets : amplitude -> braket list val on_shell : amplitude -> (wf -> bool) val is_gauss : amplitude -> (wf -> bool) val constraints : amplitude -> string option val symmetry : amplitude -> int val allowed : amplitude -> bool val initialize_cache : string -> unit val set_cache_name : string -> unit val check_charges : unit -> flavor_sans_color list list val count_fusions : amplitude -> int val count_propagators : amplitude -> int val count_diagrams : amplitude -> int val forest : wf -> amplitude -> ((wf * coupling option, wf) Tree.t) list val poles : amplitude -> wf list list val s_channel : amplitude -> wf list val tower_to_dot : out_channel -> amplitude -> unit val amplitude_to_dot : out_channel -> amplitude -> unit val phase_space_channels : out_channel -> amplitude_sans_color -> unit val phase_space_channels_flipped : out_channel -> amplitude_sans_color -> unit end module type Maker = functor (P : Momentum.T) -> functor (M : Model.T) -> T with type p = P.t and type flavor = Colorize.It(M).flavor and type flavor_sans_color = M.flavor and type constant = M.constant and type selectors = Cascade.Make(M)(P).selectors (* \thocwmodulesection{Fermi Statistics} *) module type Stat = sig 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 (* \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, []) 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 module Order_Tags (PT : Tuple.Poly) = struct type wf = int type coupling = int type 'a children = 'a PT.t let null_wf = 0 let null_coupling = 0 let fuse c wfs = PT.fold_left (+) c wfs let wf_to_string n = Some (string_of_int n) let coupling_to_string n = Some (string_of_int n) end (* \thocwmodulesection{[Tagged], the [Fusion.Make] Functor} *) module Tagged (Tagger : Tagger) (PT : Tuple.Poly) (Stat : Stat_Maker) (T : Topology.T with type 'a children = 'a PT.t) (P : Momentum.T) (M : Model.T) = struct type cache_mode = Cache_Use | Cache_Ignore | Cache_Overwrite let cache_option = ref Cache_Ignore type qcd_order = | QCD_order of int type ew_order = | EW_order of int let qcd_order = ref (QCD_order 99) let ew_order = ref (EW_order 99) let options = Options.create [ "ignore-cache", Arg.Unit (fun () -> cache_option := Cache_Ignore), " ignore cached model tables (default)"; "use-cache", Arg.Unit (fun () -> cache_option := Cache_Use), " use cached model tables"; "overwrite-cache", Arg.Unit (fun () -> cache_option := Cache_Overwrite), " overwrite cached model tables"; "qcd", Arg.Int (fun n -> qcd_order := QCD_order n), " set QCD order n [>= 0, default = 99] (ignored)"; "ew", Arg.Int (fun n -> ew_order := EW_order n), " set QCD order n [>=0, default = 99] (ignored)"] exception Negative_QCD_order exception Negative_EW_order exception Vanishing_couplings exception Negative_QCD_EW_orders let int_orders = match !qcd_order, !ew_order with | QCD_order n, EW_order n' when n < 0 && n' >= 0 -> raise Negative_QCD_order | QCD_order n, EW_order n' when n >= 0 && n' < 0 -> raise Negative_EW_order | QCD_order n, EW_order n' when n < 0 && n' < 0 -> raise Negative_QCD_EW_orders | QCD_order n, EW_order n' -> (n, n') open Coupling module S = Stat(M) type stat = S.stat let stat = S.stat let stat_sign = S.stat_sign (* \begin{dubious} This will do \emph{something} for 4-, 6-, \ldots fermion vertices, but not necessarily the right thing \ldots \end{dubious} *) 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 = sig type sign = int type t = { sign : sign; coupling : constant Coupling.t; coupling_tag : Tags.coupling } val sign : t -> sign val coupling : t -> constant Coupling.t val coupling_tag : t -> string option end module Tagged_Coupling : Tagged_Coupling = struct type sign = int type t = { sign : sign; coupling : constant Coupling.t; coupling_tag : Tags.coupling } let sign c = c.sign let coupling c = c.coupling let coupling_tag_raw c = c.coupling_tag let coupling_tag rhs = Tags.coupling_to_string (coupling_tag_raw rhs) end (* \thocwmodulesubsection{Amplitudes: Monochrome and Colored} *) module type Amplitude = sig module Tags : Tags type flavor type p type wf = { flavor : flavor; momentum : p; wf_tag : Tags.wf } val flavor : wf -> flavor val conjugate : wf -> wf val momentum : wf -> p val momentum_list : wf -> int list val wf_tag : wf -> string option val wf_tag_raw : wf -> Tags.wf val order_wf : wf -> wf -> int val external_wfs : int -> (flavor * int) list -> wf list type 'a children type coupling = Tagged_Coupling.t type rhs = coupling * wf children val sign : rhs -> int val coupling : rhs -> constant Coupling.t val coupling_tag : rhs -> string option type exclusions val no_exclusions : exclusions val children : rhs -> wf list type fusion = wf * rhs list val lhs : fusion -> wf val rhs : fusion -> rhs list type braket = wf * rhs list val bra : braket -> wf val ket : braket -> rhs list module D : DAG.T with type node = wf and type edge = coupling and type children = wf children val wavefunctions : braket list -> wf list type amplitude = { fusions : fusion list; brakets : braket list; on_shell : (wf -> bool); is_gauss : (wf -> bool); constraints : string option; incoming : flavor list; outgoing : flavor list; externals : wf list; symmetry : int; dependencies : (wf -> (wf, coupling) Tree2.t); fusion_tower : D.t; fusion_dag : D.t } val incoming : amplitude -> flavor list val outgoing : amplitude -> flavor list val externals : amplitude -> wf list val variables : amplitude -> wf list val fusions : amplitude -> fusion list val brakets : amplitude -> braket list val on_shell : amplitude -> (wf -> bool) val is_gauss : amplitude -> (wf -> bool) val constraints : amplitude -> string option val symmetry : amplitude -> int val dependencies : amplitude -> wf -> (wf, coupling) Tree2.t val fusion_dag : amplitude -> D.t end module Amplitude (PT : Tuple.Poly) (P : Momentum.T) (M : Model.T) : Amplitude with type p = P.t and type flavor = M.flavor and type 'a children = 'a PT.t and module Tags = Tags = struct type flavor = M.flavor type p = P.t module Tags = Tags type wf = { flavor : flavor; momentum : p; wf_tag : Tags.wf } let flavor wf = wf.flavor let conjugate wf = { wf with flavor = M.conjugate wf.flavor } let momentum wf = wf.momentum let momentum_list wf = P.to_ints wf.momentum let wf_tag wf = Tags.wf_to_string wf.wf_tag let wf_tag_raw wf = wf.wf_tag let external_wfs rank particles = List.map (fun (f, p) -> { flavor = f; momentum = P.singleton rank p; wf_tag = Tags.null_wf }) particles (* Order wavefunctions so that the external come first, then the pairs, etc. Also put possible Goldstone bosons \emph{before} their gauge bosons. *) let lorentz_ordering f = match M.lorentz f with | Coupling.Scalar -> 0 | Coupling.Spinor -> 1 | Coupling.ConjSpinor -> 2 | Coupling.Majorana -> 3 | Coupling.Vector -> 4 | Coupling.Massive_Vector -> 5 | Coupling.Tensor_2 -> 6 | Coupling.Tensor_1 -> 7 | Coupling.Vectorspinor -> 8 | Coupling.BRS Coupling.Scalar -> 9 | Coupling.BRS Coupling.Spinor -> 10 | Coupling.BRS Coupling.ConjSpinor -> 11 | Coupling.BRS Coupling.Majorana -> 12 | Coupling.BRS Coupling.Vector -> 13 | Coupling.BRS Coupling.Massive_Vector -> 14 | Coupling.BRS Coupling.Tensor_2 -> 15 | Coupling.BRS Coupling.Tensor_1 -> 16 | Coupling.BRS Coupling.Vectorspinor -> 17 | Coupling.BRS _ -> invalid_arg "Fusion.lorentz_ordering: not needed" | Coupling.Maj_Ghost -> 18 (*i | Coupling.Ward_Vector -> 19 i*) let order_flavor f1 f2 = let c = compare (lorentz_ordering f1) (lorentz_ordering f2) in if c <> 0 then c else compare f1 f2 (* Note that [Momentum().compare] guarantees that wavefunctions will be ordered according to \emph{increasing} [Momentum().rank] of their momenta. *) let order_wf wf1 wf2 = let c = P.compare wf1.momentum wf2.momentum in if c <> 0 then c else let c = order_flavor wf1.flavor wf2.flavor in if c <> 0 then c else compare wf1.wf_tag wf2.wf_tag (* This \emph{must} be a pair matching the [edge * node children] pairs of [DAG.Forest]! *) type coupling = Tagged_Coupling.t type 'a children = 'a PT.t type rhs = coupling * wf children let sign (c, _) = Tagged_Coupling.sign c let coupling (c, _) = Tagged_Coupling.coupling c let coupling_tag (c, _) = Tagged_Coupling.coupling_tag c type exclusions = { x_flavors : flavor list; x_couplings : coupling list } let no_exclusions = { x_flavors = []; x_couplings = [] } let children (_, wfs) = PT.to_list wfs type fusion = wf * rhs list let lhs (l, _) = l let rhs (_, r) = r type braket = wf * rhs list let bra (b, _) = b let ket (_, k) = k module D = DAG.Make (DAG.Forest(PT) (struct type t = wf let compare = order_wf end) (struct type t = coupling let compare = compare end)) module WFSet = Set.Make (struct type t = wf let compare = order_wf end) let wavefunctions brakets = WFSet.elements (List.fold_left (fun set (wf1, wf23) -> WFSet.add wf1 (List.fold_left (fun set' (_, wfs) -> PT.fold_right WFSet.add wfs set') set wf23)) WFSet.empty brakets) type amplitude = { fusions : fusion list; brakets : braket list; on_shell : (wf -> bool); is_gauss : (wf -> bool); constraints : string option; incoming : flavor list; outgoing : flavor list; externals : wf list; symmetry : int; dependencies : (wf -> (wf, coupling) Tree2.t); fusion_tower : D.t; fusion_dag : D.t } let incoming a = a.incoming let outgoing a = a.outgoing let externals a = a.externals let fusions a = a.fusions let brakets a = a.brakets let symmetry a = a.symmetry let on_shell a = a.on_shell let is_gauss a = a.is_gauss let constraints a = a.constraints let variables a = List.map lhs a.fusions let dependencies a = a.dependencies let fusion_dag a = a.fusion_dag end module A = Amplitude(PT)(P)(M) (* Operator insertions can be fused only if they are external. *) let is_source wf = match M.propagator wf.A.flavor with | Only_Insertion -> P.rank wf.A.momentum = 1 | _ -> true (* [is_goldstone_of g v] is [true] if and only if [g] is the Goldstone boson corresponding to the gauge particle [v]. *) let is_goldstone_of g v = match M.goldstone v with | None -> false | Some (g', _) -> g = g' (* \begin{dubious} In the end, [PT.to_list] should become redudant! \end{dubious} *) let fuse_rhs rhs = M.fuse (PT.to_list rhs) (* \thocwmodulesubsection{Vertices} *) (* Compute the set of all vertices in the model from the allowed fusions and the set of all flavors: \begin{dubious} One could think of using [M.vertices] instead of [M.fuse2], [M.fuse3] and [M.fuse] \ldots \end{dubious} *) module VSet = Map.Make(struct type t = A.flavor let compare = compare end) let add_vertices f rhs m = VSet.add f (try rhs :: VSet.find f m with Not_found -> [rhs]) m let collect_vertices rhs = List.fold_right (fun (f1, c) -> add_vertices (M.conjugate f1) (c, rhs)) (fuse_rhs rhs) (* The set of all vertices with common left fields factored. *) (* I used to think that constant initializers are a good idea to allow compile time optimizations. The down side turned out to be that the constant initializers will be evaluated \emph{every time} the functor is applied. \emph{Relying on the fact that the functor will be called only once is not a good idea!} *) type vertices = (A.flavor * (constant Coupling.t * A.flavor PT.t) list) list let vertices_nocache max_degree flavors : vertices = VSet.fold (fun f rhs v -> (f, rhs) :: v) (PT.power_fold collect_vertices flavors VSet.empty) [] (* Performance hack: *) type vertex_table = ((A.flavor * A.flavor * A.flavor) * constant Coupling.vertex3 * constant) list * ((A.flavor * A.flavor * A.flavor * A.flavor) * constant Coupling.vertex4 * constant) list * (A.flavor list * constant Coupling.vertexn * constant) list module VCache = Cache.Make (struct type t = vertex_table end) (struct type t = vertices end) let vertices_cache = ref None let hash () = VCache.hash (M.vertices ()) (* \begin{dubious} Can we do better than the executable name provided by [Config.cache_prefix]??? We need a better way to avoid collisions among the caches for different models in the same program. \end{dubious} *) let cache_name = ref (Config.cache_prefix ^ "." ^ Config.cache_suffix) let set_cache_name name = cache_name := name let initialize_cache dir = Printf.eprintf " >>> Initializing vertex table %s. This may take some time ... " !cache_name; flush stderr; VCache.write_dir (hash ()) dir !cache_name (vertices_nocache (M.max_degree ()) (M.flavors())); Printf.eprintf "done. <<< \n" let vertices max_degree flavors : vertices = match !vertices_cache with | None -> begin match !cache_option with | Cache_Use -> begin match VCache.maybe_read (hash ()) !cache_name with | VCache.Hit result -> result | VCache.Miss -> Printf.eprintf " >>> Initializing vertex table %s. This may take some time ... " !cache_name; flush stderr; let result = vertices_nocache max_degree flavors in VCache.write (hash ()) !cache_name (result); vertices_cache := Some result; Printf.eprintf "done. <<< \n"; flush stderr; result | VCache.Stale file -> Printf.eprintf " >>> Re-initializing stale vertex table %s in file %s. " !cache_name file; Printf.eprintf "This may take some time ... "; flush stderr; let result = vertices_nocache max_degree flavors in VCache.write (hash ()) !cache_name (result); vertices_cache := Some result; Printf.eprintf "done. <<< \n"; flush stderr; result end | Cache_Overwrite -> Printf.eprintf " >>> Overwriting vertex table %s. This may take some time ... " !cache_name; flush stderr; let result = vertices_nocache max_degree flavors in VCache.write (hash ()) !cache_name (result); vertices_cache := Some result; Printf.eprintf "done. <<< \n"; flush stderr; result | Cache_Ignore -> let result = vertices_nocache max_degree flavors in vertices_cache := Some result; result end | Some result -> result (* Note that we must perform any filtering of the vertices \emph{after} caching, because the restrictions \emph{must not} influence the cache (unless we tag the cache with model and restrictions). *) (*i let unpack_constant = function | Coupling.V3 (_, _, cs) -> cs | Coupling.V4 (_, _, cs) -> cs | Coupling.Vn (_, _, cs) -> cs let coupling_and_flavors_to_string (c, fs) = M.constant_symbol (unpack_constant c) ^ "[" ^ String.concat ", " (List.map M.flavor_to_string (PT.to_list fs)) ^ "]" let fusions_to_string (f, cfs) = M.flavor_to_string f ^ " <- { " ^ String.concat " | " (List.map coupling_and_flavors_to_string cfs) ^ " }" let vertices_to_string vertices = String.concat "; " (List.map fusions_to_string vertices) i*) let filter_vertices select_vtx vertices = List.fold_left (fun acc (f, cfs) -> let f' = M.conjugate f in let cfs = List.filter (fun (c, fs) -> select_vtx c f' (PT.to_list fs)) cfs in match cfs with | [] -> acc | cfs -> (f, cfs) :: acc) [] vertices (* \thocwmodulesubsection{Partitions} *) (* Vertices that are not crossing invariant need special treatment so that they're only generated for the correct combinations of momenta. NB: the [crossing] checks here are a bit redundant, because [CM.fuse] below will bring the killed vertices back to life and will have to filter once more. Nevertheless, we keep them here, for the unlikely case that anybody ever wants to use uncolored amplitudes directly. NB: the analogous problem does not occur for [select_wf], because this applies to momenta instead of vertices. *) (* \begin{dubious} This approach worked before the colorize, but has become \emph{futile}, because [CM.fuse] will bring the killed vertices back to life. We need to implement the same checks there again!!! \end{dubious} *) (* \begin{dubious} Using [PT.Mismatched_arity] is not really good style \ldots Tho's approach doesn't work since he does not catch charge conjugated processes or crossed processes. Another very strange thing is that O'Mega seems always to run in the q2 q3 timelike case, but not in the other two. (Property of how the DAG is built?). For the $ZZZZ$ vertex I add the same vertex again, but interchange 1 and 3 in the [crossing] vertex \end{dubious} *) let kmatrix_cuts c momenta = match c with | V4 (Vector4_K_Matrix_tho (disc, _), fusion, _) | V4 (Vector4_K_Matrix_jr (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_t0 (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_t1 (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_t2 (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_t_rsi (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_m0 (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_m1 (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (Vector4_K_Matrix_cf_m7 (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F431|F342|F432) | 1, false, true, false, (F134|F143|F234|F243) | 1, false, false, true, (F314|F413|F324|F423) -> true | 2, true, false, false, (F123|F213|F124|F214) | 2, false, true, false, (F312|F321|F412|F421) | 2, false, false, true, (F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | _ -> false end | V4 (DScalar2_Vector2_K_Matrix_ms (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F432|F123|F214) | 1, false, true, false, (F134|F243|F312|F421) | 1, false, false, true, (F314|F423|F132|F241) -> true | 2, true, false, false, (F431|F342|F213|F124) | 2, false, true, false, (F143|F234|F321|F412) | 2, false, false, true, (F413|F324|F231|F142) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | 4, true, false, false, (F142|F413|F231|F324) | 4, false, true, false, (F214|F341|F123|F432) | 4, false, false, true, (F124|F431|F213|F342) -> true | 5, true, false, false, (F143|F412|F321|F234) | 5, false, true, false, (F314|F241|F132|F423) | 5, false, false, true, (F134|F421|F312|F243) -> true | 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423) | 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342) | 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) -> true | 7, true, false, false, (F134|F312|F421|F243) | 7, false, true, false, (F413|F231|F142|F324) | 7, false, false, true, (F143|F321|F412|F432) -> true | 8, true, false, false, (F132|F314|F241|F423) | 8, false, true, false, (F213|F431|F124|F342) | 8, false, false, true, (F123|F341|F214|F234) -> true | _ -> false end | V4 (DScalar2_Vector2_m_0_K_Matrix_cf (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F432|F123|F214) | 1, false, true, false, (F134|F243|F312|F421) | 1, false, false, true, (F314|F423|F132|F241) -> true | 2, true, false, false, (F431|F342|F213|F124) | 2, false, true, false, (F143|F234|F321|F412) | 2, false, false, true, (F413|F324|F231|F142) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | 4, true, false, false, (F142|F413|F231|F324) | 4, false, true, false, (F214|F341|F123|F432) | 4, false, false, true, (F124|F431|F213|F342) -> true | 5, true, false, false, (F143|F412|F321|F234) | 5, false, true, false, (F314|F241|F132|F423) | 5, false, false, true, (F134|F421|F312|F243) -> true | 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423) | 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342) | 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) -> true | 7, true, false, false, (F134|F312|F421|F243) | 7, false, true, false, (F413|F231|F142|F324) | 7, false, false, true, (F143|F321|F412|F432) -> true | 8, true, false, false, (F132|F314|F241|F423) | 8, false, true, false, (F213|F431|F124|F342) | 8, false, false, true, (F123|F341|F214|F234) -> true | _ -> false end | V4 (DScalar2_Vector2_m_1_K_Matrix_cf (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F432|F123|F214) | 1, false, true, false, (F134|F243|F312|F421) | 1, false, false, true, (F314|F423|F132|F241) -> true | 2, true, false, false, (F431|F342|F213|F124) | 2, false, true, false, (F143|F234|F321|F412) | 2, false, false, true, (F413|F324|F231|F142) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | 4, true, false, false, (F142|F413|F231|F324) | 4, false, true, false, (F214|F341|F123|F432) | 4, false, false, true, (F124|F431|F213|F342) -> true | 5, true, false, false, (F143|F412|F321|F234) | 5, false, true, false, (F314|F241|F132|F423) | 5, false, false, true, (F134|F421|F312|F243) -> true | 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423) | 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342) | 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) -> true | 7, true, false, false, (F134|F312|F421|F243) | 7, false, true, false, (F413|F231|F142|F324) | 7, false, false, true, (F143|F321|F412|F432) -> true | 8, true, false, false, (F132|F314|F241|F423) | 8, false, true, false, (F213|F431|F124|F342) | 8, false, false, true, (F123|F341|F214|F234) -> true | _ -> false end | V4 (DScalar2_Vector2_m_7_K_Matrix_cf (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 1, true, false, false, (F341|F432|F123|F214) | 1, false, true, false, (F134|F243|F312|F421) | 1, false, false, true, (F314|F423|F132|F241) -> true | 2, true, false, false, (F431|F342|F213|F124) | 2, false, true, false, (F143|F234|F321|F412) | 2, false, false, true, (F413|F324|F231|F142) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | 4, true, false, false, (F142|F413|F231|F324) | 4, false, true, false, (F214|F341|F123|F432) | 4, false, false, true, (F124|F431|F213|F342) -> true | 5, true, false, false, (F143|F412|F321|F234) | 5, false, true, false, (F314|F241|F132|F423) | 5, false, false, true, (F134|F421|F312|F243) -> true | 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423) | 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342) | 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) -> true | 7, true, false, false, (F134|F312|F421|F243) | 7, false, true, false, (F413|F231|F142|F324) | 7, false, false, true, (F143|F321|F412|F432) -> true | 8, true, false, false, (F132|F314|F241|F423) | 8, false, true, false, (F213|F431|F124|F342) | 8, false, false, true, (F123|F341|F214|F234) -> true | _ -> false end | V4 (DScalar4_K_Matrix_ms (disc, _), fusion, _) -> let s12, s23, s13 = begin match PT.to_list momenta with | [q1; q2; q3] -> (P.Scattering.timelike (P.add q1 q2), P.Scattering.timelike (P.add q2 q3), P.Scattering.timelike (P.add q1 q3)) | _ -> raise PT.Mismatched_arity end in begin match disc, s12, s23, s13, fusion with | 0, true, false, false, (F341|F431|F342|F432|F123|F213|F124|F214) | 0, false, true, false, (F134|F143|F234|F243|F312|F321|F412|F421) | 0, false, false, true, (F314|F413|F324|F423|F132|F231|F142|F241) -> true | 3, true, false, false, (F143|F413|F142|F412|F321|F231|F324|F234) | 3, false, true, false, (F314|F341|F214|F241|F132|F123|F432|F423) | 3, false, false, true, (F134|F431|F124|F421|F312|F213|F342|F243) -> true | 4, true, false, false, (F142|F413|F231|F324) | 4, false, true, false, (F214|F341|F123|F432) | 4, false, false, true, (F124|F431|F213|F342) -> true | 5, true, false, false, (F143|F412|F321|F234) | 5, false, true, false, (F314|F241|F132|F423) | 5, false, false, true, (F134|F421|F312|F243) -> true | 6, true, false, false, (F134|F132|F314|F312|F241|F243|F421|F423) | 6, false, true, false, (F213|F413|F231|F431|F124|F324|F142|F342) | 6, false, false, true, (F143|F123|F341|F321|F412|F214|F432|F234) -> true | 7, true, false, false, (F134|F312|F421|F243) | 7, false, true, false, (F413|F231|F142|F324) | 7, false, false, true, (F143|F321|F412|F432) -> true | 8, true, false, false, (F132|F314|F241|F423) | 8, false, true, false, (F213|F431|F124|F342) | 8, false, false, true, (F123|F341|F214|F234) -> true | _ -> false end | _ -> true (* Counting QCD and EW orders. *) let qcd_ew_check orders = if fst (orders) <= fst (int_orders) && snd (orders) <= snd (int_orders) then true else false (* Match a set of flavors to a set of momenta. Form the direct product for the lists of momenta two and three with the list of couplings and flavors two and three. *) let flavor_keystone select_p dim (f1, f23) (p1, p23) = ({ A.flavor = f1; A.momentum = P.of_ints dim p1; A.wf_tag = A.Tags.null_wf }, Product.fold2 (fun (c, f) p acc -> try let p' = PT.map (P.of_ints dim) p in if select_p (P.of_ints dim p1) (PT.to_list p') && kmatrix_cuts c p' then (c, PT.map2 (fun f'' p'' -> { A.flavor = f''; A.momentum = p''; A.wf_tag = A.Tags.null_wf }) f p') :: acc else acc with | PT.Mismatched_arity -> acc) f23 p23 []) (*i let cnt = ref 0 let gc_stat () = let minor, promoted, major = Gc.counters () in Printf.sprintf "(%12.0f, %12.0f, %12.0f)" minor promoted major let flavor_keystone select_p n (f1, f23) (p1, p23) = incr cnt; Gc.set { (Gc.get()) with Gc.space_overhead = 20 }; Printf.eprintf "%6d@%8.1f: %s\n" !cnt (Sys.time ()) (gc_stat ()); flush stderr; flavor_keystone select_p n (f1, f23) (p1, p23) i*) (* Produce all possible combinations of vertices (flavor keystones) and momenta by forming the direct product. The semantically equivalent [Product.list2 (flavor_keystone select_wf n) vertices keystones] with \emph{subsequent} filtering would be a \emph{very bad} idea, because a potentially huge intermediate list is built for large models. E.\,g.~for the MSSM this would lead to non-termination by thrashing for $2\to4$ processes on most PCs. *) let flavor_keystones filter select_p dim vertices keystones = Product.fold2 (fun v k acc -> filter (flavor_keystone select_p dim v k) acc) vertices keystones [] (* Flatten the nested lists of vertices into a list of attached lines. *) let flatten_keystones t = ThoList.flatmap (fun (p1, p23) -> p1 :: (ThoList.flatmap (fun (_, rhs) -> PT.to_list rhs) p23)) t (* \thocwmodulesubsection{Subtrees} *) (* Fuse a tuple of wavefunctions, keeping track of Fermi statistics. Record only the the sign \emph{relative} to the children. (The type annotation is only for documentation.) *) let fuse select_wf select_vtx wfss : (A.wf * stat * A.rhs) list = if PT.for_all (fun (wf, _) -> is_source wf) wfss then try let wfs, ss = PT.split wfss in let flavors = PT.map A.flavor wfs and momenta = PT.map A.momentum wfs and wf_tags = PT.map A.wf_tag_raw 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 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 Pervasives.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 stat_sign (stat_fuse (PT.of2_kludge wf1' (stat_fuse wfs' (M.conjugate (A.flavor wf1)))) (A.flavor wf1)) * 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 }, wfs)) pairs') :: acc else acc (* \begin{figure} \begin{center} \thocwincludegraphics{width=\textwidth}{bhabha0}\\ \hfil\\ \thocwincludegraphics{width=\textwidth}{bhabha} \end{center} \caption{\label{fig:bhabha} The DAGs for Bhabha scattering before and after weeding out unused nodes. The blatant asymmetry of these DAGs is caused by our prescription for removing doubling counting for an even number of external lines.} \end{figure} \begin{figure} \begin{center} \thocwincludegraphics{width=\textwidth}{epemudbarmunumubar0}\\ \hfil\\ \thocwincludegraphics{width=\textwidth}{epemudbarmunumubar} \end{center} \caption{\label{fig:epemudbarmunumubar} The DAGs for $e^+e^-\to u\bar d \mu^-\bar\nu_\mu$ before and after weeding out unused nodes.} \end{figure} \begin{figure} \begin{center} \thocwincludegraphics{width=\textwidth}{epemudbardubar0}\\ \hfil\\ \thocwincludegraphics{width=\textwidth}{epemudbardubar} \end{center} \caption{\label{fig:epemudbardubar} The DAGs for $e^+e^-\to u\bar d d\bar u$ before and after weeding out unused nodes.} \end{figure} *) (* \thocwmodulesubsection{Amplitudes} *) module C = Cascade.Make(M)(P) type selectors = C.selectors let external_wfs n particles = List.map (fun (f, p) -> ({ A.flavor = f; A.momentum = P.singleton n p; A.wf_tag = A.Tags.null_wf }, stat f p)) particles (* \thocwmodulesubsection{Main Function} *) module WFMap = Map.Make (struct type t = A.wf let compare = compare end) (* [map_amplitude_wfs f a] applies the function [f : wf -> wf] to all wavefunctions appearing in the amplitude [a]. *) let map_amplitude_wfs f a = let map_rhs (c, wfs) = (c, PT.map f wfs) in let map_braket (wf, rhs) = (f wf, List.map map_rhs rhs) and map_fusion (lhs, rhs) = (f lhs, List.map map_rhs rhs) in let map_dag = A.D.map f (fun node rhs -> map_rhs rhs) in let tower = map_dag a.A.fusion_tower and dag = map_dag a.A.fusion_dag in let dependencies_map = A.D.fold (fun wf _ -> WFMap.add wf (A.D.dependencies dag wf)) dag WFMap.empty in { A.fusions = List.map map_fusion a.A.fusions; A.brakets = List.map map_braket a.A.brakets; A.on_shell = a.A.on_shell; A.is_gauss = a.A.is_gauss; A.constraints = a.A.constraints; A.incoming = a.A.incoming; A.outgoing = a.A.outgoing; A.externals = List.map f a.A.externals; A.symmetry = a.A.symmetry; A.dependencies = (fun wf -> WFMap.find wf dependencies_map); A.fusion_tower = tower; A.fusion_dag = dag } (*i (* \begin{dubious} Just a silly little test: \end{dubious} *) let hack_amplitude = map_amplitude_wfs (fun wf -> { wf with momentum = P.split 2 16 wf.momentum }) i*) (* This is the main function that constructs the amplitude for sets of incoming and outgoing particles and returns the results in conveniently packaged pieces. *) let amplitude goldstones selectors fin fout = (* Set up external lines and match flavors with numbered momenta. *) let f = fin @ List.map M.conjugate fout in let nin, nout = List.length fin, List.length fout in let n = nin + nout in let externals = List.combine f (ThoList.range 1 n) in let wfs = external_wfs n externals in let select_p = C.select_p selectors in let select_wf = match fin with | [_] -> C.select_wf selectors P.Decay.timelike | _ -> C.select_wf selectors P.Scattering.timelike in let select_vtx = C.select_vtx selectors in (* Build the full fusion tower (including nodes that are never needed in the amplitude). *) let stats, tower = if goldstones then complete_fusion_tower select_wf select_vtx wfs else minimal_fusion_tower n select_wf select_vtx wfs in (* Find all vertices for which \emph{all} off shell wavefunctions are defined by the tower. *) let brakets = flavor_keystones (filter_keystone stats tower) select_p n (filter_vertices select_vtx (vertices (M.max_degree ()) (M.flavors ()))) (T.keystones (ThoList.range 1 n)) in (* Remove the part of the DAG that is never needed in the amplitude. *) let dag = if goldstones then tower else A.D.harvest_list tower (A.wavefunctions brakets) in (* Remove the leaf nodes of the DAG, corresponding to external lines. *) let fusions = List.filter (function (_, []) -> false | _ -> true) (A.D.lists dag) in (* Calculate the symmetry factor for identical particles in the final state. *) let symmetry = Combinatorics.symmetry fout in let dependencies_map = A.D.fold (fun wf _ -> WFMap.add wf (A.D.dependencies dag wf)) dag WFMap.empty in (* Finally: package the results: *) { A.fusions = fusions; A.brakets = brakets; A.on_shell = (fun wf -> C.on_shell selectors (A.flavor wf) wf.A.momentum); A.is_gauss = (fun wf -> C.is_gauss selectors (A.flavor wf) wf.A.momentum); A.constraints = C.description selectors; A.incoming = fin; A.outgoing = fout; A.externals = List.map fst wfs; A.symmetry = symmetry; A.dependencies = (fun wf -> WFMap.find wf dependencies_map); A.fusion_tower = tower; A.fusion_dag = dag } (* \thocwmodulesubsection{Color} *) module CM = Colorize.It(M) module CA = Amplitude(PT)(P)(CM) let colorize_wf flavor wf = { CA.flavor = flavor; CA.momentum = wf.A.momentum; CA.wf_tag = wf.A.wf_tag } let uncolorize_wf wf = { A.flavor = CM.flavor_sans_color wf.CA.flavor; A.momentum = wf.CA.momentum; A.wf_tag = wf.CA.wf_tag } (* \begin{dubious} At the end of the day, I shall want to have some sort of \textit{fibered DAG} as abstract data type, with a projection of colored nodes to their uncolored counterparts. \end{dubious} *) module CWFBundle = Bundle.Make (struct type elt = CA.wf let compare_elt = compare type base = A.wf let compare_base = compare let pi wf = { A.flavor = CM.flavor_sans_color wf.CA.flavor; A.momentum = wf.CA.momentum; A.wf_tag = wf.CA.wf_tag } end) (* \begin{dubious} For now, we can live with simple aggregation: \end{dubious} *) type fibered_dag = { dag : CA.D.t; bundle : CWFBundle.t } (* Not yet(?) needed: [module CS = Stat (CM)] *) let colorize_sterile_nodes dag f wf fibered_dag = if A.D.is_sterile wf dag then let wf', wf_bundle' = f wf fibered_dag in { dag = CA.D.add_node wf' fibered_dag.dag; bundle = wf_bundle' } else fibered_dag let colorize_nodes f wf rhs fibered_dag = let wf_rhs_list', wf_bundle' = f wf rhs fibered_dag in let dag' = List.fold_right (fun (wf', rhs') -> CA.D.add_offspring wf' rhs') wf_rhs_list' fibered_dag.dag in { dag = dag'; bundle = wf_bundle' } (* O'Caml (correctly) infers the type [val colorize_dag : (D.node -> D.edge * D.children -> fibered_dag -> (CA.D.node * (CA.D.edge * CA.D.children)) list * CWFBundle.t) -> (D.node -> fibered_dag -> CA.D.node * CWFBundle.t) -> D.t -> CWFBundle.t -> fibered_dag]. *) let colorize_dag f_node f_ext dag wf_bundle = A.D.fold (colorize_nodes f_node) dag (A.D.fold_nodes (colorize_sterile_nodes dag f_ext) dag { dag = CA.D.empty; bundle = wf_bundle }) let colorize_external wf fibered_dag = match CWFBundle.inv_pi wf fibered_dag.bundle with | [c_wf] -> (c_wf, fibered_dag.bundle) | [] -> failwith "colorize_external: not found" | _ -> failwith "colorize_external: not unique" let fuse_c_wf rhs = let momenta = PT.map (fun wf -> wf.CA.momentum) rhs in List.filter (fun (_, c) -> kmatrix_cuts c momenta) (CM.fuse (List.map (fun wf -> wf.CA.flavor) (PT.to_list rhs))) let colorize_coupling c coupling = { coupling with Tagged_Coupling.coupling = c } let colorize_fusion wf (coupling, children) fibered_dag = let match_flavor (f, _) = (CM.flavor_sans_color f = A.flavor wf) and find_colored wf' = CWFBundle.inv_pi wf' fibered_dag.bundle in let fusions = ThoList.flatmap (fun c_children -> List.map (fun (f, c) -> (colorize_wf f wf, (colorize_coupling c coupling, c_children))) (List.filter match_flavor (fuse_c_wf c_children))) (PT.product (PT.map find_colored children)) in let bundle = List.fold_right (fun (c_wf, _) -> CWFBundle.add c_wf) fusions fibered_dag.bundle in (fusions, bundle) let colorize_braket1 (wf, (coupling, children)) fibered_dag = let find_colored wf' = CWFBundle.inv_pi wf' fibered_dag.bundle in Product.fold2 (fun bra ket acc -> List.fold_left (fun brakets (f, c) -> if CM.conjugate bra.CA.flavor = f then (bra, (colorize_coupling c coupling, ket)) :: brakets else brakets) acc (fuse_c_wf ket)) (find_colored wf) (PT.product (PT.map find_colored children)) [] module CWFMap = Map.Make (struct type t = CA.wf let compare = CA.order_wf end) module CKetSet = Set.Make (struct type t = CA.rhs let compare = compare end) (* Find a set of kets in [map] that belong to [bra]. Return the empty set, if nothing is found. *) let lookup_ketset bra map = try CWFMap.find bra map with Not_found -> CKetSet.empty (* Return the set of kets belonging to [bra] in [map], augmented by [ket]. *) let addto_ketset bra ket map = CKetSet.add ket (lookup_ketset bra map) (* Augment or update [map] with a new [(bra, ket)] relation. *) let addto_ketset_map map (bra, ket) = CWFMap.add bra (addto_ketset bra ket map) map (* Take a list of [(bra, ket)] pairs and group the [ket]s according to [bra]. This is very similar to [ThoList.factorize] on page~\pageref{ThoList.factorize}, but the latter keeps duplicate copies, while we keep only one, with equality determined by [CA.order_wf]. *) (* \begin{dubious} Isn't [Bundle]~\ref{Bundle} the correct framework for this? \end{dubious} *) let factorize_brakets brakets = CWFMap.fold (fun bra ket acc -> (bra, CKetSet.elements ket) :: acc) (List.fold_left addto_ketset_map CWFMap.empty brakets) [] let colorize_braket (wf, rhs_list) fibered_dag = factorize_brakets (ThoList.flatmap (fun rhs -> (colorize_braket1 (wf, rhs) fibered_dag)) rhs_list) let colorize_amplitude a fin fout = let f = fin @ List.map CM.conjugate fout in let nin, nout = List.length fin, List.length fout in let n = nin + nout in let externals = List.combine f (ThoList.range 1 n) in let external_wfs = CA.external_wfs n externals in let wf_bundle = CWFBundle.of_list external_wfs in let fibered_dag = colorize_dag colorize_fusion colorize_external a.A.fusion_dag wf_bundle in let brakets = ThoList.flatmap (fun braket -> colorize_braket braket fibered_dag) a.A.brakets in let dag = CA.D.harvest_list fibered_dag.dag (CA.wavefunctions brakets) in let fusions = List.filter (function (_, []) -> false | _ -> true) (CA.D.lists dag) in let dependencies_map = CA.D.fold (fun wf _ -> CWFMap.add wf (CA.D.dependencies dag wf)) dag CWFMap.empty in { CA.fusions = fusions; CA.brakets = brakets; CA.constraints = a.A.constraints; CA.incoming = fin; CA.outgoing = fout; CA.externals = external_wfs; CA.fusion_dag = dag; CA.fusion_tower = dag; CA.symmetry = a.A.symmetry; CA.on_shell = (fun wf -> a.A.on_shell (uncolorize_wf wf)); CA.is_gauss = (fun wf -> a.A.is_gauss (uncolorize_wf wf)); CA.dependencies = (fun wf -> CWFMap.find wf dependencies_map) } let allowed amplitude = match amplitude.CA.brakets with | [] -> false | _ -> true let colorize_amplitudes a = List.fold_left (fun amps (fin, fout) -> let amp = colorize_amplitude a fin fout in if allowed amp then amp :: amps else amps) [] (CM.amplitude a.A.incoming a.A.outgoing) let amplitudes goldstones exclusions selectors fin fout = colorize_amplitudes (amplitude goldstones selectors fin fout) let amplitude_sans_color goldstones exclusions selectors fin fout = amplitude goldstones selectors fin fout type flavor = CA.flavor type flavor_sans_color = A.flavor type p = A.p type wf = CA.wf let conjugate = CA.conjugate let flavor = CA.flavor let flavor_sans_color wf = CM.flavor_sans_color (CA.flavor wf) let momentum = CA.momentum let momentum_list = CA.momentum_list let wf_tag = CA.wf_tag type coupling = CA.coupling let sign = CA.sign let coupling = CA.coupling let coupling_tag = CA.coupling_tag type exclusions = CA.exclusions let no_exclusions = CA.no_exclusions type 'a children = 'a CA.children type rhs = CA.rhs let children = CA.children type fusion = CA.fusion let lhs = CA.lhs let rhs = CA.rhs type braket = CA.braket let bra = CA.bra let ket = CA.ket type amplitude = CA.amplitude type amplitude_sans_color = A.amplitude let incoming = CA.incoming let outgoing = CA.outgoing let externals = CA.externals let fusions = CA.fusions let brakets = CA.brakets let symmetry = CA.symmetry let on_shell = CA.on_shell let is_gauss = CA.is_gauss let constraints = CA.constraints let variables a = List.map lhs (fusions a) let dependencies = CA.dependencies (* \thocwmodulesubsection{Checking Conservation Laws} *) let check_charges () = let vlist3, vlist4, vlistn = M.vertices () in List.filter (fun flist -> not (M.Ch.is_null (M.Ch.sum (List.map M.charges flist)))) (List.map (fun ((f1, f2, f3), _, _) -> [f1; f2; f3]) vlist3 @ List.map (fun ((f1, f2, f3, f4), _, _) -> [f1; f2; f3; f4]) vlist4 @ List.map (fun (flist, _, _) -> flist) vlistn) (* \thocwmodulesubsection{Diagnostics} *) let count_propagators a = List.length a.CA.fusions let count_fusions a = List.fold_left (fun n (_, a) -> n + List.length a) 0 a.CA.fusions + List.fold_left (fun n (_, t) -> n + List.length t) 0 a.CA.brakets + List.length a.CA.brakets (* \begin{dubious} This brute force approach blows up for more than ten particles. Find a smarter algorithm. \end{dubious} *) let count_diagrams a = List.fold_left (fun n (wf1, wf23) -> n + CA.D.count_trees wf1 a.CA.fusion_dag * (List.fold_left (fun n' (_, wfs) -> n' + PT.fold_left (fun n'' wf -> n'' * CA.D.count_trees wf a.CA.fusion_dag) 1 wfs) 0 wf23)) 0 a.CA.brakets exception Impossible let forest' a = let below wf = CA.D.forest_memoized wf a.CA.fusion_dag in ThoList.flatmap (fun (bra, ket) -> (Product.list2 (fun bra' ket' -> bra' :: ket') (below bra) (ThoList.flatmap (fun (_, wfs) -> Product.list (fun w -> w) (PT.to_list (PT.map below wfs))) ket))) a.CA.brakets let cross wf = { CA.flavor = CM.conjugate wf.CA.flavor; CA.momentum = P.neg wf.CA.momentum; CA.wf_tag = wf.CA.wf_tag } let fuse_trees wf ts = Tree.fuse (fun (wf', e) -> (cross wf', e)) wf (fun t -> List.mem wf (Tree.leafs t)) ts let forest wf a = List.map (fuse_trees wf) (forest' a) (*i (* \begin{dubious} The following duplication should be replaced by polymorphism or a functor. \end{dubious} *) let forest_uncolored' a = let below wf = A.D.forest_memoized wf a.A.fusion_dag in ThoList.flatmap (fun (bra, ket) -> (Product.list2 (fun bra' ket' -> bra' :: ket') (below bra) (ThoList.flatmap (fun (_, wfs) -> Product.list (fun w -> w) (PT.to_list (PT.map below wfs))) ket))) a.A.brakets let cross_uncolored wf = { A.flavor = M.conjugate wf.A.flavor; A.momentum = P.neg wf.A.momentum; A.wf_tag = wf.A.wf_tag } let fuse_trees_uncolored wf ts = Tree.fuse (fun (wf', e) -> (cross_uncolored wf', e)) wf (fun t -> List.mem wf (Tree.leafs t)) ts let forest_sans_color wf a = List.map (fuse_trees_uncolored wf) (forest_uncolored' a) i*) let poles_beneath wf dag = CA.D.eval_memoized (fun wf' -> [[]]) (fun wf' _ p -> List.map (fun p' -> wf' :: p') p) (fun wf1 wf2 -> Product.fold2 (fun wf' wfs' wfs'' -> (wf' @ wfs') :: wfs'') wf1 wf2 []) (@) [[]] [[]] wf dag let poles a = ThoList.flatmap (fun (wf1, wf23) -> let poles_wf1 = poles_beneath wf1 a.CA.fusion_dag in (ThoList.flatmap (fun (_, wfs) -> Product.list List.flatten (PT.to_list (PT.map (fun wf -> poles_wf1 @ poles_beneath wf a.CA.fusion_dag) wfs))) wf23)) a.CA.brakets module WFSet = Set.Make (struct type t = CA.wf let compare = CA.order_wf end) let s_channel a = WFSet.elements (ThoList.fold_right2 (fun wf wfs -> if P.Scattering.timelike wf.CA.momentum then WFSet.add wf wfs else wfs) (poles a) WFSet.empty) (* \begin{dubious} This should be much faster! Is it correct? Is it faster indeed? \end{dubious} *) let poles' a = List.map CA.lhs a.CA.fusions let s_channel a = WFSet.elements (List.fold_right (fun wf wfs -> if P.Scattering.timelike wf.CA.momentum then WFSet.add wf wfs else wfs) (poles' a) WFSet.empty) (* \thocwmodulesubsection{Pictures} *) (* Export the DAG in the \texttt{dot(1)} file format so that we can draw pretty pictures to impress audiences \ldots *) let p2s p = if p >= 0 && p <= 9 then string_of_int p else if p <= 36 then String.make 1 (Char.chr (Char.code 'A' + p - 10)) else "_" let variable wf = CM.flavor_symbol wf.CA.flavor ^ String.concat "" (List.map p2s (P.to_ints wf.CA.momentum)) module Int = Map.Make (struct type t = int let compare = compare end) let add_to_list i n m = Int.add i (n :: try Int.find i m with Not_found -> []) m let classify_nodes dag = Int.fold (fun i n acc -> (i, n) :: acc) (CA.D.fold_nodes (fun wf -> add_to_list (P.rank wf.CA.momentum) wf) dag Int.empty) [] let dag_to_dot ch brakets dag = Printf.fprintf ch "digraph OMEGA {\n"; CA.D.iter_nodes (fun wf -> Printf.fprintf ch " \"%s\" [ label = \"%s\" ];\n" (variable wf) (variable wf)) dag; List.iter (fun (_, wfs) -> Printf.fprintf ch " { rank = same;"; List.iter (fun n -> Printf.fprintf ch " \"%s\";" (variable n)) wfs; Printf.fprintf ch " };\n") (classify_nodes dag); List.iter (fun n -> Printf.fprintf ch " \"*\" -> \"%s\";\n" (variable n)) (flatten_keystones brakets); CA.D.iter (fun n (_, ns) -> let p = variable n in PT.iter (fun n' -> Printf.fprintf ch " \"%s\" -> \"%s\";\n" p (variable n')) ns) dag; Printf.fprintf ch "}\n" let tower_to_dot ch a = dag_to_dot ch a.CA.brakets a.CA.fusion_tower let amplitude_to_dot ch a = dag_to_dot ch a.CA.brakets a.CA.fusion_dag (* \thocwmodulesubsection{Phasespace} *) let variable wf = M.flavor_to_string wf.A.flavor ^ "[" ^ String.concat "/" (List.map p2s (P.to_ints wf.A.momentum)) ^ "]" let below_to_channel transform ch dag wf = let n2s wf = variable (transform wf) and e2s c = "" in Tree2.to_channel ch n2s e2s (A.D.dependencies dag wf) let bra_to_channel transform ch dag wf = let tree = A.D.dependencies dag wf in if Tree2.is_singleton tree then let n2s wf = variable (transform wf) and e2s c = "" in Tree2.to_channel ch n2s e2s tree else failwith "Fusion.phase_space_channels: wrong topology!" let ket_to_channel transform ch dag ket = Printf.fprintf ch "("; begin match A.children ket with | [] -> () | [child] -> below_to_channel transform ch dag child | child :: children -> below_to_channel transform ch dag child; List.iter (fun child -> Printf.fprintf ch ","; below_to_channel transform ch dag child) children end; Printf.fprintf ch ")" let phase_space_braket transform ch (bra, ket) dag = bra_to_channel transform ch dag bra; Printf.fprintf ch ": {"; begin match ket with | [] -> () | [ket1] -> Printf.fprintf ch " "; ket_to_channel transform ch dag ket1 | ket1 :: kets -> Printf.fprintf ch " "; ket_to_channel transform ch dag ket1; List.iter (fun k -> Printf.fprintf ch " \\\n | "; ket_to_channel transform ch dag k) kets end; Printf.fprintf ch " }\n" (*i Food for thought: let braket_to_tree2 dag (bra, ket) = let bra' = A.D.dependencies dag bra in if Tree2.is_singleton bra' then Tree2.cons [(fst ket, bra, List.map (A.D.dependencies dag) (A.children ket))] else failwith "Fusion.phase_space_channels: wrong topology!" let phase_space_braket transform ch (bra, ket) dag = let n2s wf = variable (transform wf) and e2s c = "" in Printf.fprintf ch "%s\n" (Tree2.to_string n2s e2s (braket_to_tree2 dag (bra, ket))) i*) let phase_space_channels_transformed transform ch a = List.iter (fun braket -> phase_space_braket transform ch braket a.A.fusion_dag) a.A.brakets let phase_space_channels ch a = phase_space_channels_transformed (fun wf -> wf) ch a let exchange_momenta_list p1 p2 p = List.map (fun pi -> if pi = p1 then p2 else if pi = p2 then p1 else pi) p let exchange_momenta p1 p2 p = P.of_ints (P.dim p) (exchange_momenta_list p1 p2 (P.to_ints p)) let flip_momenta wf = { wf with A.momentum = exchange_momenta 1 2 wf.A.momentum } let phase_space_channels_flipped ch a = phase_space_channels_transformed flip_momenta ch a end -module Make = Tagged(Order_Tags) +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, []) (* \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) (*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 amplitudes val amplitudes : bool -> int option -> exclusions -> selectors -> process list -> amplitudes val empty : amplitudes val initialize_cache : string -> unit val set_cache_name : string -> unit val flavors : amplitudes -> process list val vanishing_flavors : amplitudes -> process list val color_flows : amplitudes -> Color.Flow.t list val helicities : amplitudes -> (int list * int list) list val processes : amplitudes -> amplitude list val process_table : amplitudes -> amplitude option array array val fusions : amplitudes -> (fusion * amplitude) list val multiplicity : amplitudes -> wf -> int val dictionary : amplitudes -> amplitude -> wf -> int val color_factors : amplitudes -> Color.Flow.factor array array val constraints : amplitudes -> string option end module type Multi_Maker = functor (Fusion_Maker : Maker) -> functor (P : Momentum.T) -> functor (M : Model.T) -> Multi with type flavor = M.flavor and type amplitude = Fusion_Maker(P)(M).amplitude and type fusion = Fusion_Maker(P)(M).fusion and type wf = Fusion_Maker(P)(M).wf and type selectors = Fusion_Maker(P)(M).selectors module Multi (Fusion_Maker : Maker) (P : Momentum.T) (M : Model.T) = struct exception Mismatch type progress_mode = | Quiet | Channel of out_channel | File of string let progress_option = ref Quiet module CM = Colorize.It(M) module F = Fusion_Maker(P)(M) module C = Cascade.Make(M)(P) (* \begin{dubious} A kludge, at best \ldots \end{dubious} *) let options = Options.extend F.options [ "progress", Arg.Unit (fun () -> progress_option := Channel stderr), "report progress to the standard error stream"; "progress_file", Arg.String (fun s -> progress_option := File s), "report progress to a file" ] type flavor = M.flavor type p = F.p type process = flavor list * flavor list type amplitude = F.amplitude type fusion = F.fusion type wf = F.wf type exclusions = F.exclusions let no_exclusions = F.no_exclusions type selectors = F.selectors type flavors = flavor list array type helicities = int list array type colors = Color.Flow.t array type amplitudes' = amplitude array array array type amplitudes = { flavors : process list; vanishing_flavors : process list; color_flows : Color.Flow.t list; helicities : (int list * int list) list; processes : amplitude list; process_table : amplitude option array array; fusions : (fusion * amplitude) list; multiplicity : (wf -> int); dictionary : (amplitude -> wf -> int); color_factors : Color.Flow.factor array array; constraints : string option } let flavors a = a.flavors let vanishing_flavors a = a.vanishing_flavors let color_flows a = a.color_flows let helicities a = a.helicities let processes a = a.processes let process_table a = a.process_table let fusions a = a.fusions let multiplicity a = a.multiplicity let dictionary a = a.dictionary let color_factors a = a.color_factors let constraints a = a.constraints let sans_colors f = List.map CM.flavor_sans_color f let colors (fin, fout) = List.map M.color (fin @ fout) let process_sans_color a = (sans_colors (F.incoming a), sans_colors (F.outgoing a)) let color_flow a = CM.flow (F.incoming a) (F.outgoing a) let process_to_string fin fout = String.concat " " (List.map M.flavor_to_string fin) ^ " -> " ^ String.concat " " (List.map M.flavor_to_string fout) let count_processes colored_processes = List.length colored_processes module FMap = Map.Make (struct type t = process let compare = compare end) module CMap = Map.Make (struct type t = Color.Flow.t let compare = compare end) (* Recently [Product.list] began to guarantee lexicographic order for sorted arguments. Anyway, we still force a lexicographic order. *) let rec order_spin_table1 s1 s2 = match s1, s2 with | h1 :: t1, h2 :: t2 -> let c = compare h1 h2 in if c <> 0 then c else order_spin_table1 t1 t2 | [], [] -> 0 | _ -> invalid_arg "order_spin_table: inconsistent lengths" let order_spin_table (s1_in, s1_out) (s2_in, s2_out) = let c = compare s1_in s2_in in if c <> 0 then c else order_spin_table1 s1_out s2_out let sort_spin_table table = List.sort order_spin_table table let id x = x let pair x y = (x, y) (* \begin{dubious} Improve support for on shell Ward identities: [Coupling.Vector -> [4]] for one and only one external vector. \end{dubious} *) let rec hs_of_lorentz = function | Coupling.Scalar -> [0] | Coupling.Spinor | Coupling.ConjSpinor | Coupling.Majorana | Coupling.Maj_Ghost -> [-1; 1] | Coupling.Vector -> [-1; 1] | Coupling.Massive_Vector -> [-1; 0; 1] | Coupling.Tensor_1 -> [-1; 0; 1] | Coupling.Vectorspinor -> [-2; -1; 1; 2] | Coupling.Tensor_2 -> [-2; -1; 0; 1; 2] | Coupling.BRS f -> hs_of_lorentz f let hs_of_flavor f = hs_of_lorentz (M.lorentz f) let hs_of_flavors (fin, fout) = (List.map hs_of_flavor fin, List.map hs_of_flavor fout) let rec unphysical_of_lorentz = function | Coupling.Vector -> [4] | Coupling.Massive_Vector -> [4] | _ -> invalid_arg "unphysical_of_lorentz: not a vector particle" let unphysical_of_flavor f = unphysical_of_lorentz (M.lorentz f) let unphysical_of_flavors1 n f_list = ThoList.mapi (fun i f -> if i = n then unphysical_of_flavor f else hs_of_flavor f) 1 f_list let unphysical_of_flavors n (fin, fout) = (unphysical_of_flavors1 n fin, unphysical_of_flavors1 (n - List.length fin) fout) let helicity_table unphysical flavors = let hs = begin match unphysical with | None -> List.map hs_of_flavors flavors | Some n -> List.map (unphysical_of_flavors n) flavors end in if not (ThoList.homogeneous hs) then invalid_arg "Fusion.helicity_table: not all flavors have the same helicity states!" else match hs with | [] -> [] | (hs_in, hs_out) :: _ -> sort_spin_table (Product.list2 pair (Product.list id hs_in) (Product.list id hs_out)) module Proc = Process.Make(M) module WFMap = Map.Make (struct type t = F.wf let compare = compare end) module WFSet2 = Set.Make (struct type t = F.wf * (F.wf, F.coupling) Tree2.t let compare = compare end) module WFMap2 = Map.Make (struct type t = F.wf * (F.wf, F.coupling) Tree2.t let compare = compare end) module WFTSet = Set.Make (struct type t = (F.wf, F.coupling) Tree2.t let compare = compare end) (* All wavefunctions are unique per amplitude. So we can use per-amplitude dependency trees without additional \emph{internal} tags to identify identical wave functions. *) (* \textbf{NB:} we miss potential optimizations, because we assume all coupling to be different, while in fact we have horizontal/family symmetries and non abelian gauge couplings are universal anyway. *) let disambiguate_fusions amplitudes = let fusions = ThoList.flatmap (fun amplitude -> List.map (fun fusion -> (fusion, F.dependencies amplitude (F.lhs fusion))) (F.fusions amplitude)) amplitudes in let duplicates = List.fold_left (fun map (fusion, dependencies) -> let wf = F.lhs fusion in let set = try WFMap.find wf map with Not_found -> WFTSet.empty in WFMap.add wf (WFTSet.add dependencies set) map) WFMap.empty fusions in let multiplicity_map = WFMap.fold (fun wf dependencies acc -> let cardinal = WFTSet.cardinal dependencies in if cardinal <= 1 then acc else WFMap.add wf cardinal acc) duplicates WFMap.empty and dictionary_map = WFMap.fold (fun wf dependencies acc -> let cardinal = WFTSet.cardinal dependencies in if cardinal <= 1 then acc else snd (WFTSet.fold (fun dependency (i', acc') -> (succ i', WFMap2.add (wf, dependency) i' acc')) dependencies (1, acc))) duplicates WFMap2.empty in let multiplicity wf = WFMap.find wf multiplicity_map and dictionary amplitude wf = WFMap2.find (wf, F.dependencies amplitude wf) dictionary_map in (multiplicity, dictionary) let eliminate_common_fusions1 seen_wfs amplitude = List.fold_left (fun (seen, acc) f -> let wf = F.lhs f in let dependencies = F.dependencies amplitude wf in if WFSet2.mem (wf, dependencies) seen then (seen, acc) else (WFSet2.add (wf, dependencies) seen, (f, amplitude) :: acc)) seen_wfs (F.fusions amplitude) let eliminate_common_fusions processes = let _, rev_fusions = List.fold_left eliminate_common_fusions1 (WFSet2.empty, []) processes in List.rev rev_fusions (*i let eliminate_common_fusions processes = ThoList.flatmap (fun amplitude -> (List.map (fun f -> (f, amplitude)) (F.fusions amplitude))) processes i*) (* \thocwmodulesubsection{Calculate All The Amplitudes} *) let amplitudes goldstones unphysical exclusions select_wf processes = (* \begin{dubious} Eventually, we might want to support inhomogeneous helicities. However, this makes little physics sense for external particles on the mass shell, unless we have a model with degenerate massive fermions and bosons. \end{dubious} *) if not (ThoList.homogeneous (List.map hs_of_flavors processes)) then invalid_arg "Fusion.Multi.amplitudes: incompatible helicities"; let unique_uncolored_processes = Proc.remove_duplicate_final_states (C.partition select_wf) processes in let progress = match !progress_option with | Quiet -> Progress.dummy | Channel oc -> Progress.channel oc (count_processes unique_uncolored_processes) | File name -> Progress.file name (count_processes unique_uncolored_processes) in let allowed = ThoList.flatmap (fun (fi, fo) -> Progress.begin_step progress (process_to_string fi fo); let amps = F.amplitudes goldstones exclusions select_wf fi fo in begin match amps with | [] -> Progress.end_step progress "forbidden" | _ -> Progress.end_step progress "allowed" end; amps) unique_uncolored_processes in Progress.summary progress "all processes done"; let color_flows = ThoList.uniq (List.sort compare (List.map color_flow allowed)) and flavors = ThoList.uniq (List.sort compare (List.map process_sans_color allowed)) in let vanishing_flavors = Proc.diff processes flavors in let helicities = helicity_table unphysical flavors in let f_index = fst (List.fold_left (fun (m, i) f -> (FMap.add f i m, succ i)) (FMap.empty, 0) flavors) and c_index = fst (List.fold_left (fun (m, i) c -> (CMap.add c i m, succ i)) (CMap.empty, 0) color_flows) in let table = Array.make_matrix (List.length flavors) (List.length color_flows) None in List.iter (fun a -> let f = FMap.find (process_sans_color a) f_index and c = CMap.find (color_flow a) c_index in table.(f).(c) <- Some (a)) allowed; let cf_array = Array.of_list color_flows in let ncf = Array.length cf_array in let color_factor_table = Array.make_matrix ncf ncf Color.Flow.zero in for i = 0 to pred ncf do for j = 0 to i do color_factor_table.(i).(j) <- Color.Flow.factor cf_array.(i) cf_array.(j); color_factor_table.(j).(i) <- color_factor_table.(i).(j) done done; let fusions = eliminate_common_fusions allowed and multiplicity, dictionary = disambiguate_fusions allowed in { flavors = flavors; vanishing_flavors = vanishing_flavors; color_flows = color_flows; helicities = helicities; processes = allowed; process_table = table; fusions = fusions; multiplicity = multiplicity; dictionary = dictionary; color_factors = color_factor_table; constraints = C.description select_wf } let initialize_cache = F.initialize_cache let set_cache_name = F.set_cache_name let empty = { flavors = []; vanishing_flavors = []; color_flows = []; helicities = []; processes = []; process_table = Array.make_matrix 0 0 None; fusions = []; multiplicity = (fun _ -> 1); dictionary = (fun _ _ -> 1); color_factors = Array.make_matrix 0 0 Color.Flow.zero; constraints = None } end Index: trunk/omega/src/UFO_lexer.mll =================================================================== --- trunk/omega/src/UFO_lexer.mll (revision 8252) +++ trunk/omega/src/UFO_lexer.mll (revision 8253) @@ -1,88 +1,88 @@ (* vertex_lexer.mll -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) { open Lexing open UFO_parser let string_of_char c = String.make 1 c let int_of_char c = int_of_string (string_of_char 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'] rule token = parse white { token lexbuf } (* skip blanks *) | '#' [^'\n']* { token lexbuf } (* skip comments *) | '\n' { new_line lexbuf; token lexbuf } | "from" [^'\n']* { token lexbuf } (* skip imports *) | "import" [^'\n']* { token lexbuf } (* skip imports (for now) *) | "try:" [^'\n']* { token lexbuf } (* skip imports (for now) *) | "except" [^'\n']* { token lexbuf } (* skip imports (for now) *) | "pass" { token lexbuf } (* skip imports (for now) *) | '(' { LPAREN } | ')' { RPAREN } | '{' { LBRACE } | '}' { RBRACE } | '[' { LBRACKET } | ']' { RBRACKET } | '=' { EQUAL } | '+' { PLUS } | '-' { MINUS } | '/' { DIV } | '.' { DOT } | ',' { COMMA } | ':' { COLON } | '-'? ( digit+ '.' digit* | digit* '.' digit+ ) ( ['E''e'] '-'? digit+ )? as x { FLOAT (float_of_string x) } | '-'? digit+ as i { INT (int_of_string i) } | char word* as s { ID s } - | '\'' ([^'\'']+ as s) '\'' + | '\'' ([^'\'']+ ( '\\' '\'' [^'\'']+ )* as s) '\'' { STRING s } - | '"' ([^'"']+ as s) '"' + | '"' ([^'"']+ ( '\\' '"' [^'"']+ )* as s) '"' { STRING s } | _ as c { failwith ("invalid character at `" ^ string_of_char c ^ "'") } | eof { END } Index: trunk/omega/src/coupling.mli =================================================================== --- trunk/omega/src/coupling.mli (revision 8252) +++ trunk/omega/src/coupling.mli (revision 8253) @@ -1,2877 +1,2886 @@ (* coupling.mli -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner Marco Sekulla So Young Shim (only parts of this file) WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) (* The enumeration types used for communication from [Models] to [Targets]. On the physics side, the modules in [Models] must implement the Feynman rules according to the conventions set up here. On the numerics side, the modules in [Targets] must handle all cases according to the same conventions. *) (* \thocwmodulesection{Propagators} The Lorentz representation of the particle. NB: O'Mega treats all lines as \emph{outgoing} and particles are therefore transforming as [ConjSpinor] and antiparticles as [Spinor]. *) type lorentz = | Scalar | Spinor (* $\psi$ *) | ConjSpinor (* $\bar\psi$ *) | Majorana (* $\chi$ *) | Maj_Ghost (* SUSY ghosts *) | Vector (*i | Ward_Vector i*) | Massive_Vector | Vectorspinor (* supersymmetric currents and gravitinos *) | Tensor_1 | Tensor_2 (* massive gravitons (large extra dimensions) *) | BRS of lorentz +type lorentz3 = lorentz * lorentz * lorentz +type lorentz4 = lorentz * lorentz * lorentz * lorentz +type lorentzn = lorentz list + (* \begin{table} \begin{center} \renewcommand{\arraystretch}{2.2} \begin{tabular}{|r|l|l|}\hline & only Dirac fermions & incl.~Majorana fermions \\\hline [Prop_Scalar] & \multicolumn{2}{ l |}{% $\displaystyle\phi(p)\leftarrow \frac{\ii}{p^2-m^2+\ii m\Gamma}\phi(p)$} \\\hline [Prop_Spinor] & $\displaystyle\psi(p)\leftarrow \frac{\ii(-\fmslash{p}+m)}{p^2-m^2+\ii m\Gamma}\psi(p)$ & $\displaystyle\psi(p)\leftarrow \frac{\ii(-\fmslash{p}+m)}{p^2-m^2+\ii m\Gamma}\psi(p)$ \\\hline [Prop_ConjSpinor] & $\displaystyle\bar\psi(p)\leftarrow \bar\psi(p)\frac{\ii(\fmslash{p}+m)}{p^2-m^2+\ii m\Gamma}$ & $\displaystyle\psi(p)\leftarrow \frac{\ii(-\fmslash{p}+m)}{p^2-m^2+\ii m\Gamma}\psi(p)$ \\\hline [Prop_Majorana] & \multicolumn{1}{ c |}{N/A} & $\displaystyle\chi(p)\leftarrow \frac{\ii(-\fmslash{p}+m)}{p^2-m^2+\ii m\Gamma}\chi(p)$ \\\hline [Prop_Unitarity] & \multicolumn{2}{ l |}{% $\displaystyle\epsilon_\mu(p)\leftarrow \frac{\ii}{p^2-m^2+\ii m\Gamma} \left(-g_{\mu\nu}+\frac{p_\mu p_\nu}{m^2}\right)\epsilon^\nu(p)$} \\\hline [Prop_Feynman] & \multicolumn{2}{ l |}{% $\displaystyle\epsilon^\nu(p)\leftarrow \frac{-\ii}{p^2-m^2+\ii m\Gamma}\epsilon^\nu(p)$} \\\hline [Prop_Gauge] & \multicolumn{2}{ l |}{% $\displaystyle\epsilon_\mu(p)\leftarrow \frac{\ii}{p^2} \left(-g_{\mu\nu}+(1-\xi)\frac{p_\mu p_\nu}{p^2}\right)\epsilon^\nu(p)$} \\\hline [Prop_Rxi] & \multicolumn{2}{ l |}{% $\displaystyle\epsilon_\mu(p)\leftarrow \frac{\ii}{p^2-m^2+\ii m\Gamma} \left(-g_{\mu\nu}+(1-\xi)\frac{p_\mu p_\nu}{p^2-\xi m^2}\right) \epsilon^\nu(p)$} \\\hline \end{tabular} \end{center} \caption{\label{tab:propagators} Propagators. NB: The sign of the momenta in the spinor propagators comes about because O'Mega treats all momenta as \emph{outgoing} and the charge flow for [Spinor] is therefore opposite to the momentum, while the charge flow for [ConjSpinor] is parallel to the momentum.} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.5} \begin{tabular}{|r|l|}\hline [Aux_Scalar] & $\displaystyle\phi(p)\leftarrow\ii\phi(p)$ \\\hline [Aux_Spinor] & $\displaystyle\psi(p)\leftarrow\ii\psi(p)$ \\\hline [Aux_ConjSpinor] & $\displaystyle\bar\psi(p)\leftarrow\ii\bar\psi(p)$ \\\hline [Aux_Vector] & $\displaystyle\epsilon^\mu(p)\leftarrow\ii\epsilon^\mu(p)$ \\\hline [Aux_Tensor_1] & $\displaystyle T^{\mu\nu}(p)\leftarrow\ii T^{\mu\nu}(p)$ \\\hline [Only_Insertion] & \multicolumn{1}{ c |}{N/A} \\\hline \end{tabular} \end{center} \caption{\label{tab:aux-propagators} Auxiliary and non propagating fields} \end{table} If there were no vectors or auxiliary fields, we could deduce the propagator from the Lorentz representation. While we're at it, we can introduce ``propagators'' for the contact interactions of auxiliary fields as well. [Prop_Gauge] and [Prop_Feynman] are redundant as special cases of [Prop_Rxi]. The special case [Only_Insertion] corresponds to operator insertions that do not correspond to a propagating field all. These are used for checking Slavnov-Taylor identities \begin{equation} \partial_\mu\Braket{\text{out}|W^\mu(x)|\text{in}} = m_W\Braket{\text{out}|\phi(x)|\text{in}} \end{equation} of gauge theories in unitarity gauge where the Goldstone bosons are not propagating. Numerically, it would suffice to use a vanishing propagator, but then superflous fusions would be calculated in production code in which the Slavnov-Taylor identities are not tested. *) type 'a propagator = | Prop_Scalar | Prop_Ghost | Prop_Spinor | Prop_ConjSpinor | Prop_Majorana | Prop_Unitarity | Prop_Feynman | Prop_Gauge of 'a | Prop_Rxi of 'a | Prop_Tensor_2 | Prop_Tensor_pure | Prop_Vector_pure | Prop_Vectorspinor | Prop_Col_Scalar | Prop_Col_Feynman | Prop_Col_Majorana | Prop_Col_Unitarity | Aux_Scalar | Aux_Vector | Aux_Tensor_1 | Aux_Col_Scalar | Aux_Col_Vector | Aux_Col_Tensor_1 | Aux_Spinor | Aux_ConjSpinor | Aux_Majorana | Only_Insertion (* \begin{JR} We don't need different fermionic propagators as supposed by the variable names [Prop_Spinor], [Prop_ConjSpinor] or [Prop_Majorana]. The propagator in all cases has to be multiplied on the left hand side of the spinor out of which a new one should be built. All momenta are treated as \emph{outgoing}, so for the propagation of the different fermions the following table arises, in which the momentum direction is always downwards and the arrows show whether the momentum and the fermion line, respectively are parallel or antiparallel to the direction of calculation: \begin{center} \begin{tabular}{|l|c|c|c|c|}\hline Fermion type & fermion arrow & mom. & calc. & sign \\\hline\hline Dirac fermion & $\uparrow$ & $\uparrow~\downarrow$ & $\uparrow~\uparrow$ & negative \\\hline Dirac antifermion & $\downarrow$ & $\downarrow~\downarrow$ & $\uparrow~\downarrow$ & negative \\\hline Majorana fermion & - & $\uparrow~\downarrow$ & - & negative \\\hline \end{tabular} \end{center} So the sign of the momentum is always negative and no further distinction is needed. \end{JR} *) type width = | Vanishing | Constant | Timelike | Running | Fudged | Complex_Mass | Custom of string (* \thocwmodulesection{Vertices} The combined $S-P$ and $V-A$ couplings (see tables~\ref{tab:dim4-fermions-SP}, \ref{tab:dim4-fermions-VA}, \ref{tab:dim4-fermions-SPVA-maj} and~\ref{tab:dim4-fermions-SPVA-maj2}) are redundant, of course, but they allow some targets to create more efficient numerical code.\footnote{An additional benefit is that the counting of Feynman diagrams is not upset by a splitting of the vectorial and axial pieces of gauge bosons.} Choosing VA2 over VA will cause the FORTRAN backend to pass the coupling as a whole array *) type fermion = Psi | Chi | Grav type fermionbar = Psibar | Chibar | Gravbar type boson = | SP | SPM | S | P | SL | SR | SLR | VA | V | A | VL | VR | VLR | VLRM | VAM | TVA | TLR | TRL | TVAM | TLRM | TRLM | POT | MOM | MOM5 | MOML | MOMR | LMOM | RMOM | VMOM | VA2 | VA3 | VA3M type boson2 = S2 | P2 | S2P | S2L | S2R | S2LR | SV | PV | SLV | SRV | SLRV | V2 | V2LR (* The integer is an additional coefficient that multiplies the respective coupling constant. This allows to reduce the number of required coupling constants in manifestly symmetrc cases. Most of times it will be equal unity, though. *) (* The two vertex types [PBP] and [BBB] for the couplings of two fermions or two antifermions ("clashing arrows") is unavoidable in supersymmetric theories. \begin{dubious} \ldots{} tho doesn't like the names and has promised to find a better mnemonics! \end{dubious} *) type 'a vertex3 = + | UFO3 of Algebra.QC.t * string * lorentz3 * Color.vertex3 | FBF of int * fermionbar * boson * fermion | PBP of int * fermion * boson * fermion | BBB of int * fermionbar * boson * fermionbar | GBG of int * fermionbar * boson * fermion (* gravitino-boson-fermion *) | Gauge_Gauge_Gauge of int | Aux_Gauge_Gauge of int | I_Gauge_Gauge_Gauge of int | Scalar_Vector_Vector of int | Aux_Vector_Vector of int | Aux_Scalar_Vector of int | Scalar_Scalar_Scalar of int | Aux_Scalar_Scalar of int | Vector_Scalar_Scalar of int | Graviton_Scalar_Scalar of int | Graviton_Vector_Vector of int | Graviton_Spinor_Spinor of int | Dim4_Vector_Vector_Vector_T of int | Dim4_Vector_Vector_Vector_L of int | Dim4_Vector_Vector_Vector_T5 of int | Dim4_Vector_Vector_Vector_L5 of int | Dim6_Gauge_Gauge_Gauge of int | Dim6_Gauge_Gauge_Gauge_5 of int | Aux_DScalar_DScalar of int | Aux_Vector_DScalar of int | Dim5_Scalar_Gauge2 of int (* % $\frac12 \phi F_{1,\mu\nu} F_2^{\mu\nu} = - \frac12 \phi (\ii \partial_{[\mu,} V_{1,\nu]})(\ii \partial^{[\mu,} V_2^{\nu]})$ *) | Dim5_Scalar_Gauge2_Skew of int (* % $\frac14 \phi F_{1,\mu\nu} \tilde{F}_2^{\mu\nu} = - \phi (\ii \partial_\mu V_{1,\nu})(\ii \partial_\rho V_{2,\sigma})\epsilon^{\mu\nu\rho\sigma}$ *) | Dim5_Scalar_Scalar2 of int (* % $\phi_1 \partial_\mu \phi_2 \partial^\mu \phi_3$ *) | Dim5_Scalar_Vector_Vector_T of int (* % $\phi(\ii\partial_\mu V_1^\nu)(\ii\partial_\nu V_2^\mu)$ *) | Dim5_Scalar_Vector_Vector_TU of int (* % $(\ii\partial_\nu\phi) (\ii\partial_\mu V_1^\nu) V_2^\mu$ *) | Dim5_Scalar_Vector_Vector_U of int (* % $(\ii\partial_\nu\phi) (\ii\partial_\mu V^\nu) V^\mu$ *) | Scalar_Vector_Vector_t of int (* % $ ( \partial_\mu V_\nu-\partial_\nu V_\mu )^2 $ *) | Dim6_Vector_Vector_Vector_T of int (* % $V_1^\mu ((\ii\partial_\nu V_2^\rho) % \ii\overleftrightarrow{\partial_\mu}(\ii\partial_\rho V_3^\nu))$ *) | Tensor_2_Vector_Vector of int (* % $T^{\mu\nu} (V_{1,\mu}V_{2,\nu} + V_{1,\nu}V_{2,\mu})$ *) | Tensor_2_Vector_Vector_1 of int (* % $T^{\mu\nu} (V_{1,\mu}V_{2,\nu} + V_{1,\nu}V_{2,\mu} - g_{\mu,\nu}V_1^\rho V_{2,\rho} )$ *) | Tensor_2_Vector_Vector_cf of int (* % $T^{\mu\nu} ( % - \frac{c_f}{2} g_{\mu,\nu}V_1^\rho V_{2,\rho} )$ *) | Tensor_2_Scalar_Scalar of int (* % $T^{\mu\nu} (\partial_{\mu}\phi_1\partial_{\nu}\phi_2 + % \partial_{\nu}\phi_1\partial_{\mu}\phi_2 )$ *) | Tensor_2_Scalar_Scalar_cf of int (* % $T^{\mu\nu} ( - \frac{c_f}{2} g_{\mu,\nu} % \partial_{\rho}\phi_1\partial_{\rho}\phi_2 )$ *) | Tensor_2_Vector_Vector_t of int (* % $T^{\mu\nu} (V_{1,\mu}V_{2,\nu} + V_{1,\nu}V_{2,\mu} - g_{\mu,\nu}V_1^\rho V_{2,\rho} )$ *) | Dim5_Tensor_2_Vector_Vector_1 of int (* % $T^{\alpha\beta} (V_1^\mu \ii\overleftrightarrow\partial_\alpha \ii\overleftrightarrow\partial_\beta V_{2,\mu}$ *) | Dim5_Tensor_2_Vector_Vector_2 of int (* % $T^{\alpha\beta} ( V_1^\mu \ii\overleftrightarrow\partial_\beta (\ii\partial_\mu V_{2,\alpha}) + V_1^\mu \ii\overleftrightarrow\partial_\alpha (\ii\partial_\mu V_{2,\beta}))$ *) | Dim7_Tensor_2_Vector_Vector_T of int (* % $T^{\alpha\beta} ((\ii\partial^\mu V_1^\nu) \ii\overleftrightarrow\partial_\alpha \ii\overleftrightarrow\partial_\beta (\ii\partial_\nu V_{2,\mu})) $ *) | Dim6_Scalar_Vector_Vector_D of int (* % $\ii \phi ( - (\partial^\mu \partial^\nu W^{-}_{\mu})W^{+}_{\nu} - (\partial^\mu \partial^\nu W^{+}_{\nu})W^{-}_{\mu} \\ \mbox{} \qquad + ( (\partial^\rho \partial_\rho W^{-}_{\mu})W^{+}_{\nu} + (\partial^\rho \partial_\rho W^{+}_{\nu})W^{-}_{\mu}) g^{\mu\nu}) $ *) | Dim6_Scalar_Vector_Vector_DP of int (* % $\ii ( (\partial^\mu H)(\partial^\nu W^{-}_{\mu})W^{+}_{\nu} + (\partial^\nu H)(\partial^\mu W^{+}_{\nu})W^{-}_{\mu} \\ \mbox{} \qquad - ((\partial^\rho H)(\partial_\rho W^{-}_{\mu})W^{+}_{\nu} (\partial^\rho H)(\partial^\rho W^{+}_{\nu})W^{-}_{\mu}) g^{\mu\nu}) $*) | Dim6_HAZ_D of int (* % $\ii ((\partial^\mu \partial^\nu A_{\mu})Z_{\nu} + (\partial^\rho \partial_\rho A_{\mu})Z_{\nu}g^{\mu\nu} )$ *) | Dim6_HAZ_DP of int (* % $\ii ((\partial^{\nu} A_{\mu})(\partial^{\mu} H)Z_{\nu} - (\partial^{\rho} A_{\mu})(\partial_{\rho} H)Z_{\nu} g^{\mu\nu})$ *) | Dim6_AWW_DP of int (* % $\ii ((\partial^{\rho} A_{\mu}) W^{-}_{\nu} W^{+}_{\rho} g^{\mu\nu} - (\partial^{\nu} A_{\mu}) W^{-}_{\nu} W^{+}_{\rho} g^{\mu\rho}) $ *) | Dim6_AWW_DW of int (*% $\ii [ (3(\partial^\rho A_{\mu})W^{-}_{\nu}W^{+}_{\rho} - (\partial^\rho W^{-}_{\nu})A_{\mu}W^{+}_{\rho} + (\partial^\rho W^{+}_{\rho})A_{\mu} W^{-}_{\nu})g^{\mu\nu} \\ \mbox{} \qquad +(-3(\partial^\nu A_{\mu})W^{-}_{\nu}W^{+}_{\rho} - (\partial^\nu W^{-}_{\nu})A_{\mu}W^{+}_{\rho} + (\partial^\nu W^{+}_{\rho})A_{\mu}W^{-}_{\nu})g^{\mu\rho} \\ \mbox{} \qquad +(2(\partial^\mu W^{-}_{\nu})A_{\mu}W^{+}_{\rho} - 2(\partial^\mu W^{+}_{\rho})A_{\mu}W^{-}_{\nu})g^{\nu\rho} ]$ *) | Dim6_HHH of int (*% $\ii(-(\partial^{\mu}H_1)(\partial_{\mu}H_2)H_3 - (\partial^{\mu}H_1)H_2(\partial_{\mu}H_3) - H_1(\partial^{\mu}H_2)(\partial_{\mu}H_3) )$ *) | Dim6_Gauge_Gauge_Gauge_i of int (*% $\ii (-(\partial^{\nu}V_{\mu})(\partial^{\rho}V_{\nu})(\partial^{\mu}V_{\rho}) + (\partial^{\rho}V_{\mu})(\partial^{\mu}V_{\nu})(\partial^{\nu}V_{\rho}) \\ \mbox{} \qquad + (-\partial^{\nu}V_{\rho} g^{\mu\rho} + \partial^{\mu}V_{\rho} g^{\nu\rho}) (\partial^{\sigma}V_{\mu})(\partial_{\sigma}V_{\nu}) + (\partial^{\rho}V_{\nu} g^{\mu\nu} - \partial^{\mu}V_{\nu} g^{\nu\rho}) (\partial^{\sigma}V_{\mu})(\partial_{\sigma}V_{\rho}) \\ \mbox{} \qquad + (-\partial^{\rho}V_{\mu} g^{\mu\nu} + \partial^{\mu}V_{\mu} g^{\mu\rho}) (\partial^{\sigma}V_{\nu})(\partial_{\sigma}V_{\rho}) )$ *) | Gauge_Gauge_Gauge_i of int | Dim6_GGG of int | Dim6_WWZ_DPWDW of int (* % $\ii( ((\partial^\rho V_{\mu})V_{\nu}V_{\rho} - (\partial^{\rho}V_{\nu})V_{\mu}V_{\rho})g^{\mu\nu} - (\partial^{\nu}V_{\mu})V_{\nu}V_{\rho}g^{\mu\rho} + (\partial^{\mu}V_{\nu})V_{\mu}V_{\rho})g^{\rho\nu} )$ *) | Dim6_WWZ_DW of int (* % $\ii( ((\partial^\mu V_{\mu})V_{\nu}V_{\rho} + V_{\mu}(\partial^\mu V_{\nu})V_{\rho})g^{\nu\rho} - ((\partial^\nu V_{\mu})V_{\nu}V_{\rho} + V_{\mu}(\partial^\nu V_{\nu})V_{\rho})g^{\mu\rho})$ *) | Dim6_WWZ_D of int (* % $\ii ( V_{\mu})V_{\nu}(\partial^{\nu}V_{\rho})g^{\mu\rho} + V_{\mu}V_{\nu}(\partial^{\mu}V_{\rho})g^{\nu\rho})$ *) | TensorVector_Vector_Vector of int | TensorVector_Vector_Vector_cf of int | TensorVector_Scalar_Scalar of int | TensorVector_Scalar_Scalar_cf of int | TensorScalar_Vector_Vector of int | TensorScalar_Vector_Vector_cf of int | TensorScalar_Scalar_Scalar of int | TensorScalar_Scalar_Scalar_cf of int (* As long as we stick to renormalizable couplings, there are only three types of quartic couplings: [Scalar4], [Scalar2_Vector2] and [Vector4]. However, there are three inequivalent contractions for the latter and the general vertex will be a linear combination with integer coefficients: \begin{subequations} \begin{align} \ocwupperid{Scalar4}\,1 :&\;\;\;\;\; \phi_1 \phi_2 \phi_3 \phi_4 \\ \ocwupperid{Scalar2\_Vector2}\,1 :&\;\;\;\;\; \phi_1^{\vphantom{\mu}} \phi_2^{\vphantom{\mu}} V_3^\mu V_{4,\mu}^{\vphantom{\mu}} \\ \ocwupperid{Vector4}\,\lbrack 1, \ocwupperid{C\_12\_34} \rbrack :&\;\;\;\;\; V_1^\mu V_{2,\mu}^{\vphantom{\mu}} V_3^\nu V_{4,\nu}^{\vphantom{\mu}} \\ \ocwupperid{Vector4}\,\lbrack 1, \ocwupperid{C\_13\_42} \rbrack :&\;\;\;\;\; V_1^\mu V_2^\nu V_{3,\mu}^{\vphantom{\mu}} V_{4,\nu}^{\vphantom{\mu}} \\ \ocwupperid{Vector4}\,\lbrack 1, \ocwupperid{C\_14\_23} \rbrack :&\;\;\;\;\; V_1^\mu V_2^\nu V_{3,\nu}^{\vphantom{\mu}} V_{4,\mu}^{\vphantom{\mu}} \end{align} \end{subequations} *) type contract4 = C_12_34 | C_13_42 | C_14_23 (*i\begin{dubious} CS objected to the polymorphic [type 'a vertex4], since it broke the implementation of some of his extensions. Is there another way of getting coupling constants into [Vector4_K_Matrix], besides the brute force solution of declaring the possible coupling constants here? \textit{I'd like to put the blame on CS for two reasons: it's not clear that the brute force solution will actually work and everytime a new vertex that depends non-linearly on coupling contanst pops up, the problem will make another appearance.} \end{dubious}i*) type 'a vertex4 = + | UFO4 of Algebra.QC.t * string * lorentz4 * Color.vertex4 | Scalar4 of int | Scalar2_Vector2 of int | Vector4 of (int * contract4) list | DScalar4 of (int * contract4) list | DScalar2_Vector2 of (int * contract4) list | Dim8_Scalar2_Vector2_1 of int | Dim8_Scalar2_Vector2_2 of int | Dim8_Scalar2_Vector2_m_0 of int | Dim8_Scalar2_Vector2_m_1 of int | Dim8_Scalar2_Vector2_m_7 of int | Dim8_Scalar4 of int | Dim8_Vector4_t_0 of (int * contract4) list | Dim8_Vector4_t_1 of (int * contract4) list | Dim8_Vector4_t_2 of (int * contract4) list | Dim8_Vector4_m_0 of (int * contract4) list | Dim8_Vector4_m_1 of (int * contract4) list | Dim8_Vector4_m_7 of (int * contract4) list | GBBG of int * fermionbar * boson2 * fermion (* In some applications, we have to allow for contributions outside of perturbation theory. The most prominent example is heavy gauge boson scattering at very high energies, where the perturbative expression violates unitarity. *) (* One solution is the `$K$-matrix' ansatz. Such unitarizations typically introduce effective propagators and/or vertices that violate crossing symmetry and vanish in the $t$-channel. This can be taken care of in [Fusion] by filtering out vertices that have the wrong momenta. *) (* In this case the ordering of the fields in a vertex of the Feynman rules becomes significant. In particular, we assume that $(V_1,V_2,V_3,V_4)$ implies \begin{equation} \parbox{25mm}{\fmfframe(2,3)(2,3){\begin{fmfgraph*}(20,20) \fmfleft{v1,v2} \fmfright{v4,v3} \fmflabel{$V_1$}{v1} \fmflabel{$V_2$}{v2} \fmflabel{$V_3$}{v3} \fmflabel{$V_4$}{v4} \fmf{plain}{v,v1} \fmf{plain}{v,v2} \fmf{plain}{v,v3} \fmf{plain}{v,v4} \fmfblob{.2w}{v} \end{fmfgraph*}}} \qquad\Longrightarrow\qquad \parbox{45mm}{\fmfframe(2,3)(2,3){\begin{fmfgraph*}(40,20) \fmfleft{v1,v2} \fmfright{v4,v3} \fmflabel{$V_1$}{v1} \fmflabel{$V_2$}{v2} \fmflabel{$V_3$}{v3} \fmflabel{$V_4$}{v4} \fmf{plain}{v1,v12,v2} \fmf{plain}{v3,v34,v4} \fmf{dots,label=$\Theta((p_1+p_2)^2)$,tension=0.7}{v12,v34} \fmfdot{v12,v34} \end{fmfgraph*}}} \end{equation} The list of pairs of parameters denotes the location and strengths of the poles in the $K$-matrix ansatz: \begin{equation} (c_1,a_1,c_2,a_2,\ldots,c_n,a_n) \Longrightarrow f(s) = \sum_{i=1}^{n} \frac{c_i}{s-a_i} \end{equation} *) | Vector4_K_Matrix_tho of int * ('a * 'a) list | Vector4_K_Matrix_jr of int * (int * contract4) list | Vector4_K_Matrix_cf_t0 of int * (int * contract4) list | Vector4_K_Matrix_cf_t1 of int * (int * contract4) list | Vector4_K_Matrix_cf_t2 of int * (int * contract4) list | Vector4_K_Matrix_cf_t_rsi of int * (int * contract4) list | Vector4_K_Matrix_cf_m0 of int * (int * contract4) list | Vector4_K_Matrix_cf_m1 of int * (int * contract4) list | Vector4_K_Matrix_cf_m7 of int * (int * contract4) list | DScalar2_Vector2_K_Matrix_ms of int * (int * contract4) list | DScalar2_Vector2_m_0_K_Matrix_cf of int * (int * contract4) list | DScalar2_Vector2_m_1_K_Matrix_cf of int * (int * contract4) list | DScalar2_Vector2_m_7_K_Matrix_cf of int * (int * contract4) list | DScalar4_K_Matrix_ms of int * (int * contract4) list | Dim6_H4_P2 of int (* % $\ii( -(\partial^{\mu}H_1)(\partial_{\mu}H_2) H_3 H_4 - (\partial^{\mu}H_1)H_2(\partial_{\mu}H_3) H_4 -(\partial^{\mu}H_1)H_2 H_3 (\partial_{mu}H_4) \\ \mbox{} \qquad - H_1(\partial^{\mu}H_2)(\partial_{\mu}H_3) H_4 - H_1(\partial^{\mu}H_2) H_3(\partial_{\mu} H_4) - H_1 H_2 (\partial^{\mu}H_3)(\partial_{\mu} H_4) )$ *) | Dim6_AHWW_DPB of int (* % $\ii H ( (\partial^{\rho} A_{\mu}) W_{\nu}W_{\rho} g^{\mu\nu} - (\partial^{\nu}A_{\mu})W_{\nu}W_{\rho}g^{\mu\rho})$ *) | Dim6_AHWW_DPW of int (* % $\ii ( ((\partial^{\rho}A_{\mu})W_{\nu}W_{\rho} - (\partial^{\rho} H)A_{\mu}W_{\nu}W_{\rho})g^{\mu\nu} \\ \mbox{} \qquad (-(\partial^{\nu}A_{\mu})W_{\nu}W_{\rho} + (\partial^{\nu} H)A_{\mu}W_{\nu}W_{\rho})g^{\mu\rho})$ *) | Dim6_AHWW_DW of int (* % $\ii H( (3(\partial^{\rho}A_{\mu})W_{\nu}W_{\rho} - A_{\mu}(\partial^{\rho}W_{\nu})W_{\rho} + A_{\mu}W_{\nu}(\partial^{\rho}W_{\rho})) g^{\mu\nu} \\ \mbox{} \qquad + (-3(\partial^{\nu}A_{\mu})W_{\nu}W_{\rho} - A_{\mu}(\partial^{\nu}W_{\nu})W_{\rho} + A_{\mu}W_{\nu}(\partial^{\nu}W_{\rho})) g^{\mu\rho} \\ \mbox{} \qquad + 2(A_{\mu}(\partial^{\mu}W_{\nu})W_{\rho} + A_{\mu}W_{\nu}(\partial^{\mu}W_{\rho}))) g^{\nu\rho}) $ *) | Dim6_Vector4_DW of int (*% $\ii ( -V_{1,\mu}V_{2,\nu}V^{3,\nu}V^{4,\mu} - V_{1,\mu}V_{2,\nu}V^{3,\mu}V^{4,\nu} \\ \mbox{} \qquad + 2V_{1,\mu}V^{2,\mu}V_{3,\nu}V^{4,\nu} $ *) | Dim6_Vector4_W of int (* % $\ii (((\partial^{\rho}V_{1,\mu})V_{2}^{\mu} (\partial^{\sigma}V_{3,\rho})V_{4,\sigma} + V_{1,\mu}(\partial^{\rho}V_{2}^{\mu}) (\partial^{\sigma}V_{3,\rho})V_{4,\sigma} \\ \mbox{} \qquad + (\partial^{\sigma}V_{1,\mu})V_{2}^{\mu}V_{3,\rho} (\partial^{\rho}V_{4,\sigma}) + V_{1,\mu}(\partial^{\sigma}V_{2}^{\mu})V_{3,\rho} (\partial^{\rho}V_{4,\sigma})) \\ \mbox{} \qquad + ((\partial^{\sigma}V_{1,\mu})V_{2,\nu} (\partial^{\nu}V_{3}^{\mu})V_{4,\sigma} - V_{1,\mu}(\partial^{\sigma}V_{2,\nu}) (\partial^{\nu}V_{3}^{\mu})V_{4,\sigma} \\ \mbox{} \qquad - (\partial^{\nu}V_{1}^{\mu})V_{2,\nu} (\partial^{\sigma}V_{3,\mu})V_{4,\sigma} - (\partial^{\sigma}V_{1,\mu})V_{2,\nu}V_{3}^{\mu} (\partial^{\nu}V_{4,\sigma})) \\ \mbox{} \qquad + ( -(\partial^{\rho}V_{1,\mu})V_{2,\nu} (\partial^{\nu}V_{3,\rho})V_{4}^{\mu} + (\partial^{\rho}V_{1,\mu})V_{2,\nu}V_{3,\rho} (\partial^{\nu}V_{4}^{\mu}) \\ \mbox{} \qquad - V_{1,\mu}(\partial^{\rho}V_{2,\nu})V_{3,\rho} (\partial^{\nu}V_{4}^{\mu}) - (\partial^{\nu}V_{1,\mu})V_{2,\nu}V_{3,\rho} (\partial^{\rho}V_{4}^{\mu}) ) \\ \mbox{} \qquad +( -(\partial^{\sigma}V_{1,\mu})V_{2,\nu} (\partial^{\mu}V_{3}^{\nu})V_{4,\sigma} + V_{1,\mu}(\partial^{\sigma}V_{2,\nu}) (\partial^{\mu}V_{3}^{\nu})V_{4,\sigma} \\ \mbox{} \qquad - V_{1,\mu}(\partial^{\mu}V_{2,\nu}) (\partial^{\sigma}V_{3}^{\nu})V_{4,\sigma} - V_{1,\mu}(\partial^{\sigma}V_{2,\nu})V_{3}^{\nu} (\partial^{\mu}V_{4,\sigma}) \\ \mbox{} \qquad + ( -V_{1,\mu}(\partial^{\rho}V_{2,\nu}) (\partial^{\mu}V_{3,\rho})V_{4}^{\nu} - (\partial^{\rho}V_{1,\mu})V_{2,\nu}V_{3,\rho} (\partial^{\mu}V_{4}^{\nu}) \\ \mbox{} \qquad + V_{1,\mu}(\partial^{\rho}V_{2,\nu})V_{3,\rho} (\partial^{\mu}V_{4}^{\nu}) - V_{1,\mu}(\partial^{\mu}V_{2,\nu})V_{3,\rho} (\partial^{\rho}V_{4}^{\nu}) ) \\ \mbox{} \qquad + ((\partial^{\nu}V_{1,\mu})V_{2,\nu} (\partial^{\mu}V_{3,\rho})V_{4}^{\rho} + V_{1,\mu}(\partial^{\mu}V_{2,\nu}) (\partial^{\nu}V_{3,\rho})V_{4}^{\rho} \\ \mbox{} \qquad + (\partial^{\nu}V_{1,\mu})V_{2,\nu}V_{3,\rho} (\partial^{\mu}V_{4}^{\rho}) + V_{1,\mu}(\partial^{\mu}V_{2,\nu})V_{3,\rho} (\partial^{\nu}V_{4}^{\rho})) \\ \mbox{} \qquad + (\partial^{\rho}V_{1,\mu})V_{2,\nu}V_{3}^{\mu} (\partial_{\rho}V_{4}^{\nu}) - (\partial^{\rho}V_{1,\mu})V_{2}^{\mu}V_{3,\nu} (\partial_{\rho}V_{4}^{\nu}) \\ \mbox{} \qquad + V_{1,\mu}(\partial^{\rho}V_{2,\nu}) (\partial_{\rho}V_{3}^{\mu})V_{4}^{\nu} - V_{1,\mu}(\partial^{\rho}V_{2}^{\mu}) (\partial_{\rho}V_{3,\nu})V_{4}^{\nu} \\ \mbox{} \qquad + (\partial^{\rho}V_{1,\mu})V_{2,\nu} (\partial_{\rho}V_{3}^{\nu})V_{4}^{\mu} - (\partial^{\rho}V_{1,\mu})V_{2}^{\mu} (\partial_{\rho}V_{3, \nu})V_{4}^{\nu} \\ \mbox{} \qquad + V_{1,\mu}(\partial^{\rho}V_{2,\nu})V_{3}^{\nu} (\partial_{\rho}V_{4}^{\mu}) - V_{1,\mu}(\partial^{\rho}V_{2}^{\mu})V_{3,\nu} (\partial_{\rho}V_{4}^{\nu}) )$ *) | Dim6_Scalar2_Vector2_D of int (*% $\ii H_1 H_2 (-(\partial^{\mu}\partial^{\nu}V_{3,\mu})V_{4,\nu} + (\partial^{\mu}\partial_{\mu}V_{3,\nu})V_{4}^{\nu} \\ \mbox{}\qquad - V_{3,\mu}(\partial^{\mu}\partial^{\nu}V_{4,\nu}) + V_{3,\mu}(\partial^{\nu}\partial_{\nu}V_{4}^{\mu}))$ *) | Dim6_Scalar2_Vector2_DP of int (*% $\ii ((\partial^{\mu}H_1)H_2(\partial^{\nu}V_{3,\mu})V_{4,\nu} - (\partial^{\nu}H_1)H_2(\partial_{\nu}V_{3,\mu})V^{4,\mu} + H_1(\partial^{\mu}H_2)(\partial^{\nu}V_{3,\mu})V_{4,\nu} \\ \mbox{} \qquad - H_1(\partial^{\nu}H_2)(\partial_{\nu}V_{3,\mu})V^{4,\mu} + (\partial^{\nu}H_1)H_2V_{3,\mu}(\partial^{\mu}V_{4,\nu}) - (\partial^{\nu}H_1)H_2V_{3,\mu}(\partial_{\nu}V^{4,\mu}) \\ \mbox{} \qquad + H_1(\partial^{\nu}H_2)V_{3,\mu}(\partial^{\mu}V_{4,\nu}) - H_1(\partial^{\nu}H_2)V_{3,\mu}(\partial_{\nu}V^{4,\mu})) $ *) | Dim6_Scalar2_Vector2_PB of int (*% $\ii (H_1H_2(\partial^{\nu}V_{3,\mu})(\partial^{\mu}V_{4,\nu}) - H_1H_2(\partial^{\nu}V_{3,\mu})(\partial_{\nu}V^{4,\mu})) $ *) | Dim6_HHZZ_T of int (*% $\ii H_1H_2V_{3,\mu}V^{4,\mu}$ *) | Dim6_HWWZ_DW of int (* % $\ii( H_1(\partial^{\rho}W_{2,\mu})W^{3,\mu}Z_{4,\rho} - H_1W_{2,\mu}(\partial^{\rho}W^{3,\mu})Z_{4,\rho} - 2H_1(\partial^{\nu}W_{2,\mu})W_{3,\nu}Z^{4,\mu} \\ \mbox{} \qquad - H_1W_{2,\mu}(\partial^{\nu}W_{3,\nu})Z^{4,\mu} + H_1(\partial^{\mu}W_{2,\mu})W_{3,\nu}Z^{4,\nu} + 2H_1W_{2,\mu}(\partial^{\mu}W_{3,\nu})Z^{4,\nu})$ *) | Dim6_HWWZ_DPB of int (* % $\ii ( - H_1W_{2,\mu}W_{3,\nu}(\partial^{\nu}Z^{4,\mu}) + H_1W_{2,\mu}W_{3,\nu}(\partial^{\mu}Z^{4,\nu}))$ *) | Dim6_HWWZ_DDPW of int (* % $ \ii(H_1(\partial^{\nu}W_{2,\mu})W^{3,\mu}Z_{4,\nu} - H_1W_{2,\mu}(\partial^{\nu}W^{3,\mu})Z_{4,\nu} - H_1(\partial^{\nu}W_{2,\mu})W_{3,\nu}Z^{4,\mu} \\ \mbox{} \qquad + H_1W_{2,\mu}W_{3,\nu}(\partial^{\nu}Z^{4,\mu}) + H_1W_{2,\mu}(\partial^{\mu}W_{3,\nu})Z^{4,\nu} - H_1W_{2,\mu}W_{3,\nu}(\partial^{\mu}Z^{4,\nu}))$ *) | Dim6_HWWZ_DPW of int (* % $\ii ( H_1(\partial^{\nu}W_{2,\mu})W^{3,\mu}Z_{4,\nu} - H_1W_{2,\mu}(\partial^{\nu}W^{3,\mu})Z_{4,\nu} + (\partial^{\nu}H_1)W_{2,\mu}W_{3,\nu}Z^{4,\mu} \\ \mbox{} \qquad - H_1(\partial^{\nu}W_{2,\mu})W_{3,\nu}Z^{4,\mu} - (\partial^{\mu}H_1)W_{2,\mu}W_{3,\nu}Z^{4,\nu} + H_1W_{2,\mu}(\partial^{\mu}W_{3,\nu})Z^{4,\nu} )$ *) | Dim6_AHHZ_D of int (* % $\ii (H_1H_2(\partial^{\mu}\partial^{\nu}A_{\mu})Z_{\nu} - H_1H_2(\partial^{\nu}\partial_{\nu}A_{\mu})Z^{\mu})$ *) | Dim6_AHHZ_DP of int (* % $\ii ((\partial^{\mu}H_1)H_2(\partial^{\nu}A_{\mu})Z_{\nu} + H_1(\partial^{\mu}H_2)(\partial^{\nu}A_{\mu})Z_{\nu} \\ \mbox{} \qquad - (\partial^{\nu}H_1)H_2(\partial_{\nu}A_{\mu})Z^{\mu} - H_1(\partial^{\nu}H_2)(\partial_{\nu}A_{\mu})Z^{\mu} ) $ *) | Dim6_AHHZ_PB of int (* % $\ii (H_1H_2(\partial^{\nu}A_{\mu})(\partial_{\nu}Z^{\mu}) - H_1H_2(\partial^{\nu}A_{\mu})(\partial^{\mu}Z_{\nu}))$ *) -type 'a vertexn = unit +type 'a vertexn = + | UFOn of Algebra.QC.t * string * lorentzn * Color.vertex (* An obvious candidate for addition to [boson] is [T], of course. *) (* \begin{dubious} This list is sufficient for the minimal standard model, but not comprehensive enough for most of its extensions, supersymmetric or otherwise. In particular, we need a \emph{general} parameterization for all trilinear vertices. One straightforward possibility are polynomials in the momenta for each combination of fields. \end{dubious} \begin{JR} Here we use the rules which can be found in~\cite{Denner:Majorana} and are more properly described in [Targets] where the performing of the fusion rules in analytical expressions is encoded. \end{JR} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.2} \begin{tabular}{|r|l|l|}\hline & only Dirac fermions & incl.~Majorana fermions \\\hline \multicolumn{3}{|l|}{[FBF (Psibar, S, Psi)]: $\mathcal{L}_I=g_S\bar\psi_1 S\psi_2$}\\\hline [F12] & $\bar\psi_2\leftarrow\ii\cdot g_S\bar\psi_1 S$ & $\psi_2\leftarrow\ii\cdot g_S\psi_1 S$ \\\hline [F21] & $\bar\psi_2\leftarrow\ii\cdot g_S S \bar\psi_1$ & $\psi_2\leftarrow\ii\cdot g_SS\psi_1$ \\\hline [F13] & $S\leftarrow\ii\cdot g_S\bar\psi_1\psi_2$ & $S\leftarrow\ii\cdot g_S\psi_1^T{\mathrm{C}}\psi_2$ \\\hline [F31] & $S\leftarrow\ii\cdot g_S\psi_{2,\alpha}\bar\psi_{1,\alpha}$ & $S\leftarrow\ii\cdot g_S\psi_2^T{\mathrm{C}} \psi_1$\\\hline [F23] & $\psi_1\leftarrow\ii\cdot g_SS\psi_2$ & $\psi_1\leftarrow\ii\cdot g_SS\psi_2$ \\\hline [F32] & $\psi_1\leftarrow\ii\cdot g_S\psi_2 S$ & $\psi_1\leftarrow\ii\cdot g_S\psi_2 S$ \\\hline \multicolumn{3}{|l|}{[FBF (Psibar, P, Psi)]: $\mathcal{L}_I=g_P\bar\psi_1 P\gamma_5\psi_2$} \\\hline [F12] & $\bar\psi_2\leftarrow\ii\cdot g_P\bar\psi_1\gamma_5 P$ & $\psi_2\leftarrow\ii\cdot g_P \gamma_5\psi_1 P$ \\\hline [F21] & $\bar\psi_2\leftarrow\ii\cdot g_P P\bar\psi_1\gamma_5$ & $\psi_2\leftarrow\ii\cdot g_P P\gamma_5\psi_1$ \\\hline [F13] & $P\leftarrow\ii\cdot g_P\bar\psi_1\gamma_5\psi_2$ & $P\leftarrow\ii\cdot g_P\psi_1^T {\mathrm{C}}\gamma_5\psi_2$ \\\hline [F31] & $P\leftarrow\ii\cdot g_P[\gamma_5\psi_2]_\alpha\bar\psi_{1,\alpha}$ & $P\leftarrow\ii\cdot g_P\psi_2^T {\mathrm{C}}\gamma_5\psi_1$ \\\hline [F23] & $\psi_1\leftarrow\ii\cdot g_P P\gamma_5\psi_2$ & $\psi_1\leftarrow\ii\cdot g_P P\gamma_5\psi_2$ \\\hline [F32] & $\psi_1\leftarrow\ii\cdot g_P \gamma_5\psi_2 P$ & $\psi_1\leftarrow\ii\cdot g_P \gamma_5\psi_2 P$ \\\hline \multicolumn{3}{|l|}{[FBF (Psibar, V, Psi)]: $\mathcal{L}_I=g_V\bar\psi_1\fmslash{V}\psi_2$} \\\hline [F12] & $\bar\psi_2\leftarrow\ii\cdot g_V\bar\psi_1\fmslash{V}$ & $\psi_{2,\alpha}\leftarrow\ii\cdot (-g_V)\psi_{1,\beta}\fmslash{V}_{\alpha\beta}$ \\\hline [F21] & $\bar\psi_{2,\beta}\leftarrow\ii\cdot g_V\fmslash{V}_{\alpha\beta} \bar\psi_{1,\alpha}$ & $\psi_2\leftarrow\ii\cdot (-g_V)\fmslash{V}\psi_1$ \\\hline [F13] & $V_\mu\leftarrow\ii\cdot g_V\bar\psi_1\gamma_\mu\psi_2$ & $V_\mu\leftarrow\ii\cdot g_V (\psi_1)^T {\mathrm{C}}\gamma_{\mu}\psi_2$ \\\hline [F31] & $V_\mu\leftarrow\ii\cdot g_V[\gamma_\mu\psi_2]_\alpha\bar\psi_{1,\alpha}$ & $V_\mu\leftarrow\ii\cdot (-g_V)(\psi_2)^T {\mathrm{C}}\gamma_{\mu}\psi_1$ \\\hline [F23] & $\psi_1\leftarrow\ii\cdot g_V\fmslash{V}\psi_2$ & $\psi_1\leftarrow\ii\cdot g_V\fmslash{V}\psi_2$ \\\hline [F32] & $\psi_{1,\alpha}\leftarrow\ii\cdot g_V\psi_{2,\beta}\fmslash{V}_{\alpha\beta}$ & $\psi_{1,\alpha}\leftarrow\ii\cdot g_V\psi_{2,\beta}\fmslash{V}_{\alpha\beta}$ \\\hline \multicolumn{3}{|l|}{[FBF (Psibar, A, Psi)]: $\mathcal{L}_I=g_A\bar\psi_1\gamma_5\fmslash{A}\psi_2$} \\\hline [F12] & $\bar\psi_2\leftarrow\ii\cdot g_A\bar\psi_1\gamma_5\fmslash{A}$ & $\psi_{2,\alpha}\leftarrow\ii\cdot g_A\psi_{\beta}[\gamma_5\fmslash{A}]_{\alpha\beta}$ \\\hline [F21] & $\bar\psi_{2,\beta}\leftarrow\ii\cdot g_A [\gamma_5\fmslash{A}]_{\alpha\beta} \bar\psi_{1,\alpha}$ & $\psi_2\leftarrow\ii\cdot g_A \gamma_5\fmslash{A}\psi$ \\\hline [F13] & $A_\mu\leftarrow\ii\cdot g_A\bar\psi_1\gamma_5\gamma_\mu\psi_2$ & $A_\mu\leftarrow\ii\cdot g_A \psi_1^T {\textrm{C}}\gamma_5\gamma_{\mu}\psi_2$ \\\hline [F31] & $A_\mu\leftarrow\ii\cdot g_A[\gamma_5\gamma_\mu\psi_2]_\alpha\bar\psi_{1,\alpha}$ & $A_\mu\leftarrow\ii\cdot g_A \psi_2^T {\textrm{C}}\gamma_5\gamma_{\mu}\psi_1$ \\\hline [F23] & $\psi_1\leftarrow\ii\cdot g_A\gamma_5\fmslash{A}\psi_2$ & $\psi_1\leftarrow\ii\cdot g_A\gamma_5\fmslash{A}\psi_2$ \\\hline [F32] & $\psi_{1,\alpha}\leftarrow\ii\cdot g_A \psi_{2,\beta}[\gamma_5\fmslash{A}]_{\alpha\beta}$ & $\psi_{1,\alpha}\leftarrow\ii\cdot g_A\psi_{2,\beta}[\gamma_5\fmslash{A}]_{\alpha\beta}$ \\\hline \end{tabular} \end{center} \caption{\label{tab:dim4-fermions} Dimension-4 trilinear fermionic couplings. The momenta are unambiguous, because there are no derivative couplings and all participating fields are different.} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.3} \begin{tabular}{|r|l|l|}\hline & only Dirac fermions & incl.~Majorana fermions \\\hline \multicolumn{3}{|l|}{[FBF (Psibar, T, Psi)]: $\mathcal{L}_I=g_TT_{\mu\nu}\bar\psi_1 [\gamma^\mu,\gamma^\nu]_-\psi_2$}\\\hline [F12] & $\bar\psi_2\leftarrow\ii\cdot g_T \bar\psi_1[\gamma^\mu,\gamma^\nu]_-T_{\mu\nu}$ & $\bar\psi_2\leftarrow\ii\cdot g_T \cdots$ \\\hline [F21] & $\bar\psi_2\leftarrow\ii\cdot g_T T_{\mu\nu} \bar\psi_1[\gamma^\mu,\gamma^\nu]_-$ & $\bar\psi_2\leftarrow\ii\cdot g_T \cdots$ \\\hline [F13] & $T_{\mu\nu}\leftarrow\ii\cdot g_T\bar\psi_1[\gamma_\mu,\gamma_\nu]_-\psi_2$ & $T_{\mu\nu}\leftarrow\ii\cdot g_T \cdots $ \\\hline [F31] & $T_{\mu\nu}\leftarrow\ii\cdot g_T [[\gamma_\mu,\gamma_\nu]_-\psi_2]_\alpha\bar\psi_{1,\alpha}$ & $T_{\mu\nu}\leftarrow\ii\cdot g_T \cdots $ \\\hline [F23] & $\psi_1\leftarrow\ii\cdot g_T T_{\mu\nu}[\gamma^\mu,\gamma^\nu]_-\psi_2$ & $\psi_1\leftarrow\ii\cdot g_T \cdots$ \\\hline [F32] & $\psi_1\leftarrow\ii\cdot g_T [\gamma^\mu,\gamma^\nu]_-\psi_2 T_{\mu\nu}$ & $\psi_1\leftarrow\ii\cdot g_T \cdots$ \\\hline \end{tabular} \end{center} \caption{\label{tab:dim5-fermions} Dimension-5 trilinear fermionic couplings (NB: the coefficients and signs are not fixed yet). The momenta are unambiguous, because there are no derivative couplings and all participating fields are different.} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.3} \begin{tabular}{|r|l|l|}\hline & only Dirac fermions & incl.~Majorana fermions \\\hline \multicolumn{3}{|l|}{[FBF (Psibar, SP, Psi)]: $\mathcal{L}_I=\bar\psi_1\phi(g_S+g_P\gamma_5)\psi_2$}\\\hline [F12] & $\bar\psi_2\leftarrow\ii\cdot\bar\psi_1(g_S+g_P\gamma_5)\phi$ & $\psi_2\leftarrow\ii\cdot \cdots$ \\\hline [F21] & $\bar\psi_2\leftarrow\ii\cdot\phi\bar\psi_1(g_S+g_P\gamma_5)$ & $\psi_2\leftarrow\ii\cdot \cdots$ \\\hline [F13] & $\phi\leftarrow\ii\cdot\bar\psi_1(g_S+g_P\gamma_5)\psi_2$ & $\phi\leftarrow\ii\cdot\cdots$ \\\hline [F31] & $\phi\leftarrow\ii\cdot[(g_S+g_P\gamma_5)\psi_2]_\alpha\bar\psi_{1,\alpha}$ & $\phi\leftarrow\ii\cdot\cdots$ \\\hline [F23] & $\psi_1\leftarrow\ii\cdot \phi(g_S+g_P\gamma_5)\psi_2$ & $\psi_1\leftarrow\ii\cdot\cdots$ \\\hline [F32] & $\psi_1\leftarrow\ii\cdot(g_S+g_P\gamma_5)\psi_2\phi$ & $\psi_1\leftarrow\ii\cdot\cdots$ \\\hline \multicolumn{3}{|l|}{[FBF (Psibar, SL, Psi)]: $\mathcal{L}_I=g_L\bar\psi_1\phi(1-\gamma_5)\psi_2$}\\\hline [F12] & $\bar\psi_2\leftarrow\ii\cdot g_L\bar\psi_1(1-\gamma_5)\phi$ & $\psi_2\leftarrow\ii\cdot \cdots$ \\\hline [F21] & $\bar\psi_2\leftarrow\ii\cdot g_L\phi\bar\psi_1(1-\gamma_5)$ & $\psi_2\leftarrow\ii\cdot \cdots$ \\\hline [F13] & $\phi\leftarrow\ii\cdot g_L\bar\psi_1(1-\gamma_5)\psi_2$ & $\phi\leftarrow\ii\cdot\cdots$ \\\hline [F31] & $\phi\leftarrow\ii\cdot g_L[(1-\gamma_5)\psi_2]_\alpha\bar\psi_{1,\alpha}$ & $\phi\leftarrow\ii\cdot\cdots$ \\\hline [F23] & $\psi_1\leftarrow\ii\cdot g_L\phi(1-\gamma_5)\psi_2$ & $\psi_1\leftarrow\ii\cdot\cdots$ \\\hline [F32] & $\psi_1\leftarrow\ii\cdot g_L(1-\gamma_5)\psi_2\phi$ & $\psi_1\leftarrow\ii\cdot\cdots$ \\\hline \multicolumn{3}{|l|}{[FBF (Psibar, SR, Psi)]: $\mathcal{L}_I=g_R\bar\psi_1\phi(1+\gamma_5)\psi_2$}\\\hline [F12] & $\bar\psi_2\leftarrow\ii\cdot g_R\bar\psi_1(1+\gamma_5)\phi$ & $\psi_2\leftarrow\ii\cdot \cdots$ \\\hline [F21] & $\bar\psi_2\leftarrow\ii\cdot g_R\phi\bar\psi_1(1+\gamma_5)$ & $\psi_2\leftarrow\ii\cdot \cdots$ \\\hline [F13] & $\phi\leftarrow\ii\cdot g_R\bar\psi_1(1+\gamma_5)\psi_2$ & $\phi\leftarrow\ii\cdot\cdots$ \\\hline [F31] & $\phi\leftarrow\ii\cdot g_R[(1+\gamma_5)\psi_2]_\alpha\bar\psi_{1,\alpha}$ & $\phi\leftarrow\ii\cdot\cdots$ \\\hline [F23] & $\psi_1\leftarrow\ii\cdot g_R\phi(1+\gamma_5)\psi_2$ & $\psi_1\leftarrow\ii\cdot\cdots$ \\\hline [F32] & $\psi_1\leftarrow\ii\cdot g_R(1+\gamma_5)\psi_2\phi$ & $\psi_1\leftarrow\ii\cdot\cdots$ \\\hline \multicolumn{3}{|l|}{[FBF (Psibar, SLR, Psi)]: $\mathcal{L}_I=g_L\bar\psi_1\phi(1-\gamma_5)\psi_2 +g_R\bar\psi_1\phi(1+\gamma_5)\psi_2$}\\\hline \end{tabular} \end{center} \caption{\label{tab:dim4-fermions-SP} Combined dimension-4 trilinear fermionic couplings.} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.3} \begin{tabular}{|r|l|l|}\hline & only Dirac fermions & incl.~Majorana fermions \\\hline \multicolumn{3}{|l|}{[FBF (Psibar, VA, Psi)]: $\mathcal{L}_I=\bar\psi_1\fmslash{Z}(g_V-g_A\gamma_5)\psi_2$}\\\hline [F12] & $\bar\psi_2\leftarrow\ii\cdot\bar\psi_1\fmslash{Z}(g_V-g_A\gamma_5)$ & $\psi_2\leftarrow\ii\cdot \cdots$ \\\hline [F21] & $\bar\psi_{2,\beta}\leftarrow\ii\cdot [\fmslash{Z}(g_V-g_A\gamma_5)]_{\alpha\beta}\bar\psi_{1,\alpha}$ & $\psi_2\leftarrow\ii\cdot \cdots$ \\\hline [F13] & $Z_\mu\leftarrow\ii\cdot\bar\psi_1\gamma_\mu(g_V-g_A\gamma_5)\psi_2$ & $Z_\mu\leftarrow\ii\cdot \cdots$ \\\hline [F31] & $Z_\mu\leftarrow\ii\cdot [\gamma_\mu(g_V-g_A\gamma_5)\psi_2]_\alpha\bar\psi_{1,\alpha}$ & $Z_\mu\leftarrow\ii\cdot \cdots$ \\\hline [F23] & $\psi_1\leftarrow\ii\cdot\fmslash{Z}(g_V-g_A\gamma_5)\psi_2$ & $\psi_1\leftarrow\ii\cdot\cdots$ \\\hline [F32] & $\psi_{1,\alpha}\leftarrow\ii\cdot \psi_{2,\beta}[\fmslash{Z}(g_V-g_A\gamma_5)]_{\alpha\beta}$ & $\psi_1\leftarrow\ii\cdot\cdots$ \\\hline \multicolumn{3}{|l|}{[FBF (Psibar, VL, Psi)]: $\mathcal{L}_I=g_L\bar\psi_1\fmslash{Z}(1-\gamma_5)\psi_2$}\\\hline [F12] & $\bar\psi_2\leftarrow\ii\cdot g_L\bar\psi_1\fmslash{Z}(1-\gamma_5)$ & $\psi_2\leftarrow\ii\cdot \cdots$ \\\hline [F21] & $\bar\psi_{2,\beta}\leftarrow\ii\cdot g_L[\fmslash{Z}(1-\gamma_5)]_{\alpha\beta}\bar\psi_{1,\alpha}$ & $\psi_2\leftarrow\ii\cdot \cdots$ \\\hline [F13] & $Z_\mu\leftarrow\ii\cdot g_L\bar\psi_1\gamma_\mu(1-\gamma_5)\psi_2$ & $Z_\mu\leftarrow\ii\cdot \cdots$ \\\hline [F31] & $Z_\mu\leftarrow\ii\cdot g_L[\gamma_\mu(1-\gamma_5)\psi_2]_\alpha\bar\psi_{1,\alpha}$ & $Z_\mu\leftarrow\ii\cdot \cdots$ \\\hline [F23] & $\psi_1\leftarrow\ii\cdot g_L\fmslash{Z}(1-\gamma_5)\psi_2$ & $\psi_1\leftarrow\ii\cdot\cdots$ \\\hline [F32] & $\psi_{1,\alpha}\leftarrow\ii\cdot g_L\psi_{2,\beta}[\fmslash{Z}(1-\gamma_5)]_{\alpha\beta}$ & $\psi_1\leftarrow\ii\cdot\cdots$ \\\hline \multicolumn{3}{|l|}{[FBF (Psibar, VR, Psi)]: $\mathcal{L}_I=g_R\bar\psi_1\fmslash{Z}(1+\gamma_5)\psi_2$}\\\hline [F12] & $\bar\psi_2\leftarrow\ii\cdot g_R\bar\psi_1\fmslash{Z}(1+\gamma_5)$ & $\psi_2\leftarrow\ii\cdot \cdots$ \\\hline [F21] & $\bar\psi_{2,\beta}\leftarrow\ii\cdot g_R[\fmslash{Z}(1+\gamma_5)]_{\alpha\beta}\bar\psi_{1,\alpha}$ & $\psi_2\leftarrow\ii\cdot \cdots$ \\\hline [F13] & $Z_\mu\leftarrow\ii\cdot g_R\bar\psi_1\gamma_\mu(1+\gamma_5)\psi_2$ & $Z_\mu\leftarrow\ii\cdot \cdots$ \\\hline [F31] & $Z_\mu\leftarrow\ii\cdot g_R[\gamma_\mu(1+\gamma_5)\psi_2]_\alpha\bar\psi_{1,\alpha}$ & $Z_\mu\leftarrow\ii\cdot \cdots$ \\\hline [F23] & $\psi_1\leftarrow\ii\cdot g_R\fmslash{Z}(1+\gamma_5)\psi_2$ & $\psi_1\leftarrow\ii\cdot\cdots$ \\\hline [F32] & $\psi_{1,\alpha}\leftarrow\ii\cdot g_R\psi_{2,\beta}[\fmslash{Z}(1+\gamma_5)]_{\alpha\beta}$ & $\psi_1\leftarrow\ii\cdot\cdots$ \\\hline \multicolumn{3}{|l|}{[FBF (Psibar, VLR, Psi)]: $\mathcal{L}_I=g_L\bar\psi_1\fmslash{Z}(1-\gamma_5)\psi_2 +g_R\bar\psi_1\fmslash{Z}(1+\gamma_5)\psi_2$}\\\hline \end{tabular} \end{center} \caption{\label{tab:dim4-fermions-VA} Combined dimension-4 trilinear fermionic couplings continued.} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.4} \begin{tabular}{|>{\qquad}r<{:}l|r<{:}l|}\hline \multicolumn{4}{|l|}{[FBF (Psibar, S, Chi)]: $\bar\psi S\chi$}\\\hline [F12] & $\chi\leftarrow\psi S$ & [F21] & $\chi\leftarrow S \psi$ \\\hline [F13] & $S\leftarrow \psi^T{\rm C}\chi$ & [F31] & $S\leftarrow \chi^T {\rm C}\psi$ \\\hline [F23] & $\psi\leftarrow S\chi$ & [F32] & $\psi\leftarrow\chi S$ \\\hline \multicolumn{4}{|l|}{[FBF (Psibar, P, Chi)]: $\bar\psi P\gamma_5\chi$}\\\hline [F12] & $\chi\leftarrow \gamma_5 \psi P$ & [F21] & $\chi\leftarrow P \gamma_5 \psi$ \\\hline [F13] & $P\leftarrow \psi^T {\rm C}\gamma_5\chi$ & [F31] & $P\leftarrow \chi^T {\rm C}\gamma_5\psi$ \\\hline [F23] & $\psi\leftarrow P\gamma_5\chi$ & [F32] & $\psi\leftarrow\gamma_5\chi P$ \\\hline \multicolumn{4}{|l|}{[FBF (Psibar, V, Chi)]: $\bar\psi\fmslash{V}\chi$}\\\hline [F12] & $\chi_{\alpha}\leftarrow-\psi_{\beta}\fmslash{V}_{\alpha\beta}$ & [F21] & $\chi\leftarrow-\fmslash{V}\psi$ \\\hline [F13] & $V_{\mu}\leftarrow \psi^T {\rm C}\gamma_{\mu}\chi$ & [F31] & $V_{\mu}\leftarrow \chi^T {\rm C}(-\gamma_{\mu}\psi)$ \\\hline [F23] & $\psi\leftarrow\fmslash{V}\chi$ & [F32] & $\psi_\alpha\leftarrow\chi_\beta\fmslash{V}_{\alpha\beta}$ \\\hline \multicolumn{4}{|l|}{[FBF (Psibar, A, Chi)]: $\bar\psi\gamma^5\fmslash{A}\chi$}\\\hline [F12] & $\chi_{\alpha}\leftarrow\psi_{\beta}\lbrack \gamma^5 \fmslash{A} \rbrack_{\alpha\beta}$ & [F21] & $\chi\leftarrow\gamma^5\fmslash{A}\psi$ \\\hline [F13] & $A_{\mu}\leftarrow \psi^T {\rm C}\gamma^5\gamma_{\mu}\chi$ & [F31] & $A_{\mu}\leftarrow \chi^T {\rm C}(\gamma^5 \gamma_{\mu}\psi)$ \\\hline [F23] & $\psi\leftarrow\gamma^5\fmslash{A}\chi$ & [F32] & $\psi_\alpha\leftarrow\chi_\beta\lbrack \gamma^5 \fmslash{A} \rbrack_{\alpha\beta}$ \\\hline \end{tabular} \end{center} \caption{\label{tab:dim4-fermions-maj} Dimension-4 trilinear couplings including one Dirac and one Majorana fermion} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.4} \begin{tabular}{|>{\qquad}r<{:}l|r<{:}l|}\hline \multicolumn{4}{|l|}{[FBF (Psibar, SP, Chi)]: $\bar\psi\phi(g_S+g_P\gamma_5)\chi$}\\\hline [F12] & $\chi \leftarrow (g_S+g_P\gamma_5)\psi \phi$ & [F21] & $\chi\leftarrow\phi(g_S+g_P\gamma_5)\psi$ \\\hline [F13] & $\phi\leftarrow \psi^T {\rm C}(g_S+g_P\gamma_5)\chi$ & [F31] & $\phi\leftarrow \chi^T {\rm C}(g_S+g_P\gamma_5) \chi$ \\\hline [F23] & $\psi\leftarrow \phi(g_S+g_P\gamma_5)\chi$ & [F32] & $\psi\leftarrow(g_S+g_P\gamma_5)\chi\phi$ \\\hline \multicolumn{4}{|l|}{[FBF (Psibar, VA, Chi)]: $\bar\psi\fmslash{Z}(g_V - g_A\gamma_5)\chi$}\\\hline [F12] & $\chi_\alpha\leftarrow \psi_\beta[\fmslash{Z}(-g_V-g_A\gamma_5)]_{\alpha\beta}$ & [F21] & $\chi\leftarrow\fmslash{Z}(-g_V-g_A\gamma_5)] \psi$ \\\hline [F13] & $Z_\mu\leftarrow \psi^T {\rm C}\gamma_\mu(g_V-g_A\gamma_5)\chi$ & [F31] & $Z_\mu\leftarrow \chi^T {\rm C}\gamma_\mu(-g_V-g_A\gamma_5)\psi$ \\\hline [F23] & $\psi\leftarrow\fmslash{Z}(g_V-g_A\gamma_5)\chi$ & [F32] & $\psi_\alpha\leftarrow \chi_\beta[\fmslash{Z}(g_V-g_A\gamma_5)]_{\alpha\beta}$ \\\hline \end{tabular} \end{center} \caption{\label{tab:dim4-fermions-SPVA-maj} Combined dimension-4 trilinear fermionic couplings including one Dirac and one Majorana fermion.} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.4} \begin{tabular}{|>{\qquad}r<{:}l|r<{:}l|}\hline \multicolumn{4}{|l|}{[FBF (Chibar, S, Psi)]: $\bar\chi S\psi$}\\\hline [F12] & $\psi\leftarrow\chi S$ & [F21] & $\psi\leftarrow S\chi$ \\\hline [F13] & $S\leftarrow \chi^T {\rm C}\psi$ & [F31] & $S\leftarrow \psi^T {\rm C}\chi$ \\\hline [F23] & $\chi\leftarrow S \psi$ & [F32] & $\chi\leftarrow\psi S$ \\\hline \multicolumn{4}{|l|}{[FBF (Chibar, P, Psi)]: $\bar\chi P\gamma_5\psi$}\\\hline [F12] & $\psi\leftarrow\gamma_5\chi P$ & [F21] & $\psi\leftarrow P\gamma_5\chi$ \\\hline [F13] & $P\leftarrow \chi^T {\rm C}\gamma_5\psi$ & [F31] & $P\leftarrow \psi^T {\rm C}\gamma_5\chi$ \\\hline [F23] & $\chi\leftarrow P \gamma_5 \psi$ & [F32] & $\chi\leftarrow \gamma_5 \psi P$ \\\hline \multicolumn{4}{|l|}{[FBF (Chibar, V, Psi)]: $\bar\chi\fmslash{V}\psi$}\\\hline [F12] & $\psi_\alpha\leftarrow-\chi_\beta\fmslash{V}_{\alpha\beta}$ & [F21] & $\psi\leftarrow-\fmslash{V}\chi$ \\\hline [F13] & $V_{\mu}\leftarrow \chi^T {\rm C}\gamma_{\mu}\psi$ & [F31] & $V_{\mu}\leftarrow \psi^T {\rm C}(-\gamma_{\mu}\chi)$ \\\hline [F23] & $\chi\leftarrow\fmslash{V}\psi$ & [F32] & $\chi_{\alpha}\leftarrow\psi_{\beta}\fmslash{V}_{\alpha\beta}$ \\\hline \multicolumn{4}{|l|}{[FBF (Chibar, A, Psi)]: $\bar\chi\gamma^5\fmslash{A}\psi$}\\\hline [F12] & $\psi_\alpha\leftarrow\chi_\beta\lbrack\gamma^5\fmslash{A} \rbrack_{\alpha\beta}$ & [F21] & $\psi\leftarrow\gamma^5\fmslash{A}\chi$ \\\hline [F13] & $A_{\mu}\leftarrow \chi^T {\rm C}(\gamma^5\gamma_{\mu}\psi)$ & [F31] & $A_{\mu}\leftarrow \psi^T {\rm C}\gamma^5\gamma_{\mu}\chi$ \\\hline [F23] & $\chi\leftarrow\gamma^5\fmslash{A}\psi$ & [F32] & $\chi_{\alpha}\leftarrow\psi_{\beta}\lbrack\gamma^5\fmslash{A} \rbrack_{\alpha\beta}$ \\\hline \end{tabular} \end{center} \caption{\label{tab:dim4-fermions-maj'} Dimension-4 trilinear couplings including one Dirac and one Majorana fermion} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.4} \begin{tabular}{|>{\qquad}r<{:}l|r<{:}l|}\hline \multicolumn{4}{|l|}{[FBF (Chibar, SP, Psi)]: $\bar\chi\phi(g_S+g_P\gamma_5)\psi$}\\\hline [F12] & $\psi\leftarrow(g_S+g_P\gamma_5)\chi\phi$ & [F21] & $\psi\leftarrow \phi(g_S+g_P\gamma_5)\chi$ \\\hline [F13] & $\phi\leftarrow \chi^T {\rm C}(g_S+g_P\gamma_5) \psi$ & [F31] & $\phi\leftarrow \psi^T {\rm C}(g_S+g_P\gamma_5)\chi$ \\\hline [F23] & $\chi\leftarrow\phi(g_S+g_P\gamma_5)\psi$ & [F32] & $\chi \leftarrow (g_S+g_P\gamma_5)\psi \phi$ \\\hline \multicolumn{4}{|l|}{[FBF (Chibar, VA, Psi)]: $\bar\chi\fmslash{Z}(g_V - g_A\gamma_5)\psi$}\\\hline [F12] & $\psi_\alpha\leftarrow \chi_\beta[\fmslash{Z}(-g_V-g_A\gamma_5)]_{\alpha\beta}$ & [F21] & $\psi\leftarrow\fmslash{Z}(-g_V-g_A\gamma_5)\chi$ \\\hline [F13] & $Z_\mu\leftarrow \chi^T {\rm C}\gamma_\mu(g_V-g_A\gamma_5)\psi$ & [F31] & $Z_\mu\leftarrow \psi^T {\rm C}\gamma_\mu(-g_V-g_A\gamma_5)\chi$ \\\hline [F23] & $\chi\leftarrow\fmslash{Z}(g_V-g_A\gamma_5)] \psi$ & [F32] & $\chi_\alpha\leftarrow\psi_\beta[\fmslash{Z}(g_V-g_A\gamma_5)]_{\alpha\beta}$ \\\hline \end{tabular} \end{center} \caption{\label{tab:dim4-fermions-SPVA-maj'} Combined dimension-4 trilinear fermionic couplings including one Dirac and one Majorana fermion.} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.4} \begin{tabular}{|>{\qquad}r<{:}l|r<{:}l|}\hline \multicolumn{4}{|l|}{[FBF (Chibar, S, Chi)]: $\bar\chi_a S\chi_b$}\\\hline [F12] & $\chi_b\leftarrow\chi_a S$ & [F21] & $\chi_b\leftarrow S \chi_a$ \\\hline [F13] & $S\leftarrow \chi^T_a {\rm C}\chi_b$ & [F31] & $S\leftarrow \chi^T_b {\rm C}\chi_a$ \\\hline [F23] & $\chi_a\leftarrow S\chi_b$ & [F32] & $\chi_a\leftarrow\chi S_b$ \\\hline \multicolumn{4}{|l|}{[FBF (Chibar, P, Chi)]: $\bar\chi_a P\gamma_5\psi_b$}\\\hline [F12] & $\chi_b\leftarrow \gamma_5 \chi_a P$ & [F21] & $\chi_b\leftarrow P \gamma_5 \chi_a$ \\\hline [F13] & $P\leftarrow \chi^T_a {\rm C}\gamma_5\chi_b$ & [F31] & $P\leftarrow \chi^T_b {\rm C}\gamma_5\chi_a$ \\\hline [F23] & $\chi_a\leftarrow P\gamma_5\chi_b$ & [F32] & $\chi_a\leftarrow\gamma_5\chi_b P$ \\\hline \multicolumn{4}{|l|}{[FBF (Chibar, V, Chi)]: $\bar\chi_a\fmslash{V}\chi_b$}\\\hline [F12] & $\chi_{b,\alpha}\leftarrow-\chi_{a,\beta}\fmslash{V}_{\alpha\beta}$ & [F21] & $\chi_b\leftarrow-\fmslash{V}\chi_a$ \\\hline [F13] & $V_{\mu}\leftarrow \chi^T_a {\rm C}\gamma_{\mu}\chi_b$ & [F31] & $V_{\mu}\leftarrow - \chi^T_b {\rm C}\gamma_{\mu}\chi_a$ \\\hline [F23] & $\chi_a\leftarrow\fmslash{V}\chi_b$ & [F32] & $\chi_{a,\alpha}\leftarrow\chi_{b,\beta}\fmslash{V}_{\alpha\beta}$ \\\hline \multicolumn{4}{|l|}{[FBF (Chibar, A, Chi)]: $\bar\chi_a\gamma^5\fmslash{A}\chi_b$}\\\hline [F12] & $\chi_{b,\alpha}\leftarrow\chi_{a,\beta}\lbrack\gamma^5\fmslash{A} \rbrack_{\alpha\beta}$ & [F21] & $\chi_b\leftarrow\gamma^5\fmslash{A}\chi_a$ \\\hline [F13] & $A_{\mu}\leftarrow \chi^T_a {\rm C}\gamma^5\gamma_{\mu}\chi_b$ & [F31] & $A_{\mu}\leftarrow \chi^T_b {\rm C}(\gamma^5\gamma_{\mu}\chi_a)$ \\\hline [F23] & $\chi_a\leftarrow\gamma^5\fmslash{A}\chi_b$ & [F32] & $\chi_{a,\alpha}\leftarrow\chi_{b,\beta}\lbrack\gamma^5\fmslash{A} \rbrack_{\alpha\beta}$ \\\hline \end{tabular} \end{center} \caption{\label{tab:dim4-fermions-maj2} Dimension-4 trilinear couplings of two Majorana fermions} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.4} \begin{tabular}{|>{\qquad}r<{:}l|r<{:}l|}\hline \multicolumn{4}{|l|}{[FBF (Chibar, SP, Chi)]: $\bar\chi\phi_a(g_S+g_P\gamma_5)\chi_b$}\\\hline [F12] & $\chi_b \leftarrow (g_S+g_P\gamma_5)\chi_a \phi$ & [F21] & $\chi_b\leftarrow\phi(g_S+g_P\gamma_5)\chi_a$ \\\hline [F13] & $\phi\leftarrow \chi^T_a {\rm C}(g_S+g_P\gamma_5)\chi_b$ & [F31] & $\phi\leftarrow \chi^T_b {\rm C}(g_S+g_P\gamma_5) \chi_a$ \\\hline [F23] & $\chi_a\leftarrow \phi(g_S+g_P\gamma_5)\chi_b$ & [F32] & $\chi_a\leftarrow(g_S+g_P\gamma_5)\chi_b\phi$ \\\hline \multicolumn{4}{|l|}{[FBF (Chibar, VA, Chi)]: $\bar\chi_a\fmslash{Z}(g_V-g_A\gamma_5)\chi_b$}\\\hline [F12] & $\chi_{b,\alpha}\leftarrow\chi_{a,\beta}[\fmslash{Z}(-g_V-g_A\gamma_5)]_{\alpha\beta}$ & [F21] & $\chi_b\leftarrow\fmslash{Z}(-g_V-g_A\gamma_5)]\chi_a$ \\\hline [F13] & $Z_\mu\leftarrow \chi^T_a {\rm C}\gamma_\mu(g_V-g_A\gamma_5)\chi_b$ & [F31] & $Z_\mu\leftarrow \chi^T_b {\rm C}\gamma_\mu(-g_V-g_A\gamma_5)\chi_a$ \\\hline [F23] & $\chi_a\leftarrow\fmslash{Z}(g_V-g_A\gamma_5)\chi_b$ & [F32] & $\chi_{a,\alpha}\leftarrow \chi_{b,\beta}[\fmslash{Z}(g_V-g_A\gamma_5)]_{\alpha\beta}$ \\\hline \end{tabular} \end{center} \caption{\label{tab:dim4-fermions-SPVA-maj2} Combined dimension-4 trilinear fermionic couplings of two Majorana fermions.} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.3} \begin{tabular}{|>{\qquad}r<{:}l|}\hline \multicolumn{2}{|l|}{[Gauge_Gauge_Gauge]: $\mathcal{L}_I=gf_{abc} A_a^\mu A_b^\nu\partial_\mu A_{c,\nu}$}\\\hline [_] & $A_a^\mu\leftarrow\ii\cdot (-\ii g/2)\cdot C_{abc}^{\mu\rho\sigma}(-k_2-k_3,k_2,k_3) A^b_\rho A^c_\sigma$\\\hline \multicolumn{2}{|l|}{[Aux_Gauge_Gauge]: $\mathcal{L}_I=gf_{abc}X_{a,\mu\nu}(k_1) ( A_b^{\mu}(k_2)A_c^{\nu}(k_3) -A_b^{\nu}(k_2)A_c^{\mu}(k_3))$}\\\hline [F23]$\lor$[F32] & $X_a^{\mu\nu}(k_2+k_3)\leftarrow\ii\cdot gf_{abc}( A_b^\mu(k_2)A_c^\nu(k_3) -A_b^\nu(k_2)A_c^\mu(k_3))$ \\\hline [F12]$\lor$[F13] & $A_{a,\mu}(k_1+k_{2/3})\leftarrow\ii\cdot gf_{abc}X_{b,\nu\mu}(k_1)A_c^\nu(k_{2/3})$ \\\hline [F21]$\lor$[F31] & $A_{a,\mu}(k_{2/3}+k_1)\leftarrow\ii\cdot gf_{abc}A_b^\nu(k_{2/3}) X_{c,\mu\nu}(k_1)$ \\\hline \end{tabular} \end{center} \caption{\label{tab:dim4-bosons} Dimension-4 Vector Boson couplings with \emph{outgoing} momenta. See~(\ref{eq:C123}) and~(\ref{eq:C123'}) for the definition of the antisymmetric tensor $C^{\mu_1\mu_2\mu_3}(k_1,k_2,k_3)$.} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.3} \begin{tabular}{|>{\qquad}r<{:}l|r<{:}l|}\hline \multicolumn{4}{|l|}{[Scalar_Vector_Vector]: $\mathcal{L}_I=g\phi V_1^\mu V_{2,\mu}$}\\\hline [F13] & $\leftarrow\ii\cdot g\cdots$ & [F31] & $\leftarrow\ii\cdot g\cdots$ \\\hline [F12] & $\leftarrow\ii\cdot g\cdots$ & [F21] & $\leftarrow\ii\cdot g\cdots$ \\\hline [F23] & $\phi\leftarrow\ii\cdot g V_1^\mu V_{2,\mu}$ & [F32] & $\phi\leftarrow\ii\cdot g V_{2,\mu} V_1^\mu$ \\\hline \multicolumn{4}{|l|}{[Aux_Vector_Vector]: $\mathcal{L}_I=gX V_1^\mu V_{2,\mu}$}\\\hline [F13] & $\leftarrow\ii\cdot g\cdots$ & [F31] & $\leftarrow\ii\cdot g\cdots$ \\\hline [F12] & $\leftarrow\ii\cdot g\cdots$ & [F21] & $\leftarrow\ii\cdot g\cdots$ \\\hline [F23] & $X\leftarrow\ii\cdot g V_1^\mu V_{2,\mu}$ & [F32] & $X\leftarrow\ii\cdot g V_{2,\mu} V_1^\mu$ \\\hline \multicolumn{4}{|l|}{[Aux_Scalar_Vector]: $\mathcal{L}_I=gX^\mu \phi V_\mu$}\\\hline [F13] & $\leftarrow\ii\cdot g\cdots$ & [F31] & $\leftarrow\ii\cdot g\cdots$ \\\hline [F12] & $\leftarrow\ii\cdot g\cdots$ & [F21] & $\leftarrow\ii\cdot g\cdots$ \\\hline [F23] & $\leftarrow\ii\cdot g\cdots$ & [F32] & $\leftarrow\ii\cdot g\cdots$ \\\hline \end{tabular} \end{center} \caption{\label{tab:scalar-vector} \ldots} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.3} \begin{tabular}{|>{\qquad}r<{:}l|r<{:}l|}\hline \multicolumn{4}{|l|}{[Scalar_Scalar_Scalar]: $\mathcal{L}_I=g\phi_1\phi_2\phi_3$}\\\hline [F13] & $\phi_2\leftarrow\ii\cdot g \phi_1\phi_3$ & [F31] & $\phi_2\leftarrow\ii\cdot g \phi_3\phi_1$ \\\hline [F12] & $\phi_3\leftarrow\ii\cdot g \phi_1\phi_2$ & [F21] & $\phi_3\leftarrow\ii\cdot g \phi_2\phi_1$ \\\hline [F23] & $\phi_1\leftarrow\ii\cdot g \phi_2\phi_3$ & [F32] & $\phi_1\leftarrow\ii\cdot g \phi_3\phi_2$ \\\hline \multicolumn{4}{|l|}{[Aux_Scalar_Scalar]: $\mathcal{L}_I=gX\phi_1\phi_2$}\\\hline [F13] & $\leftarrow\ii\cdot g\cdots$ & [F31] & $\leftarrow\ii\cdot g\cdots$ \\\hline [F12] & $\leftarrow\ii\cdot g\cdots$ & [F21] & $\leftarrow\ii\cdot g\cdots$ \\\hline [F23] & $X\leftarrow\ii\cdot g \phi_1\phi_2$ & [F32] & $X\leftarrow\ii\cdot g \phi_2\phi_1$ \\\hline \end{tabular} \end{center} \caption{\label{tab:scalars} \ldots} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.3} \begin{tabular}{|>{\qquad}r<{:}l|}\hline \multicolumn{2}{|l|}{[Vector_Scalar_Scalar]: $\mathcal{L}_I=gV^\mu\phi_1 \ii\overleftrightarrow{\partial_\mu}\phi_2$}\\\hline [F23] & $V^\mu(k_2+k_3)\leftarrow\ii\cdot g(k_2^\mu-k_3^\mu)\phi_1(k_2)\phi_2(k_3)$ \\\hline [F32] & $V^\mu(k_2+k_3)\leftarrow\ii\cdot g(k_2^\mu-k_3^\mu)\phi_2(k_3)\phi_1(k_2)$ \\\hline [F12] & $\phi_2(k_1+k_2)\leftarrow\ii\cdot g(k_1^\mu+2k_2^\mu)V_\mu(k_1)\phi_1(k_2)$ \\\hline [F21] & $\phi_2(k_1+k_2)\leftarrow\ii\cdot g(k_1^\mu+2k_2^\mu)\phi_1(k_2)V_\mu(k_1)$ \\\hline [F13] & $\phi_1(k_1+k_3)\leftarrow\ii\cdot g(-k_1^\mu-2k_3^\mu)V_\mu(k_1)\phi_2(k_3)$ \\\hline [F31] & $\phi_1(k_1+k_3)\leftarrow\ii\cdot g(-k_1^\mu-2k_3^\mu)\phi_2(k_3)V_\mu(k_1)$ \\\hline \end{tabular} \end{center} \caption{\label{tab:scalar-current} \ldots} \end{table} *) (* \begin{table} \begin{center} \renewcommand{\arraystretch}{1.3} \begin{tabular}{|>{\qquad}r<{:}l|}\hline \multicolumn{2}{|l|}{[Aux_DScalar_DScalar]: $\mathcal{L}_I=g\chi (\ii\partial_\mu\phi_1)(\ii\partial^\mu\phi_2)$}\\\hline [F23] & $\chi(k_2+k_3)\leftarrow\ii\cdot g (k_2\cdot k_3) \phi_1(k_2) \phi_2(k_3) $ \\\hline [F32] & $\chi(k_2+k_3)\leftarrow\ii\cdot g (k_3\cdot k_2) \phi_2(k_3) \phi_1(k_2) $ \\\hline [F12] & $\phi_2(k_1+k_2)\leftarrow\ii\cdot g ((-k_1-k_2) \cdot k_2) \chi(k_1) \phi_1(k_2) $ \\\hline [F21] & $\phi_2(k_1+k_2)\leftarrow\ii\cdot g (k_2 \cdot (-k_1-k_2)) \phi_1(k_2) \chi(k_1) $ \\\hline [F13] & $\phi_1(k_1+k_3)\leftarrow\ii\cdot g ((-k_1-k_3) \cdot k_3) \chi(k_1) \phi_2(k_3) $ \\\hline [F31] & $\phi_1(k_1+k_3)\leftarrow\ii\cdot g (k_3 \cdot (-k_1-k_3)) \phi_2(k_3) \chi(k_1) $ \\\hline \end{tabular} \end{center} \caption{\label{tab:dscalar-dscalar} \ldots} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.3} \begin{tabular}{|>{\qquad}r<{:}l|}\hline \multicolumn{2}{|l|}{[Aux_Vector_DScalar]: $\mathcal{L}_I=g\chi V_\mu (\ii\partial^\mu\phi)$}\\\hline [F23] & $\chi(k_2+k_3)\leftarrow\ii\cdot g k_3^\mu V_\mu(k_2) \phi(k_3) $ \\\hline [F32] & $\chi(k_2+k_3)\leftarrow\ii\cdot g \phi(k_3) k_3^\mu V_\mu(k_2) $ \\\hline [F12] & $\phi(k_1+k_2)\leftarrow\ii\cdot g \chi(k_1) (-k_1-k_2)^\mu V_\mu(k_2) $ \\\hline [F21] & $\phi(k_1+k_2)\leftarrow\ii\cdot g (-k_1-k_2)^\mu V_\mu(k_2) \chi(k_1) $ \\\hline [F13] & $V_\mu(k_1+k_3)\leftarrow\ii\cdot g (-k_1-k_3)_\mu \chi(k_1) \phi(k_3) $ \\\hline [F31] & $V_\mu(k_1+k_3)\leftarrow\ii\cdot g (-k_1-k_3)_\mu \phi(k_3) \chi(k_1) $ \\\hline \end{tabular} \end{center} \caption{\label{tab:vector-dscalar} \ldots} \end{table} *) (* Signify which two of three fields are fused: *) type fuse2 = F23 | F32 | F31 | F13 | F12 | F21 (* Signify which three of four fields are fused: *) type fuse3 = | F123 | F231 | F312 | F132 | F321 | F213 | F124 | F241 | F412 | F142 | F421 | F214 | F134 | F341 | F413 | F143 | F431 | F314 | F234 | F342 | F423 | F243 | F432 | F324 (* Explicit enumeration types make no sense for higher degrees. *) type fusen = int list (* The third member of the triplet will contain the coupling constant: *) type 'a t = | V3 of 'a vertex3 * fuse2 * 'a | V4 of 'a vertex4 * fuse3 * 'a | Vn of 'a vertexn * fusen * 'a (* \thocwmodulesection{Gauge Couplings} Dimension-4 trilinear vector boson couplings \begin{subequations} \begin{multline} f_{abc}\partial^{\mu}A^{a,\nu}A^b_{\mu}A^c_{\nu} \rightarrow \ii f_{abc}k_1^\mu A^{a,\nu}(k_1)A^b_{\mu}(k_2)A^c_{\nu}(k_3) \\ = -\frac{\ii}{3!} f_{a_1a_2a_3} C^{\mu_1\mu_2\mu_3}(k_1,k_2,k_3) A^{a_1}_{\mu_1}(k_1)A^{a_2}_{\mu_2}(k_2)A^{a_3}_{\mu_3}(k_3) \end{multline} with the totally antisymmetric tensor (under simultaneous permutations of all quantum numbers $\mu_i$ and $k_i$) and all momenta \emph{outgoing} \begin{equation} \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{equation} \end{subequations} Since~$f_{a_1a_2a_3}C^{\mu_1\mu_2\mu_3}(k_1,k_2,k_3)$ is totally symmetric (under simultaneous permutations of all quantum numbers $a_i$, $\mu_i$ and $k_i$), it is easy to take the partial derivative \begin{subequations} \label{eq:AofAA} \begin{equation} A^{a,\mu}(k_2+k_3) = - \frac{\ii}{2!} f_{abc}C^{\mu\rho\sigma}(-k_2-k_3,k_2,k_3) A^b_\rho(k_2)A^c_\sigma(k_3) \end{equation} with \begin{equation} \label{eq:C123'} C^{\mu\rho\sigma}(-k_2-k_3,k_2,k_3) = ( g^{\rho\sigma} ( k_2^{\mu} -k_3^{\mu} ) + g^{\mu\sigma} (2k_3^{\rho} +k_2^{\rho} ) - g^{\mu\rho} (2k_2^{\sigma}+k_3^{\sigma}) ) \end{equation} i.\,e. \begin{multline} \label{eq:fuse-gauge} A^{a,\mu}(k_2+k_3) = - \frac{\ii}{2!} f_{abc} \bigl( (k_2^{\mu}-k_3^{\mu})A^b(k_2) \cdot A^c(k_3) \\ + (2k_3+k_2)\cdot A^b(k_2)A^{c,\mu}(k_3) - A^{b,\mu}(k_2)A^c(k_3)\cdot(2k_2+k_3) \bigr) \end{multline} \end{subequations} \begin{dubious} Investigate the rearrangements proposed in~\cite{HELAS} for improved numerical stability. \end{dubious} *) (* \thocwmodulesubsection{Non-Gauge Vector Couplings} As a basis for the dimension-4 couplings of three vector bosons, we choose ``transversal'' and ``longitudinal'' (with respect to the first vector field) tensors that are odd and even under permutation of the second and third argument \begin{subequations} \begin{align} \mathcal{L}_T(V_1,V_2,V_3) &= V_1^\mu (V_{2,\nu}\ii\overleftrightarrow{\partial_\mu}V_3^\nu) = - \mathcal{L}_T(V_1,V_3,V_2) \\ \mathcal{L}_L(V_1,V_2,V_3) &= (\ii\partial_\mu V_1^\mu) V_{2,\nu}V_3^\nu = \mathcal{L}_L(V_1,V_3,V_2) \end{align} \end{subequations} Using partial integration in~$\mathcal{L}_L$, we find the convenient combinations \begin{subequations} \begin{align} \mathcal{L}_T(V_1,V_2,V_3) + \mathcal{L}_L(V_1,V_2,V_3) &= - 2 V_1^\mu \ii\partial_\mu V_{2,\nu} V_3^\nu \\ \mathcal{L}_T(V_1,V_2,V_3) - \mathcal{L}_L(V_1,V_2,V_3) &= 2 V_1^\mu V_{2,\nu} \ii\partial_\mu V_3^\nu \end{align} \end{subequations} As an important example, we can rewrite the dimension-4 ``anomalous'' triple gauge couplings \begin{multline} \ii\mathcal{L}_{\textrm{TGC}}(g_1,\kappa,g_4)/g_{VWW} = g_1 V^\mu (W^-_{\mu\nu} W^{+,\nu} - W^+_{\mu\nu} W^{-,\nu}) \\ + \kappa W^+_\mu W^-_\nu V^{\mu\nu} + g_4 W^+_\mu W^-_\nu (\partial^\mu V^\nu + \partial^\nu V^\mu) \end{multline} as \begin{multline} \mathcal{L}_{\textrm{TGC}}(g_1,\kappa,g_4) = g_1 \mathcal{L}_T(V,W^-,W^+) \\ - \frac{\kappa+g_1-g_4}{2} \mathcal{L}_T(W^-,V,W^+) + \frac{\kappa+g_1+g_4}{2} \mathcal{L}_T(W^+,V,W^-) \\ - \frac{\kappa-g_1-g_4}{2} \mathcal{L}_L(W^-,V,W^+) + \frac{\kappa-g_1+g_4}{2} \mathcal{L}_L(W^+,V,W^-) \end{multline} \thocwmodulesubsection{$CP$ Violation} \begin{subequations} \begin{align} \mathcal{L}_{\tilde T}(V_1,V_2,V_3) &= V_{1,\mu}(V_{2,\rho}\ii\overleftrightarrow{\partial_\nu} V_{3,\sigma})\epsilon^{\mu\nu\rho\sigma} = + \mathcal{L}_T(V_1,V_3,V_2) \\ \mathcal{L}_{\tilde L}(V_1,V_2,V_3) &= (\ii\partial_\mu V_{1,\nu}) V_{2,\rho}V_{3,\sigma}\epsilon^{\mu\nu\rho\sigma} = - \mathcal{L}_L(V_1,V_3,V_2) \end{align} \end{subequations} Here the notations~$\tilde T$ and~$\tilde L$ are clearly \textit{abuse de langage}, because $\mathcal{L}_{\tilde L}(V_1,V_2,V_3)$ is actually the transversal combination, due to the antisymmetry of~$\epsilon$. Using partial integration in~$\mathcal{L}_{\tilde L}$, we could again find combinations \begin{subequations} \begin{align} \mathcal{L}_{\tilde T}(V_1,V_2,V_3) + \mathcal{L}_{\tilde L}(V_1,V_2,V_3) &= - 2 V_{1,\mu} V_{2,\nu} \ii\partial_\rho V_{3,\sigma} \epsilon^{\mu\nu\rho\sigma} \\ \mathcal{L}_{\tilde T}(V_1,V_2,V_3) - \mathcal{L}_{\tilde L}(V_1,V_2,V_3) &= - 2 V_{1,\mu} \ii\partial_\nu V_{2,\rho} V_{3,\sigma} \epsilon^{\mu\nu\rho\sigma} \end{align} \end{subequations} but we don't need them, since \begin{multline} \ii\mathcal{L}_{\textrm{TGC}}(g_5,\tilde\kappa)/g_{VWW} = g_5 \epsilon_{\mu\nu\rho\sigma} (W^{+,\mu} \ii\overleftrightarrow{\partial^\rho} W^{-,\nu}) V^\sigma \\ - \frac{\tilde\kappa_V}{2} W^-_\mu W^+_\nu \epsilon^{\mu\nu\rho\sigma} V_{\rho\sigma} \end{multline} is immediately recognizable as \begin{equation} \mathcal{L}_{\textrm{TGC}}(g_5,\tilde\kappa) / g_{VWW} = - \ii g_5 \mathcal{L}_{\tilde L}(V,W^-,W^+) + \tilde\kappa \mathcal{L}_{\tilde T}(V,W^-,W^+) \end{equation} %%% #procedure decl %%% symbol g1, kappa; %%% vector V, Wp, Wm, k0, kp, km; %%% vector v, V1, V2, V3, k1, k2, k3; %%% index mu, nu; %%% #endprocedure %%% %%% #call decl %%% %%% global L_T(k1,V1,k2,V2,k3,V3) %%% = (V1.k2 - V1.k3) * V2.V3; %%% %%% global L_L(k1,V1,k2,V2,k3,V3) %%% = - V1.k1 * V2.V3; %%% %%% global L_g1(k1,V1,k2,V2,k3,V3) %%% = - V1(mu) * ( (k2(mu)*V2(nu) - k2(nu)*V2(mu)) * V3(nu) %%% - (k3(mu)*V3(nu) - k3(nu)*V3(mu)) * V2(nu) ); %%% %%% global L_kappa(k1,V1,k2,V2,k3,V3) %%% = (k1(mu)*V1(nu) - k1(nu)*V1(mu)) * V2(mu) * V3(nu); %%% %%% print; %%% .sort %%% .store %%% %%% #call decl %%% %%% local lp = L_T(k1,V1,k2,V2,k3,V3) + L_L(k1,V1,k2,V2,k3,V3); %%% local lm = L_T(k1,V1,k2,V2,k3,V3) - L_L(k1,V1,k2,V2,k3,V3); %%% print; %%% .sort %%% id k1.v? = - k2.v - k3.v; %%% print; %%% .sort %%% .store %%% %%% #call decl %%% %%% local [sum(TL)-g1] = - L_g1(k0,V,km,Wm,kp,Wp) %%% + L_T(k0,V,kp,Wp,km,Wm) %%% + (L_T(km,Wm,k0,V,kp,Wp) - L_T(kp,Wp,k0,V,km,Wm)) / 2 %%% - (L_L(km,Wm,k0,V,kp,Wp) - L_L(kp,Wp,k0,V,km,Wm)) / 2; %%% %%% local [sum(TL)-kappa] = - L_kappa(k0,V,km,Wm,kp,Wp) %%% + (L_T(km,Wm,k0,V,kp,Wp) - L_T(kp,Wp,k0,V,km,Wm)) / 2 %%% + (L_L(km,Wm,k0,V,kp,Wp) - L_L(kp,Wp,k0,V,km,Wm)) / 2; %%% %%% local delta = %%% - (g1 * L_g1(k0,V,km,Wm,kp,Wp) + kappa * L_kappa(k0,V,km,Wm,kp,Wp)) %%% + g1 * L_T(k0,V,kp,Wp,km,Wm) %%% + ( g1 + kappa) / 2 * (L_T(km,Wm,k0,V,kp,Wp) - L_T(kp,Wp,k0,V,km,Wm)) %%% + (- g1 + kappa) / 2 * (L_L(km,Wm,k0,V,kp,Wp) - L_L(kp,Wp,k0,V,km,Wm)); %%% %%% print; %%% .sort %%% %%% id k0.v? = - kp.v - km.v; %%% print; %%% .sort %%% .store %%% %%% .end *) (* \begin{table} \begin{center} \renewcommand{\arraystretch}{1.3} \begin{tabular}{|>{\qquad}r<{:}l|}\hline \multicolumn{2}{|l|}{[Dim4_Vector_Vector_Vector_T]: $\mathcal{L}_I=gV_1^\mu V_{2,\nu}\ii\overleftrightarrow{\partial_\mu}V_3^\nu$}\\\hline [F23] & $V_1^\mu(k_2+k_3)\leftarrow\ii\cdot g(k_2^\mu-k_3^\mu)V_{2,\nu}(k_2)V_3^\nu(k_3)$ \\\hline [F32] & $V_1^\mu(k_2+k_3)\leftarrow\ii\cdot g(k_2^\mu-k_3^\mu)V_3^\nu(k_3)V_{2,\nu}(k_2)$ \\\hline [F12] & $V_3^\mu(k_1+k_2)\leftarrow\ii\cdot g(2k_2^\nu+k_1^\nu)V_{1,\nu}(k_1)V_2^\mu(k_2)$ \\\hline [F21] & $V_3^\mu(k_1+k_2)\leftarrow\ii\cdot g(2k_2^\nu+k_1^\nu)V_2^\mu(k_2)V_{1,\nu}(k_1)$ \\\hline [F13] & $V_2^\mu(k_1+k_3)\leftarrow\ii\cdot g(-k_1^\nu-2k_3^\nu)V_1^\nu(k_1)V_3^\mu(k_3)$ \\\hline [F31] & $V_2^\mu(k_1+k_3)\leftarrow\ii\cdot g(-k_1^\nu-2k_3^\nu)V_3^\mu(k_3)V_1^\nu(k_1)$ \\\hline \multicolumn{2}{|l|}{[Dim4_Vector_Vector_Vector_L]: $\mathcal{L}_I=g\ii\partial_\mu V_1^\mu V_{2,\nu}V_3^\nu$}\\\hline [F23] & $V_1^\mu(k_2+k_3)\leftarrow\ii\cdot g(k_2^\mu+k_3^\mu)V_{2,\nu}(k_2)V_3^\nu(k_3)$ \\\hline [F32] & $V_1^\mu(k_2+k_3)\leftarrow\ii\cdot g(k_2^\mu+k_3^\mu)V_3^\nu(k_3)V_{2,\nu}(k_2)$ \\\hline [F12] & $V_3^\mu(k_1+k_2)\leftarrow\ii\cdot g(-k_1^\nu)V_{1,\nu}(k_1)V_2^\mu(k_2)$ \\\hline [F21] & $V_3^\mu(k_1+k_2)\leftarrow\ii\cdot g(-k_1^\nu)V_2^\mu(k_2)V_{1,\nu}(k_1)$ \\\hline [F13] & $V_2^\mu(k_1+k_3)\leftarrow\ii\cdot g(-k_1^\nu)V_1^\nu(k_1)V_3^\mu(k_3)$ \\\hline [F31] & $V_2^\mu(k_1+k_3)\leftarrow\ii\cdot g(-k_1^\nu)V_3^\mu(k_3)V_1^\nu(k_1)$ \\\hline \end{tabular} \end{center} \caption{\label{tab:dim4-TGC} \ldots} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.3} \begin{tabular}{|>{\qquad}r<{:}l|}\hline \multicolumn{2}{|l|}{[Dim4_Vector_Vector_Vector_T5]: $\mathcal{L}_I=gV_{1,\mu} V_{2,\rho}\ii\overleftrightarrow{\partial_\nu} V_{3,\sigma}\epsilon^{\mu\nu\rho\sigma}$}\\\hline [F23] & $V_1^\mu(k_2+k_3)\leftarrow\ii\cdot g\epsilon^{\mu\nu\rho\sigma}(k_{2,\nu}-k_{3,\nu}) V_{2,\rho}(k_2)V_{3,\sigma}(k_3)$ \\\hline [F32] & $V_1^\mu(k_2+k_3)\leftarrow\ii\cdot g\epsilon^{\mu\nu\rho\sigma}(k_{2,\nu}-k_{3,\nu}) V_{3,\sigma}(k_3)V_{2,\rho}(k_2)$ \\\hline [F12] & $V_3^\mu(k_1+k_2)\leftarrow\ii\cdot g\epsilon^{\mu\nu\rho\sigma}(2k_{2,\nu}+k_{1,\nu}) V_{1,\rho}(k_1)V_{2,\sigma}(k_2)$ \\\hline [F21] & $V_3^\mu(k_1+k_2)\leftarrow\ii\cdot g\epsilon^{\mu\nu\rho\sigma}(2k_{2,\nu}+k_{1,\nu}) V_{2,\sigma}(k_2)V_{1,\rho}(k_1)$ \\\hline [F13] & $V_2^\mu(k_1+k_3)\leftarrow\ii\cdot g\epsilon^{\mu\nu\rho\sigma}(-k_{1,\nu}-2k_{3,\nu}) V_{1,\rho}(k_1)V_{3,\sigma}(k_3)$ \\\hline [F31] & $V_2^\mu(k_1+k_3)\leftarrow\ii\cdot g\epsilon^{\mu\nu\rho\sigma}(-k_{1,\nu}-2k_{3,\nu}) V_{3,\sigma}(k_3)V_{1,\rho}(k_1)$ \\\hline \multicolumn{2}{|l|}{[Dim4_Vector_Vector_Vector_L5]: $\mathcal{L}_I=g\ii\partial_\mu V_{1,\nu} V_{2,\nu}V_{3,\sigma}\epsilon^{\mu\nu\rho\sigma}$}\\\hline [F23] & $V_1^\mu(k_2+k_3)\leftarrow\ii\cdot g\epsilon^{\mu\nu\rho\sigma}(k_{2,\nu}+k_{3,\nu}) V_{2,\rho}(k_2)V_{3,\sigma}(k_3)$ \\\hline [F32] & $V_1^\mu(k_2+k_3)\leftarrow\ii\cdot g\epsilon^{\mu\nu\rho\sigma}(k_{2,\nu}+k_{3,\nu}) V_{2,\rho}(k_2)V_{3,\sigma}(k_3)$ \\\hline [F12] & $V_3^\mu(k_1+k_2)\leftarrow\ii\cdot g\epsilon^{\mu\nu\rho\sigma}(-k_{1,\nu}) V_{1,\rho}(k_1)V_{2,\sigma}(k_2)$ \\\hline [F21] & $V_3^\mu(k_1+k_2)\leftarrow\ii\cdot g\epsilon^{\mu\nu\rho\sigma}(-k_{1,\nu}) V_{2,\sigma}(k_2)V_{1,\rho}(k_1)$ \\\hline [F13] & $V_2^\mu(k_1+k_3)\leftarrow\ii\cdot g\epsilon^{\mu\nu\rho\sigma}(-k_{1,\nu}) V_{1,\rho}(k_1)V_{3,\sigma}(k_3)$ \\\hline [F31] & $V_2^\mu(k_1+k_3)\leftarrow\ii\cdot g\epsilon^{\mu\nu\rho\sigma}(-k_{1,\nu}) V_{3,\sigma}(k_3)V_{1,\rho}(k_1)$ \\\hline \end{tabular} \end{center} \caption{\label{tab:dim4-TGC5} \ldots} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.3} \begin{tabular}{|>{\qquad}r<{:}l|}\hline \multicolumn{2}{|l|}{[Dim6_Gauge_Gauge_Gauge]: $\mathcal{L}_I=gF_1^{\mu\nu}F_{2,\nu\rho} F_{3,\hphantom{\rho}\mu}^{\hphantom{3,}\rho}$}\\\hline [_] & $A_1^\mu(k_2+k_3)\leftarrow-\ii\cdot \Lambda^{\mu\rho\sigma}(-k_2-k_3,k_2,k_3) A_{2,\rho} A_{c,\sigma}$\\\hline \end{tabular} \end{center} \caption{\label{tab:dim6-TGC} \ldots} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.3} \begin{tabular}{|>{\qquad}r<{:}l|}\hline \multicolumn{2}{|l|}{[Dim6_Gauge_Gauge_Gauge_5]: $\mathcal{L}_I=g/2\cdot\epsilon^{\mu\nu\lambda\tau} F_{1,\mu\nu}F_{2,\tau\rho} F_{3,\hphantom{\rho}\lambda}^{\hphantom{3,}\rho}$}\\\hline [F23] & $A_1^\mu(k_2+k_3)\leftarrow-\ii\cdot \Lambda_5^{\mu\rho\sigma}(-k_2-k_3,k_2,k_3) A_{2,\rho} A_{3,\sigma}$\\\hline [F32] & $A_1^\mu(k_2+k_3)\leftarrow-\ii\cdot \Lambda_5^{\mu\rho\sigma}(-k_2-k_3,k_2,k_3) A_{3,\sigma} A_{2,\rho}$\\\hline [F12] & $A_3^\mu(k_1+k_2)\leftarrow-\ii\cdot$\\\hline [F21] & $A_3^\mu(k_1+k_2)\leftarrow-\ii\cdot$\\\hline [F13] & $A_2^\mu(k_1+k_3)\leftarrow-\ii\cdot$\\\hline [F31] & $A_2^\mu(k_1+k_3)\leftarrow-\ii\cdot$\\\hline \end{tabular} \end{center} \caption{\label{tab:dim6-TGC5} \ldots} \end{table} *) (* \thocwmodulesection{$\textrm{SU}(2)$ Gauge Bosons} An important special case for table~\ref{tab:dim4-bosons} are the two usual coordinates of~$\textrm{SU}(2)$ \begin{equation} W_\pm = \frac{1}{\sqrt2} \left(W_1 \mp \ii W_2\right) \end{equation} i.\,e. \begin{subequations} \begin{align} W_1 &= \frac{1}{\sqrt2} \left(W_+ + W_-\right) \\ W_2 &= \frac{\ii}{\sqrt2} \left(W_+ - W_-\right) \end{align} \end{subequations} and \begin{equation} W_1^\mu W_2^\nu - W_2^\mu W_1^\nu = \ii\left(W_-^\mu W_+^\nu - W_+^\mu W_-^\nu\right) \end{equation} Thus the symmtry remains after the change of basis: \begin{multline} \epsilon^{abc} W_a^{\mu_1}W_b^{\mu_2}W_c^{\mu_3} = \ii W_-^{\mu_1} (W_+^{\mu_2}W_3^{\mu_3} - W_3^{\mu_2}W_+^{\mu_3}) \\ + \ii W_+^{\mu_1} (W_3^{\mu_2}W_-^{\mu_3} - W_-^{\mu_2}W_3^{\mu_3}) + \ii W_3^{\mu_1} (W_-^{\mu_2}W_+^{\mu_3} - W_+^{\mu_2}W_-^{\mu_3}) \end{multline} *) (* \thocwmodulesection{Quartic Couplings and Auxiliary Fields} Quartic couplings can be replaced by cubic couplings to a non-propagating auxiliary field. The quartic term should get a negative sign so that it the energy is bounded from below for identical fields. In the language of functional integrals \begin{subequations} \label{eq:quartic-aux} \begin{multline} \mathcal{L}_{\phi^4} = - g^2\phi_1\phi_2\phi_3\phi_4 \Longrightarrow \\ \mathcal{L}_{X\phi^2} = X^*X \pm gX\phi_1\phi_2 \pm gX^*\phi_3\phi_4 = (X^* \pm g\phi_1\phi_2)(X \pm g\phi_3\phi_4) - g^2\phi_1\phi_2\phi_3\phi_4 \end{multline} and in the language of Feynman diagrams \begin{equation} \parbox{21mm}{\begin{fmfgraph*}(20,20) \fmfleft{e1,e2} \fmfright{e3,e4} \fmf{plain}{v,e1} \fmf{plain}{v,e2} \fmf{plain}{v,e3} \fmf{plain}{v,e4} \fmfv{d.sh=circle,d.si=dot_size,label=$-\ii g^2$}{v} \end{fmfgraph*}} \qquad\Longrightarrow\qquad \parbox{21mm}{\begin{fmfgraph*}(20,20) \fmfleft{e1,e2} \fmfright{e3,e4} \fmf{plain}{v12,e1} \fmf{plain}{v12,e2} \fmf{plain}{v34,e3} \fmf{plain}{v34,e4} \fmf{dashes,label=$+\ii$}{v12,v34} \fmfv{d.sh=circle,d.si=dot_size,label=$\pm\ii g$}{v12} \fmfv{d.sh=circle,d.si=dot_size,label=$\pm\ii g$}{v34} \end{fmfgraph*}} \end{equation} \end{subequations} The other choice of signs \begin{equation} \mathcal{L}_{X\phi^2}' = - X^*X \pm gX\phi_1\phi_2 \mp gX^*\phi_3\phi_4 = - (X^* \pm g\phi_1\phi_2)(X \mp g\phi_3\phi_4) - g^2\phi_1\phi_2\phi_3\phi_4 \end{equation} can not be extended easily to identical particles and is therefore not used. For identical particles we have \begin{multline} \mathcal{L}_{\phi^4} = - \frac{g^2}{4!}\phi^4 \Longrightarrow \\ \mathcal{L}_{X\phi^2} = \frac{1}{2}X^2 \pm \frac{g}{2}X\phi^2 \pm \frac{g}{2}X\phi^2 = \frac{1}{2}\left(X \pm \frac{g}{2}\phi^2\right) \left(X \pm \frac{g}{2}\phi^2\right) - \frac{g^2}{4!}\phi^4 \end{multline} \begin{dubious} Explain the factor~$1/3$ in the functional setting and its relation to the three diagrams in the graphical setting? \end{dubious} \thocwmodulesubsection{Quartic Gauge Couplings} \begin{figure} \begin{subequations} \label{eq:Feynman-QCD} \begin{align} \parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,24) \threeexternal{k,,\mu,,a}{p}{p'} \fmf{gluon}{v,e1} \fmf{fermion}{e2,v,e3} \fmfdot{v} \end{fmfgraph*}}} \,&= \begin{split} \mbox{} + & \ii g\gamma_\mu T_a \end{split} \\ \label{eq:TGV} \parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,24) \threeexternal{1}{2}{3} \fmf{gluon}{v,e1} \fmf{gluon}{v,e2} \fmf{gluon}{v,e3} \threeoutgoing \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} \\ \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{align} \end{subequations} \caption{\label{fig:gauge-feynman-rules} Gauge couplings. See~(\ref{eq:C123}) for the definition of the antisymmetric tensor $C^{\mu_1\mu_2\mu_3}(k_1,k_2,k_3)$.} \end{figure} \begin{figure} \begin{equation} \label{eq:Feynman-QCD'} \parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,24) \fmfsurround{d1,e1,d2,e2,d3,e3,d4,e4} \fmf{gluon}{v12,e1} \fmf{gluon}{v12,e2} \fmf{gluon}{v34,e3} \fmf{gluon}{v34,e4} \fmf{dashes}{v12,v34} \fmflabel{1}{e1} \fmflabel{2}{e2} \fmflabel{3}{e3} \fmflabel{4}{e4} \fmfdot{v12,v34} \fmffreeze \fmf{warrow_right}{v12,e1} \fmf{warrow_right}{v12,e2} \fmf{warrow_right}{v34,e3} \fmf{warrow_right}{v34,e4} \end{fmfgraph*}}} \,= \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}) \end{equation} \caption{\label{fig:gauge-feynman-rules'} Gauge couplings.} \end{figure} The three crossed versions of figure~\ref{fig:gauge-feynman-rules'} reproduces the quartic coupling in figure~\ref{fig:gauge-feynman-rules}, because \begin{multline} - \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}) \\ = (\ii g f_{a_1a_2b} T_{\mu_1\mu_2,\nu_1\nu_2}) \left(\frac{\ii g^{\nu_1\nu_3} g^{\nu_2\nu_4}}{2}\right) (\ii g f_{a_3a_4b} T_{\mu_3\mu_4,\nu_3\nu_4}) \end{multline} with $T_{\mu_1\mu_2,\mu_3\mu_4} = g_{\mu_1\mu_3}g_{\mu_4\mu_2}-g_{\mu_1\mu_4}g_{\mu_2\mu_3}$. *) (* \thocwmodulesection{Gravitinos and supersymmetric currents} In supergravity theories there is a fermionic partner of the graviton, the gravitino. Therefore we have introduced the Lorentz type [Vectorspinor]. *) (* \begin{table} \begin{center} \renewcommand{\arraystretch}{1.4} \begin{tabular}{|>{\qquad}r<{:}l|r<{:}l|}\hline \multicolumn{4}{|l|}{[GBG (Fermbar, MOM, Ferm)]: $\bar\psi_1(\ii\fmslash{\partial}\pm m)\phi\psi_2$}\\\hline [F12] & $\psi_2\leftarrow-(\fmslash{k}\mp m)\psi_1S$ & [F21] & $\psi_2\leftarrow-S(\fmslash{k}\mp m)\psi_1$ \\\hline [F13] & $S\leftarrow \psi^T_1 {\rm C}(\fmslash{k}\pm m)\psi_2$ & [F31] & $S\leftarrow \psi^T_2 {\rm C}(-(\fmslash{k}\mp m)\psi_1)$ \\\hline [F23] & $\psi_1\leftarrow S(\fmslash{k}\pm m)\psi_2$ & [F32] & $\psi_1\leftarrow(\fmslash{k}\pm m)\psi_2 S$ \\\hline \multicolumn{4}{|l|}{[GBG (Fermbar, MOM5, Ferm)]: $\bar\psi_1(\ii\fmslash{\partial}\pm m)\phi\gamma^5\psi_2$}\\\hline [F12] & $\psi_2\leftarrow(\fmslash{k}\pm m)\gamma^5\psi_1P$ & [F21] & $\psi_2\leftarrow P(\fmslash{k}\pm m)\gamma^5\psi_1$ \\\hline [F13] & $P\leftarrow \psi^T_1 {\rm C}(\fmslash{k}\pm m)\gamma^5\psi_2$ & [F31] & $P\leftarrow \psi^T_2 {\rm C}(\fmslash{k}\pm m)\gamma^5\psi_1$ \\\hline [F23] & $\psi_1\leftarrow P(\fmslash{k}\pm m)\gamma^5\psi_2$ & [F32] & $\psi_1\leftarrow(\fmslash{k}\pm m)\gamma^5\psi_2 P$ \\\hline \multicolumn{4}{|l|}{[GBG (Fermbar, MOML, Ferm)]: $\bar\psi_1 (\ii\fmslash{\partial}\pm m)\phi(1-\gamma^5)\psi_2$}\\\hline [F12] & $\psi_2\leftarrow-(1-\gamma^5)(\fmslash{k}\mp m)\psi_1\phi$ & [F21] & $\psi_2\leftarrow-\phi(1-\gamma^5)(\fmslash{k}\mp m)\psi_1$ \\\hline [F13] & $\phi\leftarrow \psi^T_1 {\rm C}(\fmslash{k}\pm m)(1-\gamma^5)\psi_2$ & [F31] & $\phi\leftarrow \psi^T_2 {\rm C}(1-\gamma^5)(-(\fmslash{k}\mp m)\psi_1)$ \\\hline [F23] & $\psi_1\leftarrow\phi(\fmslash{k}\pm m)(1-\gamma^5)\psi_2$ & [F32] & $\psi_1\leftarrow(\fmslash{k}\pm m)(1-\gamma^5)\psi_2 \phi$ \\\hline \multicolumn{4}{|l|}{[GBG (Fermbar, LMOM, Ferm)]: $\bar\psi_1 \phi(1-\gamma^5)(\ii\fmslash{\partial}\pm m)\psi_2$}\\\hline [F12] & $\psi_2\leftarrow-(\fmslash{k}\mp m)\psi_1(1-\gamma^5)\phi$ & [F21] & $\psi_2\leftarrow-\phi(\fmslash{k}\mp m)(1-\gamma^5)\psi_1$ \\\hline [F13] & $\phi\leftarrow \psi^T_1 {\rm C}(1-\gamma^5)(\fmslash{k}\pm m)\psi_2$ & [F31] & $\phi\leftarrow \psi^T_2 {\rm C}(-(\fmslash{k}\mp m)(1-\gamma^5)\psi_1)$ \\\hline [F23] & $\psi_1\leftarrow\phi(1-\gamma^5)(\fmslash{k}\pm m)\psi_2$ & [F32] & $\psi_1\leftarrow(1-\gamma^5)(\fmslash{k}\pm m)\psi_2 \phi$ \\\hline \multicolumn{4}{|l|}{[GBG (Fermbar, VMOM, Ferm)]: $\bar\psi_1 \ii\fmslash{\partial}_\alpha V_\beta \lbrack \gamma^\alpha, \gamma^\beta \rbrack \psi_2$}\\\hline [F12] & $\psi_2\leftarrow-\lbrack\fmslash{k},\gamma^\alpha\rbrack\psi_1 V_\alpha$ & [F21] & $\psi_2\leftarrow-\lbrack\fmslash{k},\fmslash{V}\rbrack\psi_1$ \\\hline [F13] & $V_\alpha\leftarrow \psi^T_1 {\rm C}\lbrack\fmslash{k},\gamma_\alpha\rbrack\psi_2$ & [F31] & $V_\alpha\leftarrow \psi^T_2 {\rm C}(-\lbrack\fmslash{k}, \gamma_\alpha\rbrack\psi_1)$ \\\hline [F23] & $\psi_1\leftarrow\rbrack\fmslash{k},\fmslash{V}\rbrack\psi_2$ & [F32] & $\psi_1\leftarrow\lbrack\fmslash{k},\gamma^\alpha\rbrack\psi_2 V_\alpha$ \\\hline \end{tabular} \end{center} \caption{\label{tab:dim4-fermions-MOM} Combined dimension-4 trilinear fermionic couplings including a momentum. $Ferm$ stands for $Psi$ and $Chi$. The case of $MOMR$ is identical to $MOML$ if one substitutes $1+\gamma^5$ for $1-\gamma^5$, as well as for $LMOM$ and $RMOM$. The mass term forces us to keep the chiral projector always on the left after "inverting the line" for $MOML$ while on the right for $LMOM$.} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.4} \begin{tabular}{|>{\qquad}r<{:}l|r<{:}l|}\hline \multicolumn{2}{|l|}{[GBBG (Fermbar, S2LR, Ferm)]: $\bar\psi_1 S_1 S_2 (g_L P_L + g_R P_R) \psi_2$}\\\hline [F123] [F213] [F132] [F231] [F312] [F321] & $\psi_2\leftarrow S_1 S_2 (g_R P_L + g_L P_R) \psi_1$ \\ \hline [F423] [F243] [F432] [F234] [F342] [F324] & $\psi_1 \leftarrow S_1 S_2 (g_L P_L + g_R P_R) \psi_2$ \\ \hline [F134] [F143] [F314] & $S_1 \leftarrow \psi^T_1 C S_2 (g_L P_L + g_R P_R) \psi_2$ \\ \hline [F124] [F142] [F214] & $S_2 \leftarrow \psi^T_1 C S_1 (g_L P_L + g_R P_R) \psi_2$ \\ \hline [F413] [F431] [F341] & $S_1 \leftarrow \psi^T_2 C S_2 (g_R P_L + g_L P_R) \psi_1$ \\ \hline [F412] [F421] [F241] & $S_2 \leftarrow \psi^T_2 C S_1 (g_R P_L + g_L P_R) \psi_1$ \\ \hline \multicolumn{2}{|l|}{[GBBG (Fermbar, S2, Ferm)]: $\bar\psi_1 S_1 S_2 \gamma^5 \psi_2$}\\\hline [F123] [F213] [F132] [F231] [F312] [F321] & $\psi_2\leftarrow S_1 S_2 \gamma^5 \psi_1$ \\ \hline [F423] [F243] [F432] [F234] [F342] [F324] & $\psi_1 \leftarrow S_1 S_2 \gamma^5 \psi_2$ \\ \hline [F134] [F143] [F314] & $S_1 \leftarrow \psi^T_1 C S_2 \gamma^5 \psi_2$ \\ \hline [F124] [F142] [F214] & $S_2 \leftarrow \psi^T_1 C S_1 \gamma^5 \psi_2$ \\ \hline [F413] [F431] [F341] & $S_1 \leftarrow \psi^T_2 C S_2 \gamma^5 \psi_1$ \\ \hline [F412] [F421] [F241] & $S_2 \leftarrow \psi^T_2 C S_1 \gamma^5 \psi_1$ \\ \hline \multicolumn{2}{|l|}{[GBBG (Fermbar, V2, Ferm)]: $\bar\psi_1 \lbrack \fmslash{V}_1 , \fmslash{V}_2 \rbrack \psi_2$}\\\hline [F123] [F213] [F132] [F231] [F312] [F321] & $\psi_2\leftarrow - \lbrack \fmslash{V}_1 , \fmslash{V}_2 \rbrack \psi_1$ \\ \hline [F423] [F243] [F432] [F234] [F342] [F324] & $\psi_1 \leftarrow \lbrack \fmslash{V}_1 , \fmslash{V}_2 \rbrack \psi_2$ \\ \hline [F134] [F143] [F314] & $V_{1\:\alpha} \leftarrow \psi^T_1 C \lbrack \gamma_\alpha , \fmslash{V}_2 \rbrack \psi_2$ \\ \hline [F124] [F142] [F214] & $V_{2\:\alpha} \leftarrow \psi^T_1 C (-\lbrack \gamma_\alpha , \fmslash{V}_1 \rbrack) \psi_2$ \\ \hline [F413] [F431] [F341] & $V_{1\:\alpha} \leftarrow \psi^T_2 C (-\lbrack \gamma_\alpha , \fmslash{V}_2 \rbrack) \psi_1$ \\ \hline [F412] [F421] [F241] & $V_{2\:\alpha} \leftarrow \psi^T_2 C \lbrack \gamma_\alpha , \fmslash{V}_1 \rbrack \psi_1$ \\ \hline \end{tabular} \end{center} \caption{\label{tab:dim5-mom2} Vertices with two fermions ($Ferm$ stands for $Psi$ and $Chi$, but not for $Grav$) and two bosons (two scalars, scalar/vector, two vectors) for the BRST transformations. Part I} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.4} \begin{tabular}{|>{\qquad}r<{:}l|r<{:}l|}\hline \multicolumn{2}{|l|}{[GBBG (Fermbar, SV, Ferm)]: $\bar\psi_1 \fmslash{V} S \psi_2$}\\\hline [F123] [F213] [F132] [F231] [F312] [F321] & $\psi_2\leftarrow - \fmslash{V} S \psi_1$ \\ \hline [F423] [F243] [F432] [F234] [F342] [F324] & $\psi_1 \leftarrow \fmslash{V} S \psi_2$ \\ \hline [F134] [F143] [F314] & $V_\alpha \leftarrow \psi^T_1 C \gamma_\alpha S \psi_2$ \\ \hline [F124] [F142] [F214] & $S \leftarrow \psi^T_1 C \fmslash{V} \psi_2$ \\ \hline [F413] [F431] [F341] & $V_\alpha \leftarrow \psi^T_2 C (- \gamma_\alpha S \psi_1)$ \\ \hline [F412] [F421] [F241] & $S \leftarrow \psi^T_2 C (- \fmslash{V} \psi_1)$ \\ \hline \multicolumn{2}{|l|}{[GBBG (Fermbar, PV, Ferm)]: $\bar\psi_1 \fmslash{V} \gamma^5 P \psi_2$}\\\hline [F123] [F213] [F132] [F231] [F312] [F321] & $\psi_2\leftarrow \fmslash{V} \gamma^5 P \psi_1$ \\ \hline [F423] [F243] [F432] [F234] [F342] [F324] & $\psi_1 \leftarrow \fmslash{V} \gamma^5 P \psi_2$ \\ \hline [F134] [F143] [F314] & $V_\alpha \leftarrow \psi^T_1 C \gamma_\alpha \gamma^5 P \psi_2$ \\ \hline [F124] [F142] [F214] & $P \leftarrow \psi^T_1 C \fmslash{V} \gamma^5 \psi_2$ \\ \hline [F413] [F431] [F341] & $V_\alpha \leftarrow \psi^T_2 C \gamma_\alpha \gamma^5 P \psi_1$ \\ \hline [F412] [F421] [F241] & $P \leftarrow \psi^T_2 C \fmslash{V} \gamma^5 \psi_1$ \\ \hline \multicolumn{2}{|l|}{[GBBG (Fermbar, S(L/R)V, Ferm)]: $\bar\psi_1 \fmslash{V} (1 \mp\gamma^5) \phi \psi_2$}\\\hline [F123] [F213] [F132] [F231] [F312] [F321] & $\psi_2\leftarrow - \fmslash{V} (1\pm\gamma^5) \phi \psi_1$ \\ \hline [F423] [F243] [F432] [F234] [F342] [F324] & $\psi_1 \leftarrow \fmslash{V} (1\mp\gamma^5) \phi \psi_2$ \\ \hline [F134] [F143] [F314] & $V_\alpha \leftarrow \psi^T_1 C \gamma_\alpha (1\mp\gamma^5) \phi \psi_2$ \\ \hline [F124] [F142] [F214] & $\phi \leftarrow \psi^T_1 C \fmslash{V} (1\mp\gamma^5) \psi_2$ \\ \hline [F413] [F431] [F341] & $V_\alpha \leftarrow \psi^T_2 C \gamma_\alpha (-(1\pm\gamma^5) \phi \psi_1)$ \\ \hline [F412] [F421] [F241] & $\phi \leftarrow \psi^T_2 C \fmslash{V} (-(1\pm\gamma^5) \psi_1)$ \\ \hline \end{tabular} \end{center} \caption{\label{tab:dim5-mom2} Vertices with two fermions ($Ferm$ stands for $Psi$ and $Chi$, but not for $Grav$) and two bosons (two scalars, scalar/vector, two vectors) for the BRST transformations. Part II} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.4} \begin{tabular}{|>{\qquad}r<{:}l|r<{:}l|}\hline \multicolumn{4}{|l|}{[GBG (Gravbar, POT, Psi)]: $\bar\psi_\mu S \gamma^\mu \psi$}\\\hline [F12] & $\psi\leftarrow - \gamma^\mu \psi_\mu S$ & [F21] & $\psi\leftarrow - S\gamma^\mu \psi_\mu$ \\\hline [F13] & $S\leftarrow \psi^T_\mu {\rm C} \gamma^\mu \psi$ & [F31] & $S\leftarrow \psi^T{\rm C} (-\gamma^\mu)\psi_\mu$ \\\hline [F23] & $\psi_\mu\leftarrow S\gamma_\mu\psi$ & [F32] & $\psi_\mu\leftarrow \gamma_\mu \psi S$ \\\hline \multicolumn{4}{|l|}{[GBG (Gravbar, S, Psi)]: $\bar\psi_\mu \fmslash{k}_S S \gamma^\mu \psi$}\\\hline [F12] & $\psi\leftarrow \gamma^\mu \fmslash{k}_S \psi_\mu S$ & [F21] & $\psi\leftarrow S\gamma^\mu \fmslash{k}_S \psi_\mu$ \\\hline [F13] & $S\leftarrow \psi^T_\mu {\rm C} \fmslash{k}_S \gamma^\mu \psi$ & [F31] & $S\leftarrow \psi^T{\rm C}\gamma^\mu\fmslash{k}_S \psi_\mu$ \\\hline [F23] & $\psi_\mu\leftarrow S\fmslash{k}_S\gamma_\mu\psi$ & [F32] & $\psi_\mu\leftarrow \fmslash{k}_S \gamma_\mu \psi S$ \\\hline \multicolumn{4}{|l|}{[GBG (Gravbar, P, Psi)]: $\bar\psi_\mu \fmslash{k}_P P \gamma^\mu \gamma_5 \psi$}\\\hline [F12] & $\psi\leftarrow \gamma^\mu\fmslash{k}_P\gamma_5\psi_\mu P$ & [F21] & $\psi\leftarrow P\gamma^\mu\fmslash{k}_P\gamma_5\psi_\mu$ \\\hline [F13] & $P\leftarrow \psi^T_\mu {\rm C}\fmslash{k}_P\gamma^\mu\gamma_5\psi$ & [F31] & $P\leftarrow \psi^T {\rm C}\gamma^\mu\fmslash{k}_P\gamma_5\psi_\mu$ \\\hline [F23] & $\psi_\mu\leftarrow P\fmslash{k}_P \gamma_\mu \gamma_5 \psi$ & [F32] & $\psi_\mu\leftarrow \fmslash{k}_P \gamma_\mu \gamma_5 \psi P$ \\\hline \multicolumn{4}{|l|}{[GBG (Gravbar, V, Psi)]: $\bar\psi_\mu\lbrack\fmslash{k}_V,\fmslash{V}\rbrack\gamma^\mu\gamma^5\psi$}\\\hline [F12] & $\psi\leftarrow \gamma^5\gamma^\mu \lbrack \fmslash{k}_V , \gamma^\alpha \rbrack \psi_\mu V_\alpha$ & [F21] & $\psi\leftarrow \gamma^5\gamma^\mu \lbrack \fmslash{k}_V , \fmslash{V} \rbrack\psi_\mu$ \\\hline [F13] & $V_{\mu}\leftarrow \psi^T_\rho {\rm C} \lbrack \fmslash{k}_V , \gamma_\mu \rbrack \gamma^\rho \gamma^5 \psi$ & [F31] & $V_{\mu}\leftarrow \psi^T {\rm C} \gamma^5 \gamma^{\rho} \lbrack \fmslash{k}_V , \gamma_\mu \rbrack \psi_\rho$ \\\hline [F23] & $\psi_\mu\leftarrow\lbrack \fmslash{k}_V , \fmslash{V} \rbrack \gamma_\mu \gamma^5 \psi $ & [F32] & $\psi_\mu\leftarrow\lbrack \fmslash{k}_V , \gamma^\alpha \rbrack \gamma_\mu \gamma^5 \psi V_\alpha$ \\\hline \end{tabular} \end{center} \caption{\label{tab:dim5-fermions-gravdirac} Dimension-5 trilinear couplings including one Dirac, one Gravitino fermion and one additional particle.The option [POT] is for the coupling of the supersymmetric current to the derivative of the quadratic terms in the superpotential.} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.4} \begin{tabular}{|>{\qquad}r<{:}l|r<{:}l|}\hline \multicolumn{4}{|l|}{[GBG (Psibar, POT, Grav)]: $\bar\psi \gamma^\mu S \psi_\mu$}\\\hline [F12] & $\psi_\mu\leftarrow - \gamma_\mu \psi S$ & [F21] & $\psi_\mu\leftarrow - S \gamma_\mu\psi$ \\\hline [F13] & $S\leftarrow \psi^T{\rm C}\gamma^\mu\psi_\mu$ & [F31] & $S\leftarrow \psi^T_\mu {\rm C} (-\gamma^\mu) \psi$ \\\hline [F23] & $\psi\leftarrow S\gamma^\mu\psi_\mu$ & [F32] & $\psi\leftarrow \gamma^\mu\psi_\mu S$ \\\hline \multicolumn{4}{|l|}{[GBG (Psibar, S, Grav)]: $\bar\psi \gamma^\mu \fmslash{k}_S S \psi_\mu$}\\\hline [F12] & $\psi_\mu\leftarrow \fmslash{k}_S \gamma_\mu \psi S$ & [F21] & $\psi_\mu\leftarrow S \fmslash{k}_S \gamma_\mu\psi$ \\\hline [F13] & $S\leftarrow \psi^T{\rm C}\gamma^\mu\fmslash{k}_S \psi_\mu$ & [F31] & $S\leftarrow \psi^T_\mu {\rm C} \fmslash{k}_S \gamma^\mu \psi$ \\\hline [F23] & $\psi\leftarrow S\gamma^\mu\fmslash{k}_S\psi_\mu$ & [F32] & $\psi\leftarrow \gamma^\mu\fmslash{k}_S\psi_\mu S$ \\\hline \multicolumn{4}{|l|}{[GBG (Psibar, P, Grav)]: $\bar\psi \gamma^\mu\gamma^5 P\fmslash{k}_P \psi_\mu$}\\\hline [F12] & $\psi_\mu\leftarrow -\fmslash{k}_P \gamma_\mu \gamma^5 \psi P$ & [F21] & $\psi_\mu\leftarrow -P\fmslash{k}_P \gamma_\mu \gamma^5 \psi$ \\\hline [F13] & $P\leftarrow \psi^T {\rm C}\gamma^\mu\gamma^5\fmslash{k}_P\psi_\mu$ & [F31] & $P\leftarrow -\psi^T_\mu {\rm C}\fmslash{k}_P\gamma^\mu\gamma_5\psi$ \\\hline [F23] & $\psi\leftarrow P \gamma^\mu\gamma^5\fmslash{k}_P\psi_\mu$ & [F32] & $\psi\leftarrow \gamma^\mu\gamma^5\fmslash{k}_P\psi_\mu P$ \\\hline \multicolumn{4}{|l|}{[GBG (Psibar, V, Grav)]: $\bar\psi\gamma^5\gamma^\mu\lbrack\fmslash{k}_V,\fmslash{V}\rbrack\psi_\mu$}\\\hline [F12] & $\psi_\mu\leftarrow \lbrack \fmslash{k}_V , \gamma^\alpha \rbrack \gamma_\mu \gamma^5 \psi V_\alpha$ & [F21] & $\psi_\mu\leftarrow \lbrack \fmslash{k}_V , \fmslash{V} \rbrack \gamma_\mu \gamma^5 \psi$ \\\hline [F13] & $V_{\mu}\leftarrow \psi^T {\rm C} \gamma^5 \gamma^\rho \lbrack \fmslash{k}_V , \gamma_\mu \rbrack \psi_\rho$ & [F31] & $V_{\mu}\leftarrow \psi^T_\rho {\rm C} \lbrack \fmslash{k}_V , \gamma_\mu \rbrack \gamma^\rho \gamma^5 \psi$ \\\hline [F23] & $\psi\leftarrow\gamma^5\gamma^\mu\lbrack \fmslash{k}_V , \fmslash{V} \rbrack\psi_\mu$ & [F32] & $\psi\leftarrow\gamma^5\gamma^\mu\lbrack \fmslash{k}_V , \gamma^\alpha \rbrack\psi_\mu V_\alpha$ \\\hline \end{tabular} \end{center} \caption{\label{tab:dim5-fermions-diracgrav} Dimension-5 trilinear couplings including one conjugated Dirac, one Gravitino fermion and one additional particle.} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.4} \begin{tabular}{|>{\qquad}r<{:}l|r<{:}l|}\hline \multicolumn{4}{|l|}{[GBG (Gravbar, POT, Chi)]: $\bar\psi_\mu S \gamma^\mu \chi$}\\\hline [F12] & $\chi\leftarrow - \gamma^\mu \psi_\mu S$ & [F21] & $\chi\leftarrow - S\gamma^\mu \psi_\mu$ \\\hline [F13] & $S\leftarrow \psi^T_\mu {\rm C} \gamma^\mu \chi$ & [F31] & $S\leftarrow \chi^T{\rm C} (-\gamma^\mu)\psi_\mu$ \\\hline [F23] & $\psi_\mu\leftarrow S\gamma_\mu\chi$ & [F32] & $\psi_\mu\leftarrow \gamma_\mu \chi S$ \\\hline \multicolumn{4}{|l|}{[GBG (Gravbar, S, Chi)]: $\bar\psi_\mu \fmslash{k}_S S \gamma^\mu \chi$}\\\hline [F12] & $\chi\leftarrow \gamma^\mu \fmslash{k}_S \psi_\mu S$ & [F21] & $\chi\leftarrow S\gamma^\mu \fmslash{k}_S \psi_\mu$ \\\hline [F13] & $S\leftarrow \psi^T_\mu {\rm C} \fmslash{k}_S \gamma^\mu \chi$ & [F31] & $S\leftarrow \chi^T{\rm C}\gamma^\mu\fmslash{k}_S \psi_\mu$ \\\hline [F23] & $\psi_\mu\leftarrow S\fmslash{k}_S\gamma_\mu\chi$ & [F32] & $\psi_\mu\leftarrow \fmslash{k}_S \gamma_\mu \chi S$ \\\hline \multicolumn{4}{|l|}{[GBG (Gravbar, P, Chi)]: $\bar\psi_\mu \fmslash{k}_P P \gamma^\mu \gamma_5 \chi$}\\\hline [F12] & $\chi\leftarrow \gamma^\mu\fmslash{k}_P\gamma_5\psi_\mu P$ & [F21] & $\chi\leftarrow P\gamma^\mu\fmslash{k}_P\gamma_5\psi_\mu$ \\\hline [F13] & $P\leftarrow \psi^T_\mu {\rm C}\fmslash{k}_P\gamma^\mu\gamma_5\chi$ & [F31] & $P\leftarrow \chi^T {\rm C}\gamma^\mu\fmslash{k}_P\gamma_5\psi_\mu$ \\\hline [F23] & $\psi_\mu\leftarrow P\fmslash{k}_P \gamma_\mu \gamma_5 \chi$ & [F32] & $\psi_\mu\leftarrow \fmslash{k}_P \gamma_\mu \gamma_5 \chi P$ \\\hline \multicolumn{4}{|l|}{[GBG (Gravbar, V, Chi)]: $\bar\psi_\mu\lbrack\fmslash{k}_V,\fmslash{V}\rbrack\gamma^\mu\gamma^5\chi$}\\\hline [F12] & $\chi\leftarrow \gamma^5\gamma^\mu \lbrack \fmslash{k}_V , \gamma^\alpha \rbrack \psi_\mu V_\alpha$ & [F21] & $\chi\leftarrow \gamma^5\gamma^\mu \lbrack \fmslash{k}_V , \fmslash{V} \rbrack\psi_\mu$ \\\hline [F13] & $V_{\mu}\leftarrow \psi^T_\rho {\rm C} \lbrack \fmslash{k}_V , \gamma_\mu \rbrack \gamma^\rho \gamma^5 \chi$ & [F31] & $V_{\mu}\leftarrow \chi^T {\rm C} \gamma^5 \gamma^{\rho} \lbrack \fmslash{k}_V , \gamma_\mu \rbrack \psi_\rho$ \\\hline [F23] & $\psi_\mu\leftarrow\lbrack \fmslash{k}_V , \fmslash{V} \rbrack \gamma_\mu \gamma^5 \chi $ & [F32] & $\psi_\mu\leftarrow\lbrack \fmslash{k}_V , \gamma^\alpha \rbrack \gamma_\mu \gamma^5 \chi V_\alpha$ \\\hline \end{tabular} \end{center} \caption{\label{tab:dim5-fermions-gravmajo} Dimension-5 trilinear couplings including one Majorana, one Gravitino fermion and one additional particle. The table is essentially the same as the one with the Dirac fermion and only written for the sake of completeness.} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.4} \begin{tabular}{|>{\qquad}r<{:}l|r<{:}l|}\hline \multicolumn{4}{|l|}{[GBG (Chibar, POT, Grav)]: $\bar\chi \gamma^\mu S \psi_\mu$}\\\hline [F12] & $\psi_\mu\leftarrow - \gamma_\mu \chi S$ & [F21] & $\psi_\mu\leftarrow - S \gamma_\mu\chi$ \\\hline [F13] & $S\leftarrow \chi^T{\rm C}\gamma^\mu\psi_\mu$ & [F31] & $S\leftarrow \psi^T_\mu {\rm C} (-\gamma^\mu) \chi$ \\\hline [F23] & $\chi\leftarrow S\gamma^\mu\psi_\mu$ & [F32] & $\chi\leftarrow \gamma^\mu\psi_\mu S$ \\\hline \multicolumn{4}{|l|}{[GBG (Chibar, S, Grav)]: $\bar\chi \gamma^\mu \fmslash{k}_S S \psi_\mu$}\\\hline [F12] & $\psi_\mu\leftarrow \fmslash{k}_S \gamma_\mu \chi S$ & [F21] & $\psi_\mu\leftarrow S \fmslash{k}_S \gamma_\mu\chi$ \\\hline [F13] & $S\leftarrow \chi^T{\rm C}\gamma^\mu\fmslash{k}_S \psi_\mu$ & [F31] & $S\leftarrow \psi^T_\mu {\rm C} \fmslash{k}_S \gamma^\mu \chi$ \\\hline [F23] & $\chi\leftarrow S\gamma^\mu\fmslash{k}_S\psi_\mu$ & [F32] & $\chi\leftarrow \gamma^\mu\fmslash{k}_S\psi_\mu S$ \\\hline \multicolumn{4}{|l|}{[GBG (Chibar, P, Grav)]: $\bar\chi \gamma^\mu\gamma^5 P\fmslash{k}_P \psi_\mu$}\\\hline [F12] & $\psi_\mu\leftarrow -\fmslash{k}_P \gamma_\mu \gamma^5 \chi P$ & [F21] & $\psi_\mu\leftarrow -P\fmslash{k}_P \gamma_\mu \gamma^5 \chi$ \\\hline [F13] & $P\leftarrow \chi^T {\rm C}\gamma^\mu\gamma^5\fmslash{k}_P\psi_\mu$ & [F31] & $P\leftarrow -\psi^T_\mu {\rm C}\fmslash{k}_P\gamma^\mu\gamma_5\chi$ \\\hline [F23] & $\chi\leftarrow P \gamma^\mu\gamma^5\fmslash{k}_P\psi_\mu$ & [F32] & $\chi\leftarrow \gamma^\mu\gamma^5\fmslash{k}_P\psi_\mu P$ \\\hline \multicolumn{4}{|l|}{[GBG (Chibar, V, Grav)]: $\bar\chi\gamma^5\gamma^\mu\lbrack\fmslash{k}_V,\fmslash{V}\rbrack\psi_\mu$}\\\hline [F12] & $\psi_\mu\leftarrow \lbrack \fmslash{k}_V , \gamma^\alpha \rbrack \gamma_\mu \gamma^5 \chi V_\alpha$ & [F21] & $\psi_\mu\leftarrow \lbrack \fmslash{k}_V , \fmslash{V} \rbrack \gamma_\mu \gamma^5 \chi$ \\\hline [F13] & $V_{\mu}\leftarrow \chi^T {\rm C} \gamma^5 \gamma^\rho \lbrack \fmslash{k}_V , \gamma_\mu \rbrack \psi_\rho$ & [F31] & $V_{\mu}\leftarrow \psi^T_\rho {\rm C} \lbrack \fmslash{k}_V , \gamma_\mu \rbrack \gamma^\rho \gamma^5 \chi$ \\\hline [F23] & $\chi\leftarrow\gamma^5\gamma^\mu\lbrack \fmslash{k}_V , \fmslash{V} \rbrack\psi_\mu$ & [F32] & $\chi\leftarrow\gamma^5\gamma^\mu\lbrack \fmslash{k}_V , \gamma^\alpha \rbrack\psi_\mu V_\alpha$ \\\hline \end{tabular} \end{center} \caption{\label{tab:dim5-fermions-majograv} Dimension-5 trilinear couplings including one conjugated Majorana, one Gravitino fermion and one additional particle. This table is not only the same as the one with the conjugated Dirac fermion but also the same part of the Lagrangian density as the one with the Majorana particle on the right of the gravitino.} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.4} \begin{tabular}{|>{\qquad}r<{:}l|r<{:}l|}\hline \multicolumn{2}{|l|}{[GBBG (Gravbar, S2, Psi)]: $\bar\psi_\mu S_1 S_2 \gamma^\mu \psi$}\\\hline [F123] [F213] [F132] [F231] [F312] [F321] & $\psi\leftarrow - \gamma^\mu S_1 S_2 \psi_\mu$ \\ \hline [F423] [F243] [F432] [F234] [F342] [F324] & $\psi_\mu \leftarrow \gamma_\mu S_1 S_2 \psi$ \\ \hline [F134] [F143] [F314] & $S_1 \leftarrow \psi^T_\mu C S_2 \gamma^\mu \psi$ \\ \hline [F124] [F142] [F214] & $S_2 \leftarrow \psi^T_\mu C S_1 \gamma^\mu \psi$ \\ \hline [F413] [F431] [F341] & $S_1 \leftarrow - \psi^T C S_2 \gamma^\mu \psi_\mu$ \\ \hline [F412] [F421] [F241] & $S_2 \leftarrow - \psi^T C S_1 \gamma^\mu \psi_\mu$ \\ \hline \multicolumn{2}{|l|}{[GBBG (Gravbar, SV, Psi)]: $\bar\psi_\mu S \fmslash{V} \gamma^\mu \gamma^5 \psi$}\\\hline [F123] [F213] [F132] [F231] [F312] [F321] & $\psi\leftarrow \gamma^5 \gamma^\mu S \fmslash{V} \psi_\mu$ \\ \hline [F423] [F243] [F432] [F234] [F342] [F324] & $\psi_\mu \leftarrow \fmslash{V} S \gamma_\mu \gamma^5 \psi$ \\ \hline [F134] [F143] [F314] & $S \leftarrow \psi^T_\mu C \fmslash{V} \gamma^\mu \gamma^5 \psi$ \\ \hline [F124] [F142] [F214] & $V_\mu \leftarrow \psi^T_\rho C S \gamma_\mu \gamma^\rho \gamma^5 \psi$ \\ \hline [F413] [F431] [F341] & $S \leftarrow \psi^T C \gamma^5 \gamma^\mu \fmslash{V} \psi_\mu$ \\ \hline [F412] [F421] [F241] & $V_\mu \leftarrow \psi^T C S \gamma^5 \gamma^\rho \gamma_\mu \psi_\rho$ \\ \hline \multicolumn{2}{|l|}{[GBBG (Gravbar, PV, Psi)]: $\bar\psi_\mu P \fmslash{V} \gamma^\mu \psi$}\\\hline [F123] [F213] [F132] [F231] [F312] [F321] & $\psi\leftarrow \gamma^\mu P \fmslash{V} \psi_\mu$ \\ \hline [F423] [F243] [F432] [F234] [F342] [F324] & $\psi_\mu \leftarrow \fmslash{V} P \gamma_\mu \psi$ \\ \hline [F134] [F143] [F314] & $P \leftarrow \psi^T_\mu C \fmslash{V} \gamma^\mu \psi$ \\ \hline [F124] [F142] [F214] & $V_\mu \leftarrow \psi^T_\rho C P \gamma_\mu \gamma^\rho \psi$ \\ \hline [F413] [F431] [F341] & $P \leftarrow \psi^T C \gamma^\mu \fmslash{V} \psi_\mu$ \\ \hline [F412] [F421] [F241] & $V_\mu \leftarrow \psi^T C P \gamma^\rho \gamma_\mu \psi_\rho$ \\ \hline \multicolumn{2}{|l|}{[GBBG (Gravbar, V2, Psi)]: $\bar\psi_\mu f_{abc} \lbrack \fmslash{V}^a , \fmslash{V}^b \rbrack\gamma^\mu \gamma^5 \psi$}\\\hline [F123] [F213] [F132] [F231] [F312] [F321] & $\psi\leftarrow f_{abc} \gamma^5 \gamma^\mu \lbrack \fmslash{V}^a , \fmslash{V}^b \rbrack \psi_\mu$ \\ \hline [F423] [F243] [F432] [F234] [F342] [F324] & $\psi_\mu \leftarrow f_{abc} \lbrack \fmslash{V}^a , \fmslash{V}^b \rbrack \gamma_\mu \gamma^5 \psi$ \\ \hline [F134] [F143] [F314] [F124] [F142] [F214] & $V_\mu^a \leftarrow\psi^T_\rho C f_{abc} \lbrack \gamma_\mu , \fmslash{V}^b \rbrack \gamma^\rho \gamma^5 \psi$ \\ \hline [F413] [F431] [F341] [F412] [F421] [F241] & $V_\mu^a \leftarrow\psi^T C f_{abc} \gamma^5 \gamma^\rho\lbrack \gamma_\mu , \fmslash{V}^b \rbrack \psi_\rho$ \\ \hline \end{tabular} \end{center} \caption{\label{tab:dim5-gravferm2boson} Dimension-5 trilinear couplings including one Dirac, one Gravitino fermion and two additional bosons. In each lines we list the fusion possibilities with the same order of the fermions, but the order of the bosons is arbitrary (of course, one has to take care of this order in the mapping of the wave functions in [fusion]).} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.4} \begin{tabular}{|>{\qquad}r<{:}l|r<{:}l|}\hline \multicolumn{2}{|l|}{[GBBG (Psibar, S2, Grav)]: $\bar\psi S_1 S_2 \gamma^\mu \psi_\mu$}\\\hline [F123] [F213] [F132] [F231] [F312] [F321] & $\psi_\mu\leftarrow - \gamma_\mu S_1 S_2 \psi$ \\ \hline [F423] [F243] [F432] [F234] [F342] [F324] & $\psi \leftarrow \gamma^\mu S_1 S_2 \psi_\mu$ \\ \hline [F134] [F143] [F314] & $S_1 \leftarrow \psi^T C S_2 \gamma^\mu \psi_\mu$ \\ \hline [F124] [F142] [F214] & $S_2 \leftarrow \psi^T C S_1 \gamma^\mu \psi_\mu$ \\ \hline [F413] [F431] [F341] & $S_1 \leftarrow - \psi^T_\mu C S_2 \gamma^\mu \psi$ \\ \hline [F412] [F421] [F241] & $S_2 \leftarrow - \psi^T_\mu C S_1 \gamma^\mu \psi$ \\ \hline \multicolumn{2}{|l|}{[GBBG (Psibar, SV, Grav)]: $\bar\psi S \gamma^\mu \gamma^5 \fmslash{V} \psi_\mu$}\\\hline [F123] [F213] [F132] [F231] [F312] [F321] & $\psi_\mu\leftarrow \fmslash{V} S \gamma^5 \gamma^\mu \psi$ \\ \hline [F423] [F243] [F432] [F234] [F342] [F324] & $\psi\leftarrow \gamma^\mu\gamma^5 S\fmslash{V}\psi_\mu$ \\ \hline [F134] [F143] [F314] & $S \leftarrow \psi^T C \gamma^\mu \gamma^5 \fmslash{V}\psi$ \\ \hline [F124] [F142] [F214] & $V_\mu \leftarrow \psi^T C \gamma^\rho \gamma^5 S \gamma_\mu \psi_\rho$ \\ \hline [F413] [F431] [F341] & $S \leftarrow \psi^T_\mu C \fmslash{V} \gamma^5 \gamma^\mu \psi$ \\ \hline [F412] [F421] [F241] & $V_\mu \leftarrow \psi^T_\rho C S \gamma_\mu \gamma^5 \gamma^\rho \psi$ \\ \hline \multicolumn{2}{|l|}{[GBBG (Psibar, PV, Grav)]: $\bar\psi P \gamma^\mu \fmslash{V} \psi_\mu$}\\\hline [F123] [F213] [F132] [F231] [F312] [F321] & $\psi_\mu\leftarrow \fmslash{V}\gamma_\mu P \psi$ \\ \hline [F423] [F243] [F432] [F234] [F342] [F324] & $\psi\leftarrow \gamma^\mu\fmslash{V} P\psi_\mu$ \\ \hline [F134] [F143] [F314] & $P \leftarrow \psi^T C \gamma^\mu\fmslash{V}\psi_\mu$ \\ \hline [F124] [F142] [F214] & $V_\mu \leftarrow \psi^T C P \gamma^\rho \gamma_\mu \psi_\rho$ \\ \hline [F413] [F431] [F341] & $P \leftarrow \psi^T_\mu C \fmslash{V}\gamma^\mu \psi$ \\ \hline [F412] [F421] [F241] & $V_\mu \leftarrow \psi^T_\rho C P \gamma_\mu \gamma^\rho \psi$ \\ \hline \multicolumn{2}{|l|}{[GBBG (Psibar, V2, Grav)]: $\bar\psi f_{abc} \gamma^5 \gamma^\mu \lbrack \fmslash{V}^a , \fmslash{V}^b \rbrack\psi_\mu$}\\\hline [F123] [F213] [F132] [F231] [F312] [F321] & $\psi_\mu\leftarrow f_{abc} \lbrack \fmslash{V}^a , \fmslash{V}^b \rbrack \gamma_\mu \gamma^5 \psi$ \\ \hline [F423] [F243] [F432] [F234] [F342] [F324] & $\psi\leftarrow f_{abc} \gamma^5\gamma^\mu\lbrack \fmslash{V}^a , \fmslash{V}^b \rbrack\psi_\mu$ \\ \hline [F134] [F143] [F314] [F124] [F142] [F214] & $V_\mu^a \leftarrow\psi^T C f_{abc} \gamma^5\gamma^\rho\lbrack \gamma_\mu , \fmslash{V}^b \rbrack\psi_\rho$ \\ \hline [F413] [F431] [F341] [F412] [F421] [F241] & $V_\mu^a \leftarrow\psi^T_\rho C f_{abc}\lbrack \gamma_\mu , \fmslash{V}^b \rbrack\gamma^\rho\gamma^5 \psi$ \\ \hline \end{tabular} \end{center} \caption{\label{tab:dim5-gravferm2boson2} Dimension-5 trilinear couplings including one conjugated Dirac, one Gravitino fermion and two additional bosons. The couplings of Majorana fermions to the gravitino and two bosons are essentially the same as for Dirac fermions and they are omitted here.} \end{table} *) (* \thocwmodulesection{Perturbative Quantum Gravity and Kaluza-Klein Interactions} The gravitational coupling constant and the relative strength of the dilaton coupling are abbreviated as \begin{subequations} \begin{align} \kappa &= \sqrt{16\pi G_N} \\ \omega &= \sqrt{\frac{2}{3(n+2)}} = \sqrt{\frac{2}{3(d-2)}}\,, \end{align} \end{subequations} where~$n=d-4$ is the number of extra space dimensions. *) (* In~(\ref{eq:graviton-feynman-rules3}-\ref{eq:dilaton-feynman-rules5}), we use the notation of~\cite{Han/Lykken/Zhang:1999:Kaluza-Klein}: \begin{subequations} \begin{equation} C_{\mu\nu,\rho\sigma} = g_{\mu\rho} g_{\nu\sigma} + g_{\mu\sigma} g_{\nu\rho} - g_{\mu\nu} g_{\rho\sigma} \end{equation} \begin{multline} D_{\mu\nu,\rho\sigma}(k_1,k_2) = g_{\mu\nu} k_{1,\sigma} k_{2,\rho} \\ \mbox{} - ( g_{\mu\sigma} k_{1,\nu} k_{2,\rho} + g_{\mu\rho} k_{1,\sigma} k_{2,\nu} - g_{\rho\sigma} k_{1,\mu} k_{2,\nu} + (\mu\leftrightarrow\nu)) \end{multline} \begin{multline} E_{\mu\nu,\rho\sigma}(k_1,k_2) = g_{\mu\nu} (k_{1,\rho} k_{1,\sigma} + k_{2,\rho} k_{2,\sigma} + k_{1,\rho} k_{2,\sigma}) \\ \mbox{} - ( g_{\nu\sigma} k_{1,\mu} k_{1,\rho} + g_{\nu\rho} k_{2,\mu} k_{2,\sigma} + (\mu\leftrightarrow\nu)) \end{multline} \begin{multline} F_{\mu\nu,\rho\sigma\lambda}(k_1,k_2,k_3) = \\ g_{\mu\rho} g_{\sigma\lambda} (k_2 - k_3)_{\nu} + g_{\mu\sigma} g_{\lambda\rho} (k_3 - k_1)_{\nu} + g_{\mu\lambda} g_{\rho\sigma} (k_1 - k_2)_{\nu} + (\mu\leftrightarrow\nu) \end{multline} \begin{multline} G_{\mu\nu,\rho\sigma\lambda\delta} = g_{\mu\nu} (g_{\rho\sigma}g_{\lambda\delta} - g_{\rho\delta}g_{\lambda\sigma}) \\ \mbox{} + ( g_{\mu\rho}g_{\nu\delta}g_{\lambda\sigma} + g_{\mu\lambda}g_{\nu\sigma}g_{\rho\delta} - g_{\mu\rho}g_{\nu\sigma}g_{\lambda\delta} - g_{\mu\lambda}g_{\nu\delta}g_{\rho\sigma} + (\mu\leftrightarrow\nu) ) \end{multline} \end{subequations} *) (* \begin{figure} \begin{subequations} \label{eq:graviton-feynman-rules3} \begin{align} \label{eq:graviton-scalar-scalar} \parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,22) \Threeexternal{1}{2}{h_{\mu\nu}} \fmf{plain}{v,e1} \fmf{plain}{v,e2} \fmf{dbl_dots}{v,e3} \threeoutgoing \end{fmfgraph*}}} \,&= \begin{split} \mbox{} & - \ii \frac{\kappa}{2} g_{\mu\nu} m^2 + \ii \frac{\kappa}{2} C_{\mu\nu,\mu_1\mu_2}k^{\mu_1}_1k^{\mu_2}_2 \end{split} \\ \parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,22) \Threeexternal{1}{2}{h_{\mu\nu}} \fmf{photon}{v,e1} \fmf{photon}{v,e2} \fmf{dbl_dots}{v,e3} \threeoutgoing \end{fmfgraph*}}} \,&= \begin{split} \mbox{} - \ii \frac{\kappa}{2} m^2 C_{\mu\nu,\mu_1\mu_2} - \ii \frac{\kappa}{2} (& k_1k_2 C_{\mu\nu,\mu_1\mu_2} \\ &\mbox{} + D_{\mu\nu,\mu_1\mu_2}(k_1,k_2) \\ &\mbox{} + \xi^{-1} E_{\mu\nu,\mu_1\mu_2}(k_1,k_2)) \end{split} \\ \parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,22) \Threeexternal{p}{p'}{h_{\mu\nu}} \fmf{fermion}{e1,v,e2} \fmf{dbl_dots}{v,e3} \fmfdot{v} \end{fmfgraph*}}} \,&= \begin{split} \mbox{} - \ii \frac{\kappa}{2} m g_{\mu\nu} - \ii \frac{\kappa}{8} (& \gamma_{\mu}(p+p')_{\nu} + \gamma_{\nu}(p+p')_{\mu} \\ & \mbox{} - 2 g_{\mu\nu} (\fmslash{p}+\fmslash{p}') ) \end{split} \end{align} \end{subequations} \caption{\label{fig:graviton-feynman-rules3} Three-point graviton couplings.} \end{figure} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.4} \begin{tabular}{|>{\qquad}r<{:}l|}\hline \multicolumn{2}{|l|}{[Graviton_Scalar_Scalar]: $h_{\mu\nu} C^{\mu\nu}_{0}(k_1,k_2)\phi_1\phi_2$}\\\hline [F12|F21] & $\phi_2 \leftarrow \ii\cdot h_{\mu\nu} C^{\mu\nu}_{0} (k_1, -k-k_1)\phi_1 $ \\\hline [F13|F31] & $\phi_1 \leftarrow \ii\cdot h_{\mu\nu} C^{\mu\nu}_{0} (-k-k_2, k_2)\phi_2 $ \\\hline [F23|F32] & $h^{\mu\nu} \leftarrow \ii\cdot C^{\mu\nu}_0 (k_1,k_2)\phi_1\phi_2 $ \\\hline \multicolumn{2}{|l|}{[Graviton_Vector_Vector]: $h_{\mu\nu} C^{\mu\nu,\mu_1\mu_2}_1(k_1,k_2,\xi) V_{\mu_1}V_{\mu_2} $}\\\hline [F12|F21] & $ V^\mu_2 \leftarrow \ii\cdot h_{\kappa\lambda} C^{\kappa\lambda,\mu\nu}_1(-k-k_1,k_1\xi) V_{1,\nu}$ \\\hline [F13|F31] & $ V^\mu_1 \leftarrow \ii\cdot h_{\kappa\lambda} C^{\kappa\lambda,\mu\nu}_1(-k-k_2,k_2,\xi) V_{2,\nu}$ \\\hline [F23|F32] & $h^{\mu\nu} \leftarrow \ii\cdot C^{\mu\nu,\mu_1\mu_2}_1(k_1,k_2,\xi) V_{1,\mu_1}V_{2,\mu_2} $ \\\hline \multicolumn{2}{|l|}{[Graviton_Spinor_Spinor]: $h_{\mu\nu} \bar\psi_1 C^{\mu\nu}_{\frac{1}{2}}(k_1,k_2)\psi_2 $}\\\hline [F12] & $ \bar\psi_2 \leftarrow \ii\cdot h_{\mu\nu} \bar\psi_1 C^{\mu\nu}_{\frac{1}{2}}(k_1,-k-k_1) $ \\\hline [F21] & $ \bar\psi_2 \leftarrow \ii\cdot\ldots $ \\\hline [F13] & $ \psi_1 \leftarrow \ii\cdot h_{\mu\nu}C^{\mu\nu}_{\frac{1}{2}}(-k-k_2,k_2)\psi_2$ \\\hline [F31] & $ \psi_1 \leftarrow \ii\cdot\ldots $ \\\hline [F23] & $ h^{\mu\nu} \leftarrow \ii\cdot \bar\psi_1 C^{\mu\nu}_{\frac{1}{2}}(k_1,k_2)\psi_2 $ \\\hline [F32] & $ h^{\mu\nu} \leftarrow \ii\cdot\ldots $ \\\hline \end{tabular} \end{center} \caption{\label{tab:graviton-three-point} \ldots} \end{table} Derivation of~(\ref{eq:graviton-scalar-scalar}) \begin{subequations} \begin{align} L &= \frac{1}{2} (\partial_\mu \phi) (\partial^\mu \phi) - \frac{m^2}{2} \phi^2 \\ (\partial_\mu\phi) \frac{\partial L}{\partial(\partial^\nu\phi)} &= (\partial_\mu\phi)(\partial_\nu\phi) \\ T_{\mu\nu} &= -g_{\mu\nu} L + (\partial_\mu\phi) \frac{\partial L}{\partial(\partial^\nu\phi)} + \end{align} \end{subequations} \begin{subequations} \begin{align} C^{\mu\nu}_{0}(k_1,k_2) &= C^{\mu\nu,\mu_1\mu_2} k_{1,\mu_1} k_{2,\mu_2} \\ C^{\mu\nu,\mu_1\mu_2}_1(k_1,k_2,\xi) &= k_1k_2 C^{\mu\nu,\mu_1\mu_2} + D^{\mu\nu,\mu_1\mu_2}(k_1,k_2) + \xi^{-1} E^{\mu\nu,\mu_1\mu_2}(k_1,k_2) \\ C^{\mu\nu}_{\frac{1}{2},\alpha\beta}(p,p') &= \gamma^{\mu}_{\alpha\beta}(p+p')^{\nu} + \gamma^{\nu}_{\alpha\beta}(p+p')^{\mu} - 2 g^{\mu\nu} (\fmslash{p}+\fmslash{p}')_{\alpha\beta} \end{align} \end{subequations} *) (* \begin{figure} \begin{subequations} \label{eq:dilaton-feynman-rules3} \begin{align} \parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,22) \Threeexternal{1}{2}{\phi(k)} \fmf{plain}{v,e1} \fmf{plain}{v,e2} \fmf{dots}{v,e3} \threeoutgoing \end{fmfgraph*}}} \,&= - \ii \omega \kappa 2m^2 - \ii \omega \kappa k_1k_2 \\ \parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,22) \Threeexternal{1}{2}{\phi(k)} \fmf{photon}{v,e1} \fmf{photon}{v,e2} \fmf{dots}{v,e3} \threeoutgoing \end{fmfgraph*}}} \,&= - \ii \omega \kappa g_{\mu_1\mu_2}m^2 - \ii \omega \kappa \xi^{-1} (k_{1,\mu_1}k_{\mu_2} + k_{2,\mu_2}k_{\mu_1}) \\ \parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,22) \Threeexternal{p}{p'}{\phi(k)} \fmf{fermion}{e1,v,e2} \fmf{dots}{v,e3} \fmfdot{v} \end{fmfgraph*}}} \,&= - \ii \omega \kappa 2m + \ii \omega \kappa \frac{3}{4}(\fmslash{p}+\fmslash{p}') \end{align} \end{subequations} \caption{\label{fig:dilaton-feynman-rules3} Three-point dilaton couplings.} \end{figure} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.4} \begin{tabular}{|>{\qquad}r<{:}l|}\hline \multicolumn{2}{|l|}{[Dilaton_Scalar_Scalar]: $\phi \ldots k_1k_2\phi_1\phi_2 $}\\\hline [F12|F21] & $ \phi_2 \leftarrow \ii\cdot k_1(-k-k_1)\phi\phi_1 $ \\\hline [F13|F31] & $ \phi_1 \leftarrow \ii\cdot (-k-k_2)k_2\phi\phi_2 $ \\\hline [F23|F32] & $ \phi \leftarrow \ii\cdot k_1k_2\phi_1\phi_2 $ \\\hline \multicolumn{2}{|l|}{[Dilaton_Vector_Vector]: $\phi \ldots $}\\\hline [F12] & $ V_{2,\mu} \leftarrow \ii\cdot\ldots $ \\\hline [F21] & $ V_{2,\mu} \leftarrow \ii\cdot\ldots $ \\\hline [F13] & $ V_{1,\mu} \leftarrow \ii\cdot\ldots $ \\\hline [F31] & $ V_{1,\mu} \leftarrow \ii\cdot\ldots $ \\\hline [F23] & $ \phi \leftarrow \ii\cdot\ldots $ \\\hline [F32] & $ \phi \leftarrow \ii\cdot\ldots $ \\\hline \multicolumn{2}{|l|}{[Dilaton_Spinor_Spinor]: $\phi \ldots $}\\\hline [F12] & $ \bar\psi_2 \leftarrow \ii\cdot\ldots $ \\\hline [F21] & $ \bar\psi_2 \leftarrow \ii\cdot\ldots $ \\\hline [F13] & $ \psi_1 \leftarrow \ii\cdot\ldots $ \\\hline [F31] & $ \psi_1 \leftarrow \ii\cdot\ldots $ \\\hline [F23] & $ \phi \leftarrow \ii\cdot\ldots $ \\\hline [F32] & $ \phi \leftarrow \ii\cdot\ldots $ \\\hline \end{tabular} \end{center} \caption{\label{tab:dilaton-three-point} \ldots} \end{table} *) (* \begin{figure} \begin{subequations} \label{eq:graviton-feynman-rules4} \begin{align} \label{eq:graviton-scalar-scalar-scalar} \parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,22) \Fourexternal{1}{2}{3}{h_{\mu\nu}} \fmf{plain}{v,e1} \fmf{plain}{v,e2} \fmf{plain}{v,e3} \fmf{dbl_dots}{v,e4} \fouroutgoing \end{fmfgraph*}}} \,&= \begin{split} \mbox{} & ??? \end{split} \\ \parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,22) \Fourexternal{1}{2}{3}{h_{\mu\nu}} \fmf{plain}{v,e1} \fmf{plain}{v,e2} \fmf{photon}{v,e3} \fmf{dbl_dots}{v,e4} \fouroutgoing \end{fmfgraph*}}} \,&= \begin{split} \mbox{} & - \ii g\frac{\kappa}{2} C_{\mu\nu,\mu_3\rho}(k_1-k_2)^{\rho} T^{a_3}_{n_2n_1} \end{split} \\ \label{eq:graviton-scalar-vector-vector} \parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,22) \Fourexternal{1}{2}{3}{h_{\mu\nu}} \fmf{plain}{v,e1} \fmf{photon}{v,e2} \fmf{photon}{v,e3} \fmf{dbl_dots}{v,e4} \fouroutgoing \end{fmfgraph*}}} \,&= \begin{split} \mbox{} & ??? \end{split} \\ \parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,22) \Fourexternal{1}{2}{3}{h_{\mu\nu}} \fmf{photon}{v,e1} \fmf{photon}{v,e2} \fmf{photon}{v,e3} \fmf{dbl_dots}{v,e4} \fouroutgoing \end{fmfgraph*}}} \,&= \begin{split} \mbox{} - g \frac{\kappa}{2} f^{a_1a_2a_3} (& C_{\mu\nu,\mu_1\mu_2} (k_1-k_2)_{\mu_3} \\ & \mbox{} + C_{\mu\nu,\mu_2\mu_3} (k_2-k_3)_{\mu_1} \\ & \mbox{} + C_{\mu\nu,\mu_3\mu_1} (k_3-k_1)_{\mu_2} \\ & \mbox{} + F_{\mu\nu,\mu_1\mu_2\mu_3}(k_1,k_2,k_3) ) \end{split} \\ \label{eq:graviton-yukawa} \parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,22) \Fourexternal{1}{2}{3}{h_{\mu\nu}} \fmf{fermion}{e1,v,e2} \fmf{plain}{v,e3} \fmf{dbl_dots}{v,e4} \fmfdot{v} \fmffreeze \fmf{warrow_right}{v,e3} \fmf{warrow_right}{v,e4} \end{fmfgraph*}}} \,&= \begin{split} \mbox{} & ??? \end{split} \\ \parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,22) \Fourexternal{1}{2}{3}{h_{\mu\nu}} \fmf{fermion}{e1,v,e2} \fmf{photon}{v,e3} \fmf{dbl_dots}{v,e4} \fmfdot{v} \fmffreeze \fmf{warrow_right}{v,e3} \fmf{warrow_right}{v,e4} \end{fmfgraph*}}} \,&= \begin{split} \mbox{} & \ii g\frac{\kappa}{4} (C_{\mu\nu,\mu_3\rho} - g_{\mu\nu}g_{\mu_3\rho}) \gamma^{\rho} T^{a_3}_{n_2n_1} \end{split} \end{align} \end{subequations} \caption{\label{fig:graviton-feynman-rules4} Four-point graviton couplings. (\ref{eq:graviton-scalar-scalar-scalar}), (\ref{eq:graviton-scalar-vector-vector}), and~(\ref{eq:graviton-yukawa)} are missing in~\cite{Han/Lykken/Zhang:1999:Kaluza-Klein}, but should be generated by standard model Higgs selfcouplings, Higgs-gaugeboson couplings, and Yukawa couplings.} \end{figure} *) (* \begin{figure} \begin{subequations} \label{eq:dilaton-feynman-rules4} \begin{align} \label{eq:dilaton-scalar-scalar-scalar} \parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,22) \Fourexternal{1}{2}{3}{\phi(k)} \fmf{plain}{v,e1} \fmf{plain}{v,e2} \fmf{plain}{v,e3} \fmf{dots}{v,e4} \fouroutgoing \end{fmfgraph*}}} \,&= ??? \\ \parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,22) \Fourexternal{1}{2}{3}{\phi(k)} \fmf{plain}{v,e1} \fmf{plain}{v,e2} \fmf{photon}{v,e3} \fmf{dots}{v,e4} \fouroutgoing \end{fmfgraph*}}} \,&= - \ii \omega \kappa (k_1 + k_2)_{\mu_3} T^{a_3}_{n_1,n_2} \\ \label{eq:dilaton-scalar-vector-vector} \parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,22) \Fourexternal{1}{2}{3}{\phi(k)} \fmf{plain}{v,e1} \fmf{photon}{v,e2} \fmf{photon}{v,e3} \fmf{dots}{v,e4} \fouroutgoing \end{fmfgraph*}}} \,&= ??? \\ \parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,22) \Fourexternal{1}{2}{3}{\phi(k)} \fmf{photon}{v,e1} \fmf{photon}{v,e2} \fmf{photon}{v,e3} \fmf{dots}{v,e4} \fouroutgoing \end{fmfgraph*}}} \,&= 0 \\ \label{eq:dilaton-yukawa} \parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,22) \Fourexternal{1}{2}{3}{h_{\mu\nu}} \fmf{fermion}{e1,v,e2} \fmf{plain}{v,e3} \fmf{dots}{v,e4} \fmfdot{v} \fmffreeze \fmf{warrow_right}{v,e3} \fmf{warrow_right}{v,e4} \end{fmfgraph*}}} \,&= ??? \\ \parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,22) \Fourexternal{1}{2}{3}{\phi(k)} \fmf{fermion}{e1,v,e2} \fmf{photon}{v,e3} \fmf{dots}{v,e4} \fmfdot{v} \fmffreeze \fmf{warrow_right}{v,e3} \fmf{warrow_right}{v,e4} \end{fmfgraph*}}} \,&= - \ii \frac{3}{2} \omega g \kappa \gamma_{\mu_3} T^{a_3}_{n_1n_2} \end{align} \end{subequations} \caption{\label{fig:dilaton-feynman-rules4} Four-point dilaton couplings. (\ref{eq:dilaton-scalar-scalar-scalar}), (\ref{eq:dilaton-scalar-vector-vector}) and~(\ref{eq:dilaton-yukawa}) are missing in~\cite{Han/Lykken/Zhang:1999:Kaluza-Klein}, but could be generated by standard model Higgs selfcouplings, Higgs-gaugeboson couplings, and Yukawa couplings.} \end{figure} *) (* \begin{figure} \begin{subequations} \label{eq:graviton-feynman-rules5} \begin{align} \label{eq:graviton-scalar-scalar-scalar-scalar} \parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,22) \Fiveexternal{1}{2}{3}{4}{h_{\mu\nu}} \fmf{plain}{v,e1} \fmf{plain}{v,e2} \fmf{plain}{v,e3} \fmf{plain}{v,e4} \fmf{dots}{v,e5} \fiveoutgoing \end{fmfgraph*}}} \,&= \begin{split} \mbox{} & ??? \end{split} \\ \parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,22) \Fiveexternal{1}{2}{3}{4}{h_{\mu\nu}} \fmf{plain}{v,e1} \fmf{plain}{v,e2} \fmf{photon}{v,e3} \fmf{photon}{v,e4} \fmf{dots}{v,e5} \fiveoutgoing \end{fmfgraph*}}} \,&= \begin{split} \mbox{} & - \ii g^2 \frac{\kappa}{2} C_{\mu\nu,\mu_3\mu_4} (T^{a_3}T^{a_4} + T^{a_4}T^{a_3})_{n_2n_1} \end{split} \\ \parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,22) \Fiveexternal{1}{2}{3}{4}{h_{\mu\nu}} \fmf{photon}{v,e1} \fmf{photon}{v,e2} \fmf{photon}{v,e3} \fmf{photon}{v,e4} \fmf{dots}{v,e5} \fiveoutgoing \end{fmfgraph*}}} \,&= \begin{split} \mbox{} - \ii g^2 \frac{\kappa}{2} (& f^{ba_1a_3} f^{ba_2a_4} G_{\mu\nu,\mu_1\mu_2\mu_3\mu_4} \\ & \mbox + f^{ba_1a_2} f^{ba_3a_4} G_{\mu\nu,\mu_1\mu_3\mu_2\mu_4} \\ & \mbox + f^{ba_1a_4} f^{ba_2a_3} G_{\mu\nu,\mu_1\mu_2\mu_4\mu_3} ) \end{split} \end{align} \end{subequations} \caption{\label{fig:graviton-feynman-rules5} Five-point graviton couplings. (\ref{eq:graviton-scalar-scalar-scalar-scalar}) is missing in~\cite{Han/Lykken/Zhang:1999:Kaluza-Klein}, but should be generated by standard model Higgs selfcouplings.} \end{figure} *) (* \begin{figure} \begin{subequations} \label{eq:dilaton-feynman-rules5} \begin{align} \label{eq:dilaton-scalar-scalar-scalar-scalar} \parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,22) \Fiveexternal{1}{2}{3}{4}{\phi(k)} \fmf{plain}{v,e1} \fmf{plain}{v,e2} \fmf{plain}{v,e3} \fmf{plain}{v,e4} \fmf{dots}{v,e5} \fiveoutgoing \end{fmfgraph*}}} \,&= ??? \\ \parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,22) \Fiveexternal{1}{2}{3}{4}{\phi(k)} \fmf{plain}{v,e1} \fmf{plain}{v,e2} \fmf{photon}{v,e3} \fmf{photon}{v,e4} \fmf{dots}{v,e5} \fiveoutgoing \end{fmfgraph*}}} \,&= \ii \omega g^2 \kappa g_{\mu_3\mu_4} (T^{a_3}T^{a_4} + T^{a_4}T^{a_3})_{n_2n_1} \\ \parbox{28mm}{\fmfframe(2,2)(2,1){\begin{fmfgraph*}(24,22) \Fiveexternal{1}{2}{3}{4}{\phi(k)} \fmf{photon}{v,e1} \fmf{photon}{v,e2} \fmf{photon}{v,e3} \fmf{photon}{v,e4} \fmf{dots}{v,e5} \fiveoutgoing \end{fmfgraph*}}} \,&= 0 \end{align} \end{subequations} \caption{\label{fig:dilaton-feynman-rules5} Five-point dilaton couplings. (\ref{eq:dilaton-scalar-scalar-scalar-scalar}) is missing in~\cite{Han/Lykken/Zhang:1999:Kaluza-Klein}, but could be generated by standard model Higgs selfcouplings.} \end{figure} *) (* \thocwmodulesection{Dependent Parameters} This is a simple abstract syntax for parameter dependencies. Later, there will be a parser for a convenient concrete syntax as a part of a concrete syntax for models. There is no intention to do \emph{any} symbolic manipulation with this. The expressions will be translated directly by [Targets] to the target language. *) type 'a expr = | I | Const of int | Atom of 'a | Sum of 'a expr list | Diff of 'a expr * 'a expr | Neg of 'a expr | Prod of 'a expr list | Quot of 'a expr * 'a expr | Rec of 'a expr | Pow of 'a expr * int + | PowX of 'a expr * 'a expr | Sqrt of 'a expr | Sin of 'a expr | Cos of 'a expr | Tan of 'a expr | Cot of 'a expr | Atan2 of 'a expr * 'a expr + | Exp of 'a expr | Conj of 'a expr type 'a variable = Real of 'a | Complex of 'a type 'a variable_array = Real_Array of 'a | Complex_Array of 'a type 'a parameters = { input : ('a * float) list; derived : ('a variable * 'a expr) list; derived_arrays : ('a variable_array * 'a expr list) list } (* \thocwmodulesection{More Exotic Couplings} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.3} \begin{tabular}{|>{\qquad}r<{:}l|}\hline \multicolumn{2}{|l|}{[Dim5_Scalar_Vector_Vector_T]: $\mathcal{L}_I=g\phi (\ii\partial_\mu V_1^\nu)(\ii\partial_\nu V_2^\mu)$}\\\hline [F23] & $\phi(k_2+k_3)\leftarrow\ii\cdot g k_3^\mu V_{1,\mu}(k_2) k_2^\nu V_{2,\nu}(k_3)$ \\\hline [F32] & $\phi(k_2+k_3)\leftarrow\ii\cdot g k_2^\mu V_{2,\mu}(k_3) k_3^\nu V_{1,\nu}(k_2)$ \\\hline [F12] & $V_2^\mu(k_1+k_2)\leftarrow\ii\cdot g k_2^\mu \phi(k_1) (-k_1^\nu-k_2^\nu) V_{1,\nu}(k_2)$ \\\hline [F21] & $V_2^\mu(k_1+k_2)\leftarrow\ii\cdot g k_2^\mu (-k_1^\nu-k_2^\nu)V_{1,\nu}(k_2) \phi(k_1)$ \\\hline [F13] & $V_1^\mu(k_1+k_3)\leftarrow\ii\cdot g k_3^\mu \phi(k_1) (-k_1^\nu-k_3^\nu)V_{2,\nu}(k_3)$ \\\hline [F31] & $V_1^\mu(k_1+k_3)\leftarrow\ii\cdot g k_3^\mu (-k_1^\nu-k_3^\nu)V_{2,\nu}(k_3) \phi(k_1)$ \\\hline \end{tabular} \end{center} \caption{\label{tab:dim5-scalar-vector-vector} \ldots} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.3} \begin{tabular}{|>{\qquad}r<{:}l|}\hline \multicolumn{2}{|l|}{[Dim6_Vector_Vector_Vector_T]: $\mathcal{L}_I=gV_1^\mu ((\ii\partial_\nu V_2^\rho)% \ii\overleftrightarrow{\partial_\mu} (\ii\partial_\rho V_3^\nu))$}\\\hline [F23] & $V_1^\mu(k_2+k_3)\leftarrow\ii\cdot g (k_2^\mu - k_3^\mu) k_3^\nu V_{2,\nu} (k_2) k_2^\rho V_{3,\rho}(k_3)$ \\\hline [F32] & $V_1^\mu(k_2+k_3)\leftarrow\ii\cdot g (k_2^\mu - k_3^\mu) k_2^\nu V_{3,\nu} (k_3) k_3^\rho V_{2,\rho}(k_2)$ \\\hline [F12] & $V_3^\mu(k_1+k_2)\leftarrow\ii\cdot g k_2^\mu (k_1^\nu+2k_2^\nu) V_{1,\nu} (k_1) (-k_1^\rho-k_2^\rho) V_{2,\rho}(k_2)$ \\\hline [F21] & $V_3^\mu(k_1+k_2)\leftarrow\ii\cdot g k_2^\mu (-k_1^\rho-k_2^\rho) V_{2,\rho}(k_2) (k_1^\nu+2k_2^\nu) V_{1,\nu} (k_1)$ \\\hline [F13] & $V_2^\mu(k_1+k_3)\leftarrow\ii\cdot g k_3^\mu (k_1^\nu+2k_3^\nu) V_{1,\nu} (k_1) (-k_1^\rho-k_3^\rho) V_{3,\rho}(k_3)$ \\\hline [F31] & $V_2^\mu(k_1+k_3)\leftarrow\ii\cdot g k_3^\mu (-k_1^\rho-k_3^\rho) V_{3,\rho}(k_3) (k_1^\nu+2k_3^\nu) V_{1,\nu} (k_1)$ \\\hline \end{tabular} \end{center} \caption{\label{tab:dim6-vector-vector-vector} \ldots} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.3} \begin{tabular}{|>{\qquad}r<{:}l|}\hline \multicolumn{2}{|l|}{[Tensor_2_Vector_Vector]: $\mathcal{L}_I=gT^{\mu\nu} (V_{1,\mu}V_{2,\nu} + V_{1,\nu}V_{2,\mu})$}\\\hline [F23] & $T^{\mu\nu}(k_2+k_3)\leftarrow\ii\cdot g (V_{1,\mu}(k_2) V_{2,\nu}(k_3) + V_{1,\nu}(k_2) V_{2,\mu}(k_3))$ \\\hline [F32] & $T^{\mu\nu}(k_2+k_3)\leftarrow\ii\cdot g (V_{2,\nu}(k_3) V_{1,\mu}(k_2) + V_{2,\mu}(k_3) V_{1,\nu}(k_2))$ \\\hline [F12] & $V_2^\mu(k_1+k_2)\leftarrow\ii\cdot g (T^{\mu\nu}(k_1) + T^{\nu\mu}(k_1)) V_{1,\nu}(k_2)$ \\\hline [F21] & $V_2^\mu(k_1+k_2)\leftarrow\ii\cdot g V_{1,\nu}(k_2)(T^{\mu\nu}(k_1) + T^{\nu\mu}(k_1))$ \\\hline [F13] & $V_1^\mu(k_1+k_3)\leftarrow\ii\cdot g (T^{\mu\nu}(k_1) + T^{\nu\mu}(k_1)) V_{2,\nu}(k_3)$ \\\hline [F31] & $V_1^\mu(k_1+k_3)\leftarrow\ii\cdot g V_{2,\nu}(k_3) (T^{\mu\nu}(k_1) + T^{\nu\mu}(k_1))$ \\\hline \end{tabular} \end{center} \caption{\label{tab:tensor2-vector-vector} \ldots} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.3} \begin{tabular}{|>{\qquad}r<{:}l|}\hline \multicolumn{2}{|l|}{[Dim5_Tensor_2_Vector_Vector_1]: $\mathcal{L}_I=gT^{\alpha\beta} (V_1^\mu \ii\overleftrightarrow\partial_\alpha \ii\overleftrightarrow\partial_\beta V_{2,\mu})$}\\\hline [F23] & $T^{\alpha\beta}(k_2+k_3)\leftarrow\ii\cdot g (k_2^\alpha-k_3^\alpha)(k_2^\beta-k_3^\beta) V_1^\mu(k_2)V_{2,\mu}(k_3)$ \\\hline [F32] & $T^{\alpha\beta}(k_2+k_3)\leftarrow\ii\cdot g (k_2^\alpha-k_3^\alpha)(k_2^\beta-k_3^\beta) V_{2,\mu}(k_3)V_1^\mu(k_2)$ \\\hline [F12] & $V_2^\mu(k_1+k_2)\leftarrow\ii\cdot g (k_1^\alpha+2k_2^\alpha) (k_1^\beta+2k_2^\beta) T_{\alpha\beta}(k_1) V_1^\mu(k_2)$ \\\hline [F21] & $V_2^\mu(k_1+k_2)\leftarrow\ii\cdot g (k_1^\alpha+2k_2^\alpha) (k_1^\beta+2k_2^\beta) V_1^\mu(k_2) T_{\alpha\beta}(k_1)$ \\\hline [F13] & $V_1^\mu(k_1+k_3)\leftarrow\ii\cdot g (k_1^\alpha+2k_3^\alpha) (k_1^\beta+2k_3^\beta) T_{\alpha\beta}(k_1) V_2^\mu(k_3)$ \\\hline [F31] & $V_1^\mu(k_1+k_3)\leftarrow\ii\cdot g (k_1^\alpha+2k_3^\alpha) (k_1^\beta+2k_3^\beta) V_2^\mu(k_3) T_{\alpha\beta}(k_1)$ \\\hline \end{tabular} \end{center} \caption{\label{tab:dim5-tensor2-vector-vector-1} \ldots} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.3} \begin{tabular}{|>{\qquad}r<{:}l|}\hline \multicolumn{2}{|l|}{[Dim5_Tensor_2_Vector_Vector_2]: $\mathcal{L}_I=gT^{\alpha\beta} ( V_1^\mu \ii\overleftrightarrow\partial_\beta (\ii\partial_\mu V_{2,\alpha}) + V_1^\mu \ii\overleftrightarrow\partial_\alpha (\ii\partial_\mu V_{2,\beta})) $}\\\hline [F23] & $T^{\alpha\beta}(k_2+k_3)\leftarrow\ii\cdot g (k_3^\beta-k_2^\beta) k_3^\mu V_{1,\mu}(k_2)V_2^\alpha(k_3) + (\alpha\leftrightarrow\beta)$ \\\hline [F32] & $T^{\alpha\beta}(k_2+k_3)\leftarrow\ii\cdot g (k_3^\beta-k_2^\beta) V_2^\alpha(k_3) k_3^\mu V_{1,\mu}(k_2) + (\alpha\leftrightarrow\beta)$ \\\hline [F12] & $V_2^\alpha(k_1+k_2)\leftarrow\ii\cdot g (k_1^\beta+2k_2^\beta) (T^{\alpha\beta}(k_1)+T^{\beta\alpha}(k_1)) (k_1^\mu+k_2^\mu) V_{1,\mu}(k_2)$ \\\hline [F21] & $V_2^\alpha(k_1+k_2)\leftarrow\ii\cdot g (k_1^\mu+k_2^\mu) V_{1,\mu}(k_2) (k_1^\beta+2k_2^\beta) (T^{\alpha\beta}(k_1)+T^{\beta\alpha}(k_1))$ \\\hline [F13] & $V_1^\alpha(k_1+k_3)\leftarrow\ii\cdot g (k_1^\beta+2k_3^\beta) (T^{\alpha\beta}(k_1)+T^{\beta\alpha}(k_1)) (k_1^\mu+k_3^\mu) V_{2,\mu}(k_3)$ \\\hline [F31] & $V_1^\alpha(k_1+k_3)\leftarrow\ii\cdot g (k_1^\mu+k_3^\mu) V_{2,\mu}(k_3) (k_1^\beta+2k_3^\beta) (T^{\alpha\beta}(k_1)+T^{\beta\alpha}(k_1))$ \\\hline \end{tabular} \end{center} \caption{\label{tab:dim5-tensor2-vector-vector-1'} \ldots} \end{table} \begin{table} \begin{center} \renewcommand{\arraystretch}{1.3} \begin{tabular}{|>{\qquad}r<{:}l|}\hline \multicolumn{2}{|l|}{[Dim7_Tensor_2_Vector_Vector_T]: $\mathcal{L}_I=gT^{\alpha\beta} ((\ii\partial^\mu V_1^\nu) \ii\overleftrightarrow\partial_\alpha \ii\overleftrightarrow\partial_\beta (\ii\partial_\nu V_{2,\mu}))$}\\\hline [F23] & $T^{\alpha\beta}(k_2+k_3)\leftarrow\ii\cdot g (k_2^\alpha-k_3^\alpha)(k_2^\beta-k_3^\beta) k_3^\mu V_{1,\mu}(k_2) k_2^\nu V_{2,\nu}(k_3)$ \\\hline [F32] & $T^{\alpha\beta}(k_2+k_3)\leftarrow\ii\cdot g (k_2^\alpha-k_3^\alpha)(k_2^\beta-k_3^\beta) k_2^\nu V_{2,\nu}(k_3) k_3^\mu V_{1,\mu}(k_2)$ \\\hline [F12] & $V_2^\mu(k_1+k_2)\leftarrow\ii\cdot g k_2^\mu (k_1^\alpha+2k_2^\alpha) (k_1^\beta+2k_2^\beta) T_{\alpha\beta}(k_1) (-k_1^\nu-k_2^\nu)V_{1,\nu}(k_2)$ \\\hline [F21] & $V_2^\mu(k_1+k_2)\leftarrow\ii\cdot g k_2^\mu (-k_1^\nu-k_2^\nu)V_{1,\nu}(k_2) (k_1^\alpha+2k_2^\alpha) (k_1^\beta+2k_2^\beta) T_{\alpha\beta}(k_1)$ \\\hline [F13] & $V_1^\mu(k_1+k_3)\leftarrow\ii\cdot g k_3^\mu (k_1^\alpha+2k_3^\alpha) (k_1^\beta+2k_3^\beta) T_{\alpha\beta}(k_1) (-k_1^\nu-k_3^\nu) V_{2,\nu}(k_3)$ \\\hline [F31] & $V_1^\mu(k_1+k_3)\leftarrow\ii\cdot g k_3^\mu (-k_1^\nu-k_3^\nu) V_{2,\nu}(k_3) (k_1^\alpha+2k_3^\alpha) (k_1^\beta+2k_3^\beta) T_{\alpha\beta}(k_1)$ \\\hline \end{tabular} \end{center} \caption{\label{tab:dim7-tensor2-vector-vector-T} \ldots} \end{table} *) Index: trunk/omega/src/UFO.ml =================================================================== --- trunk/omega/src/UFO.ml (revision 8252) +++ trunk/omega/src/UFO.ml (revision 8253) @@ -1,2139 +1,2294 @@ (* UFO.ml -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) (* Unfortunately, \texttt{ocamlweb} will not typeset all multi character operators nicely. E.\,g.~\verb+f @< g+ comes out as [f @< g]. *) let (@@) f g x = f (g x) let (@@@) f g x y = f (g x y) 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_syntax.Syntax_Error (msg, start_pos, end_pos) -> invalid_arg (Printf.sprintf "syntax error (%s) at: `%s'" msg (error_in_string text start_pos end_pos)) | Parsing.Parse_error -> invalid_arg ("parse error: " ^ text) let parse_file name = let ic = open_in name in let result = begin try UFO_parser.file UFO_lexer.token (UFO_lexer.init_position name (Lexing.from_channel ic)) with | UFO_syntax.Syntax_Error (msg, start_pos, end_pos) -> begin close_in ic; invalid_arg (Printf.sprintf "%s: syntax error (%s)" (error_in_file name start_pos end_pos) msg) end | Parsing.Parse_error -> begin close_in ic; invalid_arg ("parse error: " ^ name) end end in close_in ic; result +(* These are the contents of the Python files after lexical + analysis as context-free variable declarations, before + any semantic interpretation. *) + module type Files = sig type t = private { particles : UFO_syntax.t; couplings : UFO_syntax.t; coupling_orders : UFO_syntax.t; vertices : UFO_syntax.t; lorentz : UFO_syntax.t; parameters : UFO_syntax.t; propagators : UFO_syntax.t; decays : UFO_syntax.t } val parse_directory : string -> t end module Files : Files = struct type t = { particles : UFO_syntax.t; couplings : UFO_syntax.t; coupling_orders : UFO_syntax.t; vertices : UFO_syntax.t; lorentz : UFO_syntax.t; parameters : UFO_syntax.t; propagators : UFO_syntax.t; decays : UFO_syntax.t } let parse_directory dir = let parse stem = parse_file (Filename.concat dir (stem ^ ".py")) in { particles = parse "particles"; couplings = parse "couplings"; coupling_orders = (try parse "coupling_orders" with _ -> []); vertices = parse "vertices"; lorentz = parse "lorentz"; parameters = parse "parameters"; propagators = (try parse "propagators" with _ -> []); decays = (try parse "decays" with _ -> []) } end let dump_file pfx f = List.iter (fun s -> print_endline (pfx ^ ": " ^ s)) (UFO_syntax.to_strings f) type charge = | Q_Integer of int | Q_Fraction of int * int let charge_to_string = function | Q_Integer i -> Printf.sprintf "%d" i | Q_Fraction (n, d) -> Printf.sprintf "%d/%d" n d module S = UFO_syntax let find_attrib name attribs = try (List.find (fun a -> name = a.S.a_name) attribs).S.a_value with | Not_found -> failwith ("UFO.find_attrib: \"" ^ name ^ "\" not found") let find_attrib name attribs = (List.find (fun a -> name = a.S.a_name) attribs).S.a_value let name_to_string ?strip name = let stripped = begin match strip, List.rev name with | Some pfx, head :: tail -> if pfx = head then tail else failwith ("UFO.name_to_string: expected prefix '" ^ pfx ^ "', got '" ^ head ^ "'") | _, name -> name end in String.concat "." stripped let name_attrib ?strip name attribs = match find_attrib name attribs with | S.Name n -> name_to_string ?strip n | _ -> invalid_arg name let integer_attrib name attribs = match find_attrib name attribs with | S.Integer i -> i | _ -> invalid_arg 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 name let string_attrib name attribs = match find_attrib name attribs with | S.String s -> s | _ -> invalid_arg name let boolean_attrib name attribs = try match String.lowercase (name_attrib name attribs) with | "true" -> true | "false" -> false | _ -> invalid_arg name with | Not_found -> false type value = | Integer of int | Fraction of int * int | Float of float | String of string | Name of string list 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 | String s -> Printf.sprintf "'%s'" s | 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 | String s -> UFOx.Value.to_string (UFOx.Value.of_expr (substitutions (UFOx.Expr.of_string s))) | Name n -> name_to_string n let value_to_coupling substitutions atom = function | Integer i -> Coupling.Const i | Fraction (n, d) -> Coupling.Quot (Coupling.Const n, Coupling.Const d) | Float x -> failwith "UFO.value_to_coupling: Float not supported yet!" | String s -> UFOx.Value.to_coupling atom (UFOx.Value.of_expr (substitutions (UFOx.Expr.of_string s))) | 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 | String s -> invalid_arg ("UFO.value_to_numeric: string = " ^ s) | 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 | String s -> invalid_arg ("UFO.value_to_float: string = " ^ s) | 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 -> String s | S.Name n -> Name n | _ -> invalid_arg name let string_list_attrib name attribs = match find_attrib name attribs with | S.String_List l -> l | _ -> invalid_arg 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 name let integer_list_attrib name attribs = match find_attrib name attribs with | S.Integer_List l -> l | _ -> invalid_arg name let order_dictionary_attrib name attribs = match find_attrib name attribs with | S.Order_Dictionary d -> d | _ -> invalid_arg 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 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 name module SMap = Map.Make (struct type t = string let compare = compare end) 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 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; texname : string; antitexname : string; charge : charge; ghost_number : int; lepton_number : int; y : int; 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 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; texname : string; antitexname : string; charge : charge; ghost_number : int; lepton_number : int; y : int; 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, \ Q = %s, G = %d, L = %d, Y = %d, \ 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 (charge_to_string p.charge) p.ghost_number p.lepton_number 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; texname = p.antitexname; antitexname = p.texname; charge = conjugate_charge p.charge; ghost_number = p.ghost_number; lepton_number = p.lepton_number; y = p.y; goldstone = p.goldstone; propagating = p.propagating; line = p.line; is_anti = not p.is_anti } let of_file1 map d = let symbol = d.S.name in match d.S.kind, d.S.attribs with | [ "Particle" ], attribs -> SMap.add symbol { pdg_code = integer_attrib "pdg_code" attribs; name = string_attrib "name" attribs; antiname = string_attrib "antiname" attribs; spin = UFOx.Lorentz.rep_of_int (integer_attrib "spin" attribs); color = UFOx.Color.rep_of_int (integer_attrib "color" attribs); mass = name_attrib ~strip:"Param" "mass" attribs; width = name_attrib ~strip:"Param" "width" attribs; texname = string_attrib "texname" attribs; antitexname = string_attrib "antitexname" attribs; charge = charge_attrib "charge" attribs; ghost_number = integer_attrib "GhostNumber" attribs; lepton_number = integer_attrib "LeptonNumber" attribs; y = (try integer_attrib "Y" attribs with _ -> 0); goldstone = (try boolean_attrib "goldstone" attribs with _ -> false); propagating = true; line = None; is_anti = false} map | [ "anti"; p ], [] -> begin try SMap.add symbol (conjugate (SMap.find p map)) map with | Not_found -> invalid_arg ("Particle.of_file: " ^ p ^ ".anti() not yet defined!") end | _ -> invalid_arg ("Particle.of_file: " ^ name_to_string d.S.kind) let of_file particles = List.fold_left of_file1 SMap.empty particles let is_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 : string; order : (string * int) list } val of_file : S.t -> t SMap.t val to_string : string -> t -> string + val to_string_expanded : string -> t -> string end module UFO_Coupling : UFO_Coupling = struct type t = { name : string; value : string; 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 c.value (order_to_string c.order) + let to_string_expanded symbol c = + let expansion = + UFOx.Value.to_string (UFOx.Value.of_expr (UFOx.Expr.of_string c.value)) in + Printf.sprintf + "coupling: %s => [name = '%s', value = '%s', value' = '%s', order = [%s]]" + symbol c.name c.value expansion (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 name = string_attrib "name" attribs in if name <> symbol then Printf.eprintf "UFO_Coupling.of_file: warning: symbol '%s' <> name '%s'\n" symbol name; SMap.add symbol { name = name; value = string_attrib "value" attribs; order = order_dictionary_attrib "order" attribs } 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 -> SMap.add symbol { name = string_attrib "name" attribs; expansion_order = integer_attrib "expansion_order" attribs; hierarchy = integer_attrib "hierarchy" attribs } 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 = +module type Lorentz_UFO = sig type t = private { name : 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 : Lorentz = +module Lorentz_UFO : Lorentz_UFO = struct type t = { name : 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 -> SMap.add symbol { name = string_attrib "name" attribs; spins = integer_list_attrib "spins" attribs; structure = UFOx.Lorentz.of_string (string_attrib "structure" attribs) } 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; - color : UFOx.Color.t array; - lorentz : string array; - couplings : string option array array } + lcc : lcc list } - val of_file : S.t -> t SMap.t + val of_file : Particle.t SMap.t -> S.t -> t SMap.t val to_string : string -> t -> string val to_string_expanded : - Lorentz.t SMap.t -> UFO_Coupling.t SMap.t -> t -> string - + 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; - color : UFOx.Color.t array; - lorentz : string array; - couplings : string option array array } + lcc : lcc list } let to_string symbol c = Printf.sprintf "vertex: %s => [name = '%s', particles = [%s], \ - color = [%s], lorentz = [%s], \ - couplings = [%s]]" + lorentz-color-couplings = [%s]]" symbol c.name - (String.concat ", " (Array.to_list c.particles)) - (String.concat ", " - (List.map UFOx.Color.to_string (Array.to_list c.color))) - (String.concat ", " (Array.to_list c.lorentz)) - (String.concat ", " - (List.map - (fun column -> - "[" ^ (String.concat ", " - (List.map - (function Some s -> s | None -> "0") - (Array.to_list column))) ^ "]") - (Array.to_list c.couplings))) - + (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.structure - with - | Not_found -> "?" in - let expand_coupling s = - try - UFOx.Value.to_string - (UFOx.Value.of_expr - (UFOx.Expr.of_string - (SMap.find s couplings).UFO_Coupling.value)) + UFOx.Lorentz.to_string (SMap.find s lorentz).Lorentz_UFO.structure with | Not_found -> "?" in Printf.sprintf - "expanded: [%s] -> { color = [%s], lorentz = [%s], \ - couplings = [%s] }" + "expanded: [%s] -> { lorentz-color-couplings = [%s] }" (String.concat ", " (Array.to_list c.particles)) - (String.concat ", " - (List.map UFOx.Color.to_string (Array.to_list c.color))) - (String.concat ", " - (List.map expand_lorentz (Array.to_list c.lorentz))) - (String.concat ", " - (List.map - (fun column -> - "[" ^ (String.concat ", " - (List.map - (function Some s -> expand_coupling s | None -> "0") - (Array.to_list column))) ^ "]") - (Array.to_list c.couplings))) + (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 of_file1 map d = + 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 + + let of_file1 particle_map map d = let symbol = d.S.name in match d.S.kind, d.S.attribs with | [ "Vertex" ], attribs -> + let particles = + Array.of_list (name_list_attrib ~strip:"P" "particles" attribs) in let color = + let indices = classify_color_indices particle_map particles in Array.of_list (List.map - UFOx.Color.of_string (string_list_attrib "color" attribs)) + (force_identity indices @@ UFOx.Color.of_string) + (string_list_attrib "color" attribs)) and lorentz = Array.of_list (name_list_attrib ~strip:"L" "lorentz" attribs) and couplings_alist = coupling_dictionary_attrib ~strip:"C" "couplings" attribs in - let couplings = - Array.make_matrix (Array.length color) (Array.length lorentz) None in - List.iter - (fun (i, j, c) -> couplings.(i).(j) <- Some c) - couplings_alist; + let lcc = + List.map + (fun (i, j, c) -> + { lorentz = lorentz.(j); + color = color.(i); + coupling = c }) + couplings_alist in SMap.add symbol { name = string_attrib "name" attribs; - particles = - Array.of_list (name_list_attrib ~strip:"P" "particles" attribs); - color = color; - lorentz = lorentz; - couplings = couplings } map + particles; + lcc } map | _ -> invalid_arg ("Vertex.of_file: " ^ name_to_string d.S.kind) - let of_file vertices = - List.fold_left of_file1 SMap.empty vertices + 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 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 -> (SMap.add symbol { name = string_attrib "name" attribs; nature = nature_of_string (string_attrib "nature" attribs); ptype = ptype_of_string (string_attrib "type" attribs); value = value_attrib "value" attribs; texname = string_attrib "texname" attribs; 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 end module type Propagator = sig type t = private { name : string; numerator : string; denominator : string } val of_file : S.t -> t SMap.t val to_string : string -> t -> string end module Propagator : Propagator = struct type t = { name : string; numerator : string; denominator : string } let to_string symbol p = Printf.sprintf "propagator: %s => [name = '%s', numerator = '%s', \ denominator = '%s']" symbol p.name p.numerator p.denominator (* The parser will turn [foo = "bar"] into [foo = "bar"."$"], which will be interpreted as a macro definition for [foo] expanding to ["bar"]. The dollar is used to distinguish it from an empty attribute list. This could also be implemented with a union type for the declarations. *) let of_file1 (macros, map) d = let symbol = d.S.name in match d.S.kind, d.S.attribs with | [ "Propagator" ], attribs -> let denominator = begin match find_attrib "denominator" attribs with | S.String s -> s | S.Name [n] -> SMap.find n macros | _ -> invalid_arg "Propagator.denominator: " end in (macros, SMap.add symbol { name = string_attrib "name" attribs; numerator = string_attrib "numerator" attribs; denominator = denominator } map) | [ "$"; s ], [] -> (SMap.add symbol s macros, map) | _ -> invalid_arg ("Propagator:of_file: " ^ name_to_string d.S.kind) let of_file propagators = let _, propagators' = List.fold_left of_file1 (SMap.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 -> SMap.add symbol { name = string_attrib "name" attribs; particle = name_attrib ~strip:"P" "particle" attribs; widths = decay_dictionary_attrib "partial_widths" attribs } 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 -type t = - { particles : Particle.t SMap.t; - couplings : UFO_Coupling.t SMap.t; - coupling_orders : Coupling_Order.t SMap.t; - vertices : Vertex.t SMap.t; - lorentz : Lorentz.t SMap.t; - parameters : Parameter.t SMap.t; - propagators : Propagator.t SMap.t; - decays : Decay.t SMap.t } - -(* Take the elements of [list] that satisfy [predicate] and - form a list of pairs of offsets and elements with the offsets - starting from [offset]. *) -let alist_of_list predicate offset 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 - -let lorentz_reps_of_vertex model v = - alist_of_list (not @@ UFOx.Lorentz.rep_trivial) 1 +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 model.particles).Particle.spin) + (SMap.find p particles).Particle.spin) (Array.to_list v.Vertex.particles)) -let check_lorentz_reps_of_vertex model v = - let reps_particles = List.sort compare (lorentz_reps_of_vertex model v) in - Array.iter - (fun l -> - let l = (SMap.find l model.lorentz).Lorentz.structure in +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 reps_vertex <> reps_particles then begin Printf.printf "%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); invalid_arg "check_lorentz_reps_of_vertex" end) - v.Vertex.lorentz - -let color_reps_of_vertex model v = - alist_of_list (not @@ UFOx.Color.rep_trivial) 1 + 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 model.particles).Particle.color) + (fun p -> (SMap.find p particles).Particle.color) (Array.to_list v.Vertex.particles)) -let check_color_reps_of_vertex model v = - let reps_particles = List.sort compare (color_reps_of_vertex model v) in - Array.iter - (fun c -> - let reps_vertex = List.sort compare (UFOx.Color.classify_indices c) in +let check_color_reps_of_vertex particles v = + let reps_particles = + List.sort compare (color_reps_of_vertex particles v) in + List.iter + (fun lcc -> + let reps_vertex = + List.sort compare (UFOx.Color.classify_indices lcc.Vertex.color) in if reps_vertex <> reps_particles then begin Printf.printf "%s <> %s\n" (UFOx.Index.classes_to_string UFOx.Color.rep_to_string reps_particles) (UFOx.Index.classes_to_string UFOx.Color.rep_to_string reps_vertex); invalid_arg "check_color_reps_of_vertex" end) - v.Vertex.color - + 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 : UFOx.Lorentz.t } + + 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 to_string : string -> t -> string + + end + +module Lorentz : Lorentz = + struct + + (* 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. + + TODO: check if UFO files for models with Majorana + fermions need further disambiguation, because the + same Lorentz structure is used for Dirac and Majorana + fermions. *) + + type spins = + | Unused + | Unique of Coupling.lorentz array + | Ambiguous of Coupling.lorentz array SMap.t + + type t = + { name : string; + n : int; + spins : spins; + structure : UFOx.Lorentz.t } + + let permute_spins p = function + | Unused -> Unused + | Unique s -> Unique (P.array p s) + | Ambiguous map -> Ambiguous (SMap.map (P.array p) map) + + (* We must permute only the free indices, of course. + Note that we apply the \emph{inverse} permutation to + the indices in order to match the permutation of the + particles/spins. *) + let permute_structure n p l = + let permuted = P.array (P.inverse p) (Array.init n succ) in + let permute_index i = + if i > 0 then + permuted.(pred i) + else + i in + UFOx.Lorentz.map_indices permute_index l + + let permute p l = + { name = l.name ^ "_p" ^ P.to_string (P.inverse p); + n = l.n; + spins = permute_spins p l.spins; + structure = permute_structure l.n p l.structure } + + 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.name) + 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 + | _ -> Ambiguous uses + + let of_lorentz_UFO particles vertices lorentz_UFO = + SMap.map + (fun l -> + { name = l.Lorentz_UFO.name; + n = List.length l.Lorentz_UFO.spins; + spins = lorentz_reps_of_structure particles vertices l; + structure = l.Lorentz_UFO.structure }) + lorentz_UFO + + 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 ^ ")" + + let to_string symbol l = + Printf.sprintf + "lorentz: %s => [name = '%s', spins = %s, \ + structure = %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!") + (UFOx.Lorentz.to_string l.structure) + + 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 : Propagator.t SMap.t; + decays : Decay.t SMap.t } + let of_file u = + let particles = Particle.of_file u.Files.particles in + let particle_array = Array.of_list (values particles) in + let vertices = Vertex.of_file particles u.Files.vertices in + let lorentz_UFO = Lorentz_UFO.of_file u.Files.lorentz in + let lorentz = Lorentz.of_lorentz_UFO particles vertices lorentz_UFO in let model = - { particles = Particle.of_file u.Files.particles; + { particles; + particle_array; couplings = UFO_Coupling.of_file u.Files.couplings; coupling_orders = Coupling_Order.of_file u.Files.coupling_orders; - vertices = Vertex.of_file u.Files.vertices; - lorentz = Lorentz.of_file u.Files.lorentz; + vertices; + lorentz_UFO; + lorentz; parameters = Parameter.of_file u.Files.parameters; propagators = Propagator.of_file u.Files.propagators; decays = Decay.of_file u.Files.decays } in SMap.iter (fun _ v -> - check_color_reps_of_vertex model v; - check_lorentz_reps_of_vertex model v) + check_color_reps_of_vertex model.particles v; + check_lorentz_reps_of_vertex model.particles model.lorentz_UFO v) model.vertices; model let parse_directory dir = of_file (Files.parse_directory dir) let dump model = SMap.iter (print_endline @@@ Particle.to_string) model.particles; - (* [SMap.iter (print_endline @@@ UFO_Coupling.to_string) model.couplings;] *) - SMap.iter - (fun symbol c -> - (print_endline @@@ UFO_Coupling.to_string) symbol c; - print_endline - (" ==>> " ^ - (UFOx.Value.to_string - (UFOx.Value.of_expr - (UFOx.Expr.of_string c.UFO_Coupling.value))))) - model.couplings; + SMap.iter (print_endline @@@ UFO_Coupling.to_string_expanded) 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 model.couplings v); - check_color_reps_of_vertex model v; - check_lorentz_reps_of_vertex model v) + print_endline + (Vertex.to_string_expanded model.lorentz_UFO model.couplings v); + check_color_reps_of_vertex model.particles v; + check_lorentz_reps_of_vertex model.particles model.lorentz_UFO 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.to_string) model.propagators; SMap.iter (print_endline @@@ Decay.to_string) model.decays; SMap.iter - (fun symbol c -> ignore (UFOx.Expr.of_string c.UFO_Coupling.value)) - model.couplings; - SMap.iter (fun symbol d -> List.iter (fun (_, w) -> ignore (UFOx.Expr.of_string w)) d.Decay.widths) model.decays exception Unhandled of string let unhandled s = raise (Unhandled s) module Model = struct (* NB: we could use [type flavor = Particle.t], but that would be very inefficient, because we will use [flavor] as a key for maps below. *) type flavor = int type constant = string type gauge = unit module M = Modeltools.Mutable (struct type f = flavor type g = gauge type c = constant end) let flavors = M.flavors let external_flavors = M.external_flavors let external_flavors = M.external_flavors let lorentz = M.lorentz let color = M.color let 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 -> 1 | Coupling.Maj_Ghost -> 1 | 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 let rec conjugate_lorentz = function | Coupling.Spinor -> Coupling.ConjSpinor | Coupling.ConjSpinor -> Coupling.Spinor | Coupling.BRS f -> Coupling.BRS (conjugate_lorentz f) | f -> f module F = Modeltools.Fusions (struct type f = flavor type c = constant let compare = compare let conjugate = conjugate end) - module Q = UFOx.Q + module Q = Algebra.Q + module QC = Algebra.QC let dummy_tensor3 = Coupling.Scalar_Scalar_Scalar 1 let dummy_tensor4 = Coupling.Scalar4 1 - let third i j = - match i, j with - | 1, 2 | 2, 1 -> 3 - | 2, 3 | 3, 2 -> 1 - | 3, 1 | 1, 3 -> 2 - | _ -> invalid_arg "UFO.third" - - let translate_color_atom c = - let open UFOx.Color_Atom in - match c with - | Identity (i, j) -> 1 - | T (a, i, j) -> 1 - | F (a, b, c) -> Combinatorics.sign [a;b;c] - | D (a, b, c) -> invalid_arg "d-tensor not supported yet" - | Epsilon (i, j, k) -> invalid_arg "epsilon-tensor not supported yet" - | EpsilonBar (i, j, k) -> invalid_arg "epsilon-tensor not supported yet" - | T6 (a, i, j) -> invalid_arg "T6-tensor not supported yet" - | K6 (i, j, k) -> invalid_arg "K6-tensor not supported yet" - | K6Bar (i, j, k) -> invalid_arg "K6-tensor not supported yet" - - let translate_color3_1 c = - match c with - | [ ([], q) ] -> q - | [ ([c1], q) ] -> Q.mul q (Q.make (translate_color_atom c1) 1) - | [] -> invalid_arg "translate_color3_1: empty" - | _ -> invalid_arg "translate_color3_1: sums of tensors not supported yet" - - let translate_color3 = function - | [| c |] -> translate_color3_1 c - | c -> - invalid_arg - (Printf.sprintf - "translate_color3: #color structures: %d > 1" (Array.length c)) - - (* Move the smallest index first, using antisymmetry - in $a,b$ and $c,d$ as well as symmetry in $(ab)(cd)$: *) - let normalize_quartet a b c d = - let a0 = List.hd (List.sort compare [a; b; c; d]) in - if a0 = a then - (a, b, c, d) - else if a0 = b then - (b, a, d, c) - else if a0 = c then - (c, d, a, b) - else - (d, c, b, a) - - (* [FF_1 (q, a, b, c, d)] represents the tensor $q f_{abe}f_{ecd}$ - and we assume that [normalize_quartet] has been applied to the - indices. *) - type color4_1 = - | C3_1 of Q.t - | FF_1 of Q.t * int * int * int * int - - (* [FF123 (q1, q2, q3, a, b, c, d)] represents the tensor triple - $(q_1 f_{abe}f_{ecd}, q_2 f_{ace}f_{edb}, q_3 f_{ade}f_{ecb})$ - and [FF132 (q1, q2, q3, a, b, c, d)] the triple - $(q_1 f_{abe}f_{ecd}, q_2 f_{ade}f_{ecb}, q_3 f_{ace}f_{edb})$ *) - - type color4 = - | C3 of Q.t - | FF123 of Q.t * Q.t * Q.t * int * int * int * int - | FF132 of Q.t * Q.t * Q.t * int * int * int * int - - let q2s q = - match Q.to_ratio q with - | n, 1 -> string_of_int n - | n, d -> string_of_int n ^ "/" ^ string_of_int d - - let color4_to_string = function - | C3 (q) -> q2s q - | FF123 (q1, q2, q3, a, b, c, d) -> - Printf.sprintf - "[%s*f(%d,%d,-1)*f(-1,%d,%d); \ - %s*f(%d,%d,-1)*f(-1,%d,%d); \ - %s*f(%d,%d,-1)*f(-1,%d,%d)]" - (q2s q1) a b c d - (q2s q2) a c d b - (q2s q3) a d b c - | FF132 (q1, q2, q3, a, b, c, d) -> - Printf.sprintf - "[%s*f(%d,%d,-1)*f(-1,%d,%d); \ - %s*f(%d,%d,-1)*f(-1,%d,%d); \ - %s*f(%d,%d,-1)*f(-1,%d,%d)]" - (q2s q1) a b c d - (q2s q2) a d b c - (q2s q3) a c d b - - let translate_color4_1_1 c = - Q.make (translate_color_atom c) 1 - -(* Take two lists of three indices each, find exactly one common index, - check that it is a summation index (i.\,e. not positive) and return - the remaining four indices in normal order (see [normalize_quartet]) - together with the sign of the permutations. *) - let translate_color4_ff abc abc' = - match ThoList.common abc abc' with - | [] -> invalid_arg "translate_color4_ff: not summation index" - | [s] -> - if s >= 1 then - invalid_arg "translate_color4_ff: invalid summation index" - else - begin match (Combinatorics.sort_signed abc, - Combinatorics.sort_signed abc') with - | (eps, [_; b; c]), (eps', [_; b'; c']) -> - let a, b, c, d = normalize_quartet b c b' c' in - FF_1 (Q.make (eps * eps') 1, a, b, c, d) - | _ -> failwith "translate_color4_ff: can't happen" - end - | _ -> - invalid_arg "translate_color4_ff: multiple summation indices" - - let translate_color_atom_pair c1 c2 = - let open UFOx.Color_Atom in - match c1, c2 with - | Identity (i, j), Identity (i', l') -> - invalid_arg "quartic 3-3bar-couplings not supported yet" - | T (a, i, j), T (a', i', j') -> - invalid_arg "quartic 3-3bar-couplings not supported yet" - | F (a, b, c), F (a', b', c') -> - translate_color4_ff [a; b; c] [a'; b'; c'] - | T (a, i, j), F (a', b', c') - | F (a', b', c'), T (a, i, j) -> - invalid_arg "quartic 8-8-3-3bar-couplings not supported yet" - | Identity (i, j), T (a', i', l') - | T (a', i', l'), Identity (i, j) -> - invalid_arg "open index" - | Identity (i, j), F (a', b', c') - | F (a', b', c'), Identity (i, j) -> - invalid_arg "open index" - | D (a, b, c), _ | _, D (a, b, c) -> - invalid_arg "d-tensor not supported yet" - | Epsilon (i, j, k), _ | _, Epsilon (i, j, k) - | EpsilonBar (i, j, k), _| _, EpsilonBar (i, j, k) -> - invalid_arg "epsilon-tensor not supported yet" - | T6 (a, i, j), _ | _, T6 (a, i, j) -> - invalid_arg "T6-tensor not supported yet" - | K6 (i, j, k), _ | _, K6 (i, j, k) - | K6Bar (i, j, k), _ | _, K6Bar (i, j, k) -> - invalid_arg "K6-tensor not supported yet" - - let translate_color4_1 c = - match c with - | [ ([], q) ] -> C3_1 (q) - | [ ([c1], q) ] -> - C3_1 (Q.mul q (translate_color4_1_1 c1)) - | [ ([c1; c2], q) ] -> - begin match translate_color_atom_pair c1 c2 with - | FF_1 (eps, a, b, c, d) -> FF_1 (Q.mul q eps, a, b, c, d) - | C3_1 (eps) -> C3_1 (Q.mul q eps) - end - | _ -> invalid_arg "translate_color4_1: too many atoms" - - let l2s f l = - "[" ^ String.concat "; " (List.map f l) ^ "]" - - let il2s l = l2s string_of_int l - - let il2s2 l2 = l2s il2s l2 - -(*l -We can not handle color tensors on their own, because UFO -allows to exchange signs between color and Lorentz tensors. - -Indeed, the \texttt{FeynRulesSM} file has -\begin{verbatim} - 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 = [ 'Metric(1,4)*Metric(2,3) - Metric(1,3)*Metric(2,4)', - 'Metric(1,4)*Metric(2,3) - Metric(1,2)*Metric(3,4)', - 'Metric(1,3)*Metric(2,4) - Metric(1,2)*Metric(3,4)' ], - couplings = {(1,1):C.GC_12,(0,0):C.GC_12,(2,2):C.GC_12}) -\end{verbatim} -i.e. -\begin{verbatim} - f(-1,1,2)*f(3,4,-1) * (Metric(1,4)*Metric(2,3) - Metric(1,3)*Metric(2,4)) - + f(-1,1,3)*f(2,4,-1) * (Metric(1,4)*Metric(2,3) - Metric(1,2)*Metric(3,4)) - + f(-1,1,4)*f(2,3,-1) * (Metric(1,3)*Metric(2,4) - Metric(1,2)*Metric(3,4)) -= - f(-1,1,2)*f(3,4,-1) * (Metric(1,4)*Metric(2,3) - Metric(1,3)*Metric(4,2)) - + f(-1,1,3)*f(4,2,-1) * (Metric(1,2)*Metric(3,4) - Metric(1,4)*Metric(3,2)) - + f(-1,1,4)*f(2,3,-1) * (Metric(1,3)*Metric(2,4) - Metric(1,2)*Metric(3,4)) -\end{verbatim} -*) - - let translate_color4 c = - match Array.map translate_color4_1 c with - | [| C3_1 (q) |] -> C3 q - | [| FF_1 (q1, a1, b1, c1, d1); - FF_1 (q2, a2, b2, c2, d2); - FF_1 (q3, a3, b3, c3, d3) |] -> - if Q.abs q1 = Q.abs q2 && Q.abs q2 = Q.abs q3 then - if a1 = a2 && a2 = a3 then - let bcd1 = [b1; c1; d1] - and bcd2 = [b2; c2; d2] - and bcd3 = [b3; c3; d3] in - let eps1 = Combinatorics.sign bcd1 in - let eps2, bcd2 = - let eps = Combinatorics.sign bcd2 in - if eps = eps1 then - (Q.make eps 1, bcd2) - else - (Q.make eps 1, [b2; d2; c2]) - and eps3, bcd3 = - let eps = Combinatorics.sign bcd3 in - if eps = eps1 then - (Q.make eps 1, bcd3) - else - (Q.make eps 1, [b3; d3; c3]) in - if bcd2 = [c1; d1; b1] then - if bcd3 = [d1; b1; c1] then - FF123 (q1, Q.mul eps2 q2, Q.mul eps3 q3, a1, b1, c1, d1) - else - invalid_arg "translate_color4: mismatched indices b, c, d" - else if bcd2 = [d1; b1; c1] then - if bcd3 = [c1; d1; b1] then - FF132 (q1, Q.mul eps2 q2, Q.mul eps3 q3, a1, b1, c1, d1) - else - invalid_arg "translate_color4: mismatched indices b, c, d" - else - invalid_arg "translate_color4: mismatched indices b, c, d" - else - invalid_arg "translate_color4: mismatched indices a" - else - invalid_arg "translate_color4: mismatched couplings" - | c -> - invalid_arg - (Printf.sprintf - "translate_color4: #color structures: %d" (Array.length c)) - -(* The Lorentz part of the three gauge boson vertex is - \begin{equation} - 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{equation} -*) - let normalize_lorentz_gauge_3 l = - List.sort - (fun (ka1, la1, mu1, i1, q1) (ka2, la2, mu2, i2, q2) -> - ThoList.lexicographic [ka1; la1; mu1; i1] [ka2; la2; mu2; i2]) - (List.map - (fun (ka, la, mu, i, q) -> - if ka > la then - (la, ka, mu, i, q) - else - (ka, la, mu, i, q)) - l) - let triplet p = (p.(0), p.(1), p.(2)) - - let translate_lorentz_gauge_3 t c p g kalamuiq = - match normalize_lorentz_gauge_3 kalamuiq with - | [ (ka1, la1, mu1, i1, q1); - (ka2, la2, mu2, i2, q2); - (ka3, la3, mu3, i3, q3); - (ka4, la4, mu4, i4, q4); - (ka5, la5, mu5, i5, q5); - (ka6, la6, mu6, i6, q6) ] -> - if ThoList.homogeneous [ ka1; ka2; ka3; ka4; mu5; mu6; i1; i3 ] - && ThoList.homogeneous [ la1; la2; mu3; mu4; ka5; ka6; i2; i5 ] - && ThoList.homogeneous [ mu1; mu2; la3; la4; la5; la6; i4; i6 ] - && ThoList.homogeneous [ q1; Q.neg q2; Q.neg q3; q4; q5; Q.neg q6 ] - then - begin match c with - | [| [([UFOx.Color_Atom.F (_, _, _)], _)] |] -> - (triplet p, Coupling.Gauge_Gauge_Gauge (-1), g, q1) -(* Here we have three gluons. The color flow Feynman rules require - an additional factor of $+\textrm{i}$ relative to the colorless case - below. *) -(* FIXME: we actually use and need $-\textrm{i}$ to make things work. - Explain this!!! *) - | [| [([], _)] |] -> - (triplet p, Coupling.I_Gauge_Gauge_Gauge (-1), g, q1) -(* Here we have three vector bosons without color. - [I_Gauge_Gauge_Gauge] translates to $+\textrm{i}$ times - \verb+g_gg+, i.\,e.~the factor of $-\textrm{i}$ inside - \verb+g_gg+ is cancelled and everything is real. - Naturally, there is no factor of $+\textrm{i}$ - from color flow Feynman rules. Finally, there is a - factor of $-1$, because all O'Mega momenta are defined as - \emph{outgoing}. *) - | _ -> - invalid_arg "translate_lorentz_gauge_3: unexpected colors" -(* We probably never get here. Or are there models - with mixed vectors mixing color representations? *) - end - else - invalid_arg "translate_lorentz_gauge_3" - | _ -> invalid_arg "translate_lorentz_gauge_3: expected 6 terms" + 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 translate_coupling3_1 model p t c qc g = - let module L = UFOx.Lorentz_Atom in - match t with - | [ [], qt] -> - [(triplet p, Coupling.Scalar_Scalar_Scalar 1, g, Q.mul qt qc)] - | [ [L.Identity(j,i)], qt] -> - [((p.(pred i), p.(pred (third i j)), p.(pred j)), - Coupling.FBF (1, Coupling.Psibar, Coupling.S, Coupling.Psi), - g, Q.mul qt qc)] - | [ [L.ProjP(j,i)], qt] -> - [((p.(pred i), p.(pred (third i j)), p.(pred j)), - Coupling.FBF (1, Coupling.Psibar, Coupling.SR, Coupling.Psi), - g, half_times qt qc)] - | [ [L.ProjM(j,i)], qt] -> - [((p.(pred i), p.(pred (third i j)), p.(pred j)), - Coupling.FBF (1, Coupling.Psibar, Coupling.SL, Coupling.Psi), - g, half_times qt qc)] - | [ ([L.ProjM(j,i)], qm); ([L.ProjP(j',i')], qp)] as t -> - if i = i' && j = j' then - if Q.is_null (Q.add qm qp) then - [((p.(pred i), p.(pred (third i j)), p.(pred j)), - Coupling.FBF (1, Coupling.Psibar, Coupling.P, Coupling.Psi), - g, half_times qp qc)] - else if Q.is_null (Q.sub qp qp) then - [((p.(pred i), p.(pred (third i j)), p.(pred j)), - Coupling.FBF (1, Coupling.Psibar, Coupling.S, Coupling.Psi), - g, Q.mul qp qc)] - else - unhandled ("colorless 3-vertex: " ^ UFOx.Lorentz.to_string t) - else - invalid_arg "translate_coupling3_1: mismatched indices" - | [ ([L.Gamma(mu,j,-1); L.ProjM(-1,i)], qm); - ([L.Gamma(mu',j',-1); L.ProjP(-1,i')], qp)] -> - if i = i' && j = j' && mu = mu' then - [((p.(pred i), p.(pred mu), p.(pred j)), - Coupling.FBF (1, Coupling.Psibar, Coupling.VL, Coupling.Psi), - g, half_times qm qc); - ((p.(pred i), p.(pred mu), p.(pred j)), - Coupling.FBF (1, Coupling.Psibar, Coupling.VR, Coupling.Psi), - g, half_times qp qc)] - else - invalid_arg "translate_coupling3_1: mismatched indices" - | [ [L.Gamma(mu,j,i)], qt] -> - [((p.(pred i), p.(pred mu), p.(pred j)), - Coupling.FBF (1, Coupling.Psibar, Coupling.V, Coupling.Psi), - g, Q.mul qt qc)] - | [ [L.Gamma(mu,j,-1); L.ProjP(-1,i)], qt] -> - [((p.(pred i), p.(pred mu), p.(pred j)), - Coupling.FBF (1, Coupling.Psibar, Coupling.VR, Coupling.Psi), - g, half_times qt qc)] - | [ [L.Gamma(mu,j,-1); L.ProjM(-1,i)], qt] -> - [((p.(pred i), p.(pred mu), p.(pred j)), - Coupling.FBF (1, Coupling.Psibar, Coupling.VL, Coupling.Psi), - g, half_times qt qc)] - | [ [L.Metric(j,i)], qt] -> - [((p.(pred (third i j)), p.(pred i), p.(pred j)), - Coupling.Scalar_Vector_Vector 1, - g, Q.mul qt qc)] - | [ ([L.P(mu,i)], q1); ([L.P(mu',j)], q2) ] as t -> - if mu = mu' then - if Q.is_null (Q.add q1 q2) then - [((p.(pred (third i j)), p.(pred i), p.(pred j)), - Coupling.Vector_Scalar_Scalar 1, - g, Q.mul q1 qc)] - else - unhandled ("colorless 3-vertex: " ^ UFOx.Lorentz.to_string t) - else - invalid_arg "translate_coupling3_1: mismatched indices" - | [ ([L.Metric(ka1,la1); L.P(mu1,i1)], q1); - ([L.Metric(ka2,la2); L.P(mu2,i2)], q2); - ([L.Metric(ka3,la3); L.P(mu3,i3)], q3); - ([L.Metric(ka4,la4); L.P(mu4,i4)], q4); - ([L.Metric(ka5,la5); L.P(mu5,i5)], q5); - ([L.Metric(ka6,la6); L.P(mu6,i6)], q6)] as t -> - [translate_lorentz_gauge_3 t c p g - [ (ka1, la1, mu1, i1, q1); - (ka2, la2, mu2, i2, q2); - (ka3, la3, mu3, i3, q3); - (ka4, la4, mu4, i4, q4); - (ka5, la5, mu5, i5, q5); - (ka6, la6, mu6, i6, q6) ]] - | t -> - unhandled ("3-vertex: " ^ UFOx.Lorentz.to_string t) - 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 translate_chiral_pair c1 c2 = - let open Coupling in - match c1, c2 with - | (p123, FBF (q, Psibar, l, Psi), g, r), - (p123',FBF (q', Psibar, l', Psi), g', r') -> - if p123 = p123 then - match l, l' with - | P, S | S, P | SL, SR | SR, SL | V, A | A, V | VL, VR | VR, VL -> - [(p123, FBF (q, Psibar, l, Psi), fractional_coupling g r); - (p123, FBF (q', Psibar, l', Psi), fractional_coupling g' r')] - | _, _ -> - invalid_arg "translate_chiral_pair: incompatible Dirac matrices" + 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" + + let force_integer q = + try + Q.to_integer q + with + | _ -> invalid_arg "translate_color?: non-integer coefficient" + + let pair3_of_indices i j = + match i, j with + | 1, 2 -> Color.P3_12 + | 2, 3 -> Color.P3_23 + | 3, 1 -> Color.P3_31 + | 2, 1 -> Color.P3_21 + | 3, 2 -> Color.P3_32 + | 1, 3 -> Color.P3_13 + | _ -> + if i = j then + invalid_arg "pair3_of_indices: equal" else - invalid_arg "translate_chiral_pair: incompatible flavors" - | _ -> unhandled "chiral pair" + invalid_arg "pair3_of_indices: out of range" - let translate_coupling3 model p t c g = - match t, translate_color3 c, g with - | [| t |], qc, [| [| Some g |] |] -> - begin match translate_coupling3_1 model p t c qc g with - | [] -> [] - | [(p123, fbf, g, r)] -> [(p123, fbf, fractional_coupling g r)] - | [c1; c2] -> translate_chiral_pair c1 c2 - | _ -> invalid_arg "translate_coupling3: unexpected list" - end - | [| t |], qc, _ -> - invalid_arg "translate_coupling3: too many constants" - | [| t1; t2 |], qc, [| [| Some g1; Some g2 |] |] -> - begin match (translate_coupling3_1 model p t1 c qc g1, - translate_coupling3_1 model p t2 c qc g2) with - | [c1], [c2] -> translate_chiral_pair c1 c2 - | c1, c2 -> - let c_clist = c1 @ c2 in - if ThoList.homogeneous - (List.map (fun (p123, _, _, _) -> p123) c_clist) then - (* We're not checking the compatibility of the - $\gamma$-matrices here! *) - List.map - (fun (p123, fbf, g, r) -> (p123, fbf, fractional_coupling g r)) - c_clist - else - invalid_arg "translate_coupling3: incompatible flavors" - end - | [| t1; t2; t3 |], qc, [| [| Some g1; Some g2; Some g3 |] |] -> - begin match (translate_coupling3_1 model p t1 c qc g1, - translate_coupling3_1 model p t2 c qc g2, - translate_coupling3_1 model p t3 c qc g3) with - | c1, c2, c3 -> - let c_clist = c1 @ c2 @ c3 in - if ThoList.homogeneous - (List.map (fun (p123, _, _, _) -> p123) c_clist) then - (* We're not checking the compatibility of the - $\gamma$-matrices here! *) - List.map - (fun (p123, fbf, g, r) -> (p123, fbf, fractional_coupling g r)) - c_clist - else - invalid_arg "translate_coupling3: incompatible flavors" - end - | t, qc, g -> - unhandled - ("3-vertex w/multiple Lorentz structures: " ^ - (String.concat ", " - (List.map UFOx.Lorentz.to_string (Array.to_list t)))) - -(* Use the fact that $g_{\mu\nu}g_{\kappa\lambda}$ is symmetric in the - interchanges $\mu\leftrightarrow\nu$, $\kappa\leftrightarrow\lambda$ - and $(\mu\nu)\leftrightarrow(\kappa\lambda)$ to normalize the - index positions: *) - let normalize_lorentz_4_1 (mu, nu, ka, la) = - List.flatten (List.sort ThoList.lexicographic - (List.map (List.sort compare) [[mu; nu]; [ka; la]])) - - let normalize_lorentz_4 contractions = - List.sort - (fun (c1, q1) (c2, q2) -> ThoList.lexicographic c1 c2) - (List.map (fun (c, q) -> (normalize_lorentz_4_1 c, q)) contractions) - -(* \begin{dubious} - Here we must verify and fix (iff necessary) the signs! - \end{dubious} *) - - let translate_lorentz_4 model p t = - let open Coupling in - let module L = UFOx.Lorentz_Atom in - match t with - | [ ([L.Metric(mu1,nu1); L.Metric(ka1,la1)], q1); - ([L.Metric(mu2,nu2); L.Metric(ka2,la2)], q2); - ([L.Metric(mu3,nu3); L.Metric(ka3,la3)], q3) ] -> - begin match normalize_lorentz_4 [ ((mu1, nu1, ka1, la1), q1); - ((mu2, nu2, ka2, la2), q2); - ((mu3, nu3, ka3, la3), q3) ] with - | [ ([mu1; nu1; ka1; la1], q1); - ([mu2; nu2; ka2; la2], q2); - ([mu3; nu3; ka3; la3], q3) ] -> - let minus_half q = Q.mul (Q.make (-1) 2) q in - if ThoList.homogeneous [mu1; mu2; mu3] - && ThoList.homogeneous [nu1; ka2; ka3] - && ThoList.homogeneous [ka1; nu2; la3] - && ThoList.homogeneous [la1; la2; nu3] then begin - (* $ q_1 g_{\mu\nu}g_{\kappa\lambda} - + q_2 g_{\mu\kappa}g_{\nu\lambda} - + q_3 g_{\mu\lambda}g_{\nu\kappa} $ a.\,k.\,a.{} *) - (* $ q_1 \text{\textit{C\_12\_34}} - + q_2 \text{\textit{C\_13\_24}} - + q_3 \text{\textit{C\_14\_23}} $ *) - if ThoList.homogeneous [minus_half q1; q2; q3] then - (p, q2, Vector4 [ (-2, C_12_34); ( 1, C_13_42); ( 1, C_14_23) ]) - else if ThoList.homogeneous [minus_half q2; q3; q1] then - (p, q3, Vector4 [ ( 1, C_12_34); (-2, C_13_42); ( 1, C_14_23) ]) - else if ThoList.homogeneous [minus_half q3; q1; q2] then - (p, q1, Vector4 [ ( 1, C_12_34); ( 1, C_13_42); (-2, C_14_23) ]) - else begin - prerr_endline - ("unexpected 4-gauge-vertex: " ^ UFOx.Lorentz.to_string t); - (p, Q.unit, dummy_tensor4) - end - end else begin - prerr_endline - ("expected 4-gauge-vertex: " ^ UFOx.Lorentz.to_string t); - invalid_arg "normalize_lorentz_4: unexpected" - end - | _ -> failwith "translate_lorentz_4: unexpected" - end - | [ ([L.Metric(mu1,nu1); L.Metric(ka1,la1)], q1); - ([L.Metric(mu2,nu2); L.Metric(ka2,la2)], q2) ] -> - begin match normalize_lorentz_4 [ ((mu1, nu1, ka1, la1), q1); - ((mu2, nu2, ka2, la2), q2) ] with - | [ ([mu1; nu1; ka1; la1], q1); - ([mu2; nu2; ka2; la2], q2) ] -> - (* $ \lbrack 1;2;3;4 \rbrack - \lbrack 1;3;2;4 \rbrack $ and - $ \lbrack 1;2;3;4 \rbrack - \lbrack 1;4;2;3 \rbrack $ and - $ \lbrack 1;3;2;4 \rbrack - \lbrack 1;4;2;3 \rbrack $ *) - if mu1 = mu2 && q2 = Q.neg q1 then - if [nu2; ka2; la2] = [ka1; nu1; la1] then - (p, q1, Vector4 [ ( 1, C_12_34); (-1, C_13_42) ]) - else if [nu2; ka2; la2] = [la1; nu1; ka1] then - (p, q1, Vector4 [ ( 1, C_12_34); (-1, C_14_23) ]) - else if [nu2; ka2; la2] = [la1; ka1; nu1] then - (p, q1, Vector4 [ ( 1, C_13_42); (-1, C_14_23) ]) - else - invalid_arg "translate_lorentz_4: inconsistent" - else - invalid_arg "translate_lorentz_4: inconsistent" - | _ -> failwith "translate_lorentz_4: unexpected" - end - | [ ([L.Metric(mu,nu)], q) ] -> - let mu = pred mu and nu = pred nu in - begin match ThoList.complement [0; 1; 2; 3] [mu; nu] with - | [ka; la] -> - ([|p.(ka); p.(la); p.(mu); p.(nu)|], - Q.unit, Scalar2_Vector2 1) - | _ -> failwith "translate_lorentz_4: impossible" - end - | _ -> failwith "translate_lorentz_4" + let of_rational q = + QC.make q Q.null - let gauge_contraction1 c1 c2 = - let open Coupling in - match c1, c2 with - | (C_13_42, C_14_23) -> 1 - | (C_14_23, C_13_42) -> -1 - | _ -> invalid_arg "gauge_contraction1: unexpected" + let of_int n = + of_rational (Q.make n 1) - let gauge_contraction2 c1 c2 = - let open Coupling in - match c1, c2 with - | (C_12_34, C_14_23) -> 1 - | (C_14_23, C_12_34) -> -1 - | _ -> invalid_arg "gauge_contraction2: mismatch" + let translate_color_atom3 c = + let open UFOx.Color_Atom in + match c with + | Identity (i, j) -> Color.Delta3 (pair3_of_indices i j) + | Identity8 (a, b) -> Color.Delta8 (pair3_of_indices a b) + | T (a, i, j) -> Color.T (pair3_of_indices i j) + | F (a, b, c) -> Color.F + | Epsilon (i, j, k) | EpsilonBar (i, j, k) -> Color.Eps + | D (a, b, c) -> invalid_arg "d-tensor not supported yet" + | T6 (a, i, j) -> invalid_arg "T6-tensor not supported yet" + | K6 (i, j, k) -> invalid_arg "K6-tensor not supported yet" + | K6Bar (i, j, k) -> invalid_arg "K6-tensor not supported yet" - let gauge_contraction3 c1 c2 = - let open Coupling in - match c1, c2 with - | (C_12_34, C_13_42) -> 1 - | (C_13_42, C_12_34) -> -1 - | _ -> invalid_arg "gauge_contraction3: mismatch" + (* TODO: translate [lcc.Vertex.color] to [Color.vertex3], permuting + indices, if necessary. *) + let trivialize_color3 = function + | [ ([], q) ] -> (of_rational q, Color.Trivial3) + | color -> + Printf.eprintf + "translate_color3: trivializing '%s'\n" + (UFOx.Color.to_string color); + (QC.one, Color.Trivial3) - let quartet p = (p.(0), p.(1), p.(2), p.(3)) + let translate_color3_legacy color = + (QC.one, Color.Legacy3) - (* color flow basis: *) - let gauge4 eps = - let open Coupling in - Vector4 [(2*eps, C_13_42); (-1*eps, C_12_34); (-1*eps, C_14_23)] - - let translate_gauge_vertex4 model p t c g = - let open Coupling in - let g = - begin match g with - | [| [| Some g1; None; None |]; - [| None; Some g2; None |]; - [| None; None; Some g3 |] |] -> - if g1 = g2 && g2 = g3 then - g1 - else - invalid_arg "translate_gauge_vertex4: non-unital couplings" - | _ -> (* NB: [g] can be off-diagonal, if [t] or [c] are reordered! *) - invalid_arg "translate_gauge_vertex4: off diagonal couplings" - end in - match Array.map (translate_lorentz_4 model p) t with - | [| (p1, q1, Vector4 [ (1, contraction11); (-1, contraction12) ]); - (p2, q2, Vector4 [ (1, contraction21); (-1, contraction22) ]); - (p3, q3, Vector4 [ (1, contraction31); (-1, contraction32) ]) |] -> - if p1 = p2 && p2 = p3 then - begin match c with - | FF123 (q1', q2', q3', a, b, c, d) -> - let q1 = Q.mul q1 q1' - and q2 = Q.mul q2 q2' - and q3 = Q.mul q3 q3' in - if Q.abs q1 = Q.abs q2 && Q.abs q2 = Q.abs q3 then begin - let eps1 = gauge_contraction1 contraction11 contraction12 - and eps2 = gauge_contraction2 contraction21 contraction22 - and eps3 = gauge_contraction3 contraction31 contraction32 in - if eps1 = eps2 && eps2 = eps3 then - (* FIXME: why not [q1] instead of [Q.unit]??? *) - [(quartet p, gauge4 eps1, fractional_coupling g Q.unit)] - else - invalid_arg "translate_gauge_vertex4: unexpected permutations" - end else - invalid_arg "translate_gauge_vertex4: different couplings" - | FF132 (q1', q2', q3', a, b, c, d) -> - let q1 = Q.mul q1 q1' - and q2 = Q.mul q2 q2' - and q3 = Q.mul q3 q3' in - if Q.abs q1 = Q.abs q2 && Q.abs q2 = Q.abs q3 then begin - let eps1 = gauge_contraction1 contraction11 contraction12 - and eps2 = gauge_contraction3 contraction21 contraction22 - and eps3 = gauge_contraction2 contraction31 contraction32 in - if eps1 = eps2 && eps2 = eps3 then - (* FIXME: why not [q1] instead of [Q.unit]??? *) - [(quartet p, gauge4 eps1, fractional_coupling g Q.unit)] - else - invalid_arg "translate_gauge_vertex4: unexpected permutations" - end else - invalid_arg "translate_gauge_vertex4: different couplings" - | _ -> invalid_arg "translate_gauge_vertex4: wrong color" - end - else - invalid_arg "translate_gauge_vertex4: different particles" - | _ -> invalid_arg "translate_gauge_vertex4: unexpected Lorentz" + let translate_color3 = function + | [] -> invalid_arg "translate_color3: empty" + | [ ([], q) ] -> (of_rational q, Color.Trivial3) + | [ ([atom], q) ] -> (of_rational q, translate_color_atom3 atom) + | [ (atoms, q) ] as term -> + failwith + (Printf.sprintf + "translate_color3: nonatomic term '%s' not supported yet!" + (UFOx.Color.to_string term)) + | terms -> + failwith + (Printf.sprintf + "translate_color3: sum '%s' not supported yet!" + (UFOx.Color.to_string terms)) - let translate_coupling4 model p t c g = - let open Coupling in - let module L = UFOx.Lorentz_Atom in - match t, translate_color4 c, g with - | [| [ [], qt] |], C3 qc, [| [| Some g |] |] -> - [(quartet p, Scalar4 1, fractional_coupling g (Q.mul qt qc))] - | [| t |], qc, [| [| Some g |] |] -> - begin match translate_lorentz_4 model p t with - | p, q, t -> [(quartet p, t, fractional_coupling g q)] - end - | [| t |], qc, _-> - invalid_arg "translate_coupling4: too many constants" - | t, qc, g -> - translate_gauge_vertex4 model p t qc g + let translate_color3_mostly_legacy color = + let open UFOx.Color_Atom in + match color with + | [] -> invalid_arg "translate_color3_mostly_legacy: empty" + | [ ([], q) ] -> (of_rational q, Color.Trivial3) + | [ ([Identity (i, j)], q) ] -> + (of_rational q, Color.Delta3 (pair3_of_indices i j)) + | [ ([F (a, b, c)], q) ] -> + let eps = Combinatorics.sign [a;b;c] in + (QC.mul (of_int eps) (of_rational q), Color.F) + | _ -> (QC.one, Color.Legacy3) + + (* TODO: translate [lcc.Vertex.color] to [Color.vertex4], permuting + indices, if necessary. *) + let trivialize_color4 = function + | [ ([], q) ] -> (of_rational q, Color.Trivial4) + | color -> + Printf.eprintf + "translate_color4: trivializing '%s'\n" + (UFOx.Color.to_string color); + (QC.one, Color.Trivial4) + + let translate_color4_legacy color = + (QC.one, Color.Legacy4) + + let translate_color4 = function + | [] -> invalid_arg "translate_color4: empty" + | [ ([], q) ] -> (of_rational q, Color.Trivial4) + | [ ([atom], q) ] as term -> + failwith + (Printf.sprintf + "translate_color4: atomic terms '%s' not supported yet!" + (UFOx.Color.to_string term)) + | [ ([atom1; atom2], q) ] as term -> + failwith + (Printf.sprintf + "translate_color4: twoatomic terms '%s' not supported yet!" + (UFOx.Color.to_string term)) + | [ (atoms, q) ] as term -> + failwith + (Printf.sprintf + "translate_color4: multiatomic terms '%s' not supported yet!" + (UFOx.Color.to_string term)) + | terms -> + failwith + (Printf.sprintf + "translate_color4: sum '%s' not supported yet!" + (UFOx.Color.to_string terms)) + + let cmp_int i j = + if i < j then + -1 + else if i = j then + 0 + else + 1 - let lorentz_of_symbol model symbol = - try - SMap.find symbol model.lorentz - with - | Not_found -> invalid_arg ("lorentz_of_symbol: " ^ symbol) + (* FIXME: verify that this does the right thing! *) + (* FIXME: this will need to be generalized for vertices + with more than 4 legs! *) + let permutation_of_ff indices1 indices2 = + let eps1, indices1 = Combinatorics.sort_signed ~cmp:cmp_int indices1 + and eps2, indices2 = Combinatorics.sort_signed ~cmp:cmp_int indices2 in + let eps = eps1 * eps2 + and indices1, indices2 = + if ThoList.lexicographic ~cmp:cmp_int indices1 indices2 < 0 then + (indices1, indices2) + else + (indices2, indices1) in + match indices1, indices2 with + | [a; a1; a2], [a'; a3; a4] -> + if a > 0 || a' > 0 || a <> a' then + invalid_arg "permutation_of_ff: no summation index" + else if a1 < 1 || a3 < 1 then + invalid_arg "permutation_of_ff: to many summation indices" + else if eps < 0 then + Color.FF ((a1, a2), (a4, a3)) + else + Color.FF ((a1, a2), (a3, a4)) + | _ -> invalid_arg "permutation_of_ff" - let coupling_of_symbol model = function - | None -> None - | Some symbol -> - begin - try - Some (SMap.find symbol model.couplings) - with - | Not_found -> invalid_arg ("coupling_of_symbol: " ^ symbol) - end + let translate_color4_legacy_plus_ff color = + let open UFOx.Color_Atom in + match color with + | [ ([F (a, b, c); F (a', b', c')], q) ] as term -> + (of_rational q, permutation_of_ff [a;b;c] [a';b';c']) + | _ -> (QC.one, Color.Legacy4) + + (* Backstop \ldots *) + let translate_color3 = translate_color3_mostly_legacy + let translate_color4 = translate_color4_legacy_plus_ff + + let translate_coupling3_1 model p lcc = + let p = triplet p + and l = lcc.Vertex.lorentz + and s = spin_triplet model lcc.Vertex.lorentz + and c = name (coupling_of_symbol model lcc.Vertex.coupling) + and eps, col = translate_color3 lcc.Vertex.color in + (p, Coupling.UFO3 (eps, l, s, col), c) + + let translate_coupling3 model p lcc = + List.map (translate_coupling3_1 model p) lcc + + let translate_coupling4_1 model p lcc = + let p = quartet p + and l = lcc.Vertex.lorentz + and s = spin_quartet model lcc.Vertex.lorentz + and c = name (coupling_of_symbol model lcc.Vertex.coupling) + and eps, col = translate_color4 lcc.Vertex.color in + (p, Coupling.UFO4 (eps, l, s, col), c) + + let translate_coupling4 model p lcc = + List.map (translate_coupling4_1 model p) lcc let long_flavors = ref false module type Lookup = sig type f = private { flavors : flavor list; flavor_of_string : string -> flavor; flavor_of_symbol : string -> flavor; particle : flavor -> Particle.t; flavor_symbol : flavor -> string; conjugate : flavor -> flavor } type flavor_format = | Long | Decimal | Hexadecimal val flavor_format : flavor_format ref val of_model : t -> f end module Lookup : Lookup = struct type f = { flavors : flavor list; flavor_of_string : string -> flavor; flavor_of_symbol : string -> flavor; particle : flavor -> Particle.t; flavor_symbol : flavor -> string; conjugate : flavor -> flavor } type flavor_format = | Long | Decimal | Hexadecimal let flavor_format = ref Hexadecimal let conjugate_of_particle_array particles = Array.init (Array.length particles) (fun i -> let f' = Particle.conjugate particles.(i) in match ThoArray.match_all f' particles with | [i'] -> i' | [] -> invalid_arg ("no charge conjugate: " ^ f'.Particle.name) | _ -> invalid_arg ("multiple charge conjugates: " ^ f'.Particle.name)) let invert_flavor_array a = let table = SHash.create 37 in Array.iteri (fun i s -> SHash.add table s i) a; (fun name -> try SHash.find table name with | Not_found -> invalid_arg ("not found: " ^ name)) let digits base n = let rec digits' acc n = if n < 1 then acc else digits' (succ acc) (n / base) in if n < 0 then digits' 1 (-n) else if n = 0 then 1 else digits' 0 n let of_model model = let particle_array = Array.of_list (values model.particles) in let conjugate_array = conjugate_of_particle_array particle_array and name_array = Array.map (fun f -> f.Particle.name) particle_array and symbol_array = Array.of_list (keys model.particles) in let flavor_symbol f = begin match !flavor_format with | Long -> symbol_array.(f) | Decimal -> let w = digits 10 (Array.length particle_array - 1) in Printf.sprintf "%0*d" w f | Hexadecimal -> let w = digits 16 (Array.length particle_array - 1) in Printf.sprintf "%0*X" w f end in { flavors = ThoList.range 0 (Array.length particle_array - 1); flavor_of_string = invert_flavor_array name_array; flavor_of_symbol = invert_flavor_array symbol_array; particle = Array.get particle_array; flavor_symbol = flavor_symbol; conjugate = Array.get conjugate_array } end + (* \begin{dubious} + We appear to need to conjugate all flavors. Why??? + \end{dubious} *) let translate_vertices model tables = - List.fold_left (fun (v3, v4, vn) v -> - let p = Array.map tables.Lookup.flavor_of_symbol v.Vertex.particles - and g = - Array.map (Array.map (coupling_of_symbol model)) v.Vertex.couplings - and t = Array.map (lorentz_of_symbol model) v.Vertex.lorentz - and c = v.Vertex.color in - let t = Array.map (fun l -> l.Lorentz.structure) t in - match Array.length p with - | 3 -> (translate_coupling3 model p t c g @ v3, v4, vn) - | 4 -> (v3, translate_coupling4 model p t c g @ v4, vn) - | _ -> invalid_arg "UFO.Model.init: only 3- and 4-vertices for now!") + List.fold_left + (fun (v3, v4, vn) 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? *) + match Array.length p with + | 3 -> (translate_coupling3 model p lcc @ v3, v4, vn) + | 4 -> (v3, translate_coupling4 model p lcc @ v4, vn) + | _ -> invalid_arg "UFO.Model.init: only 3- and 4-vertices for now!") ([], [], []) (values model.vertices) 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 + | 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.Vectorspinor -> invalid_arg "UFO.Model.propagator_of_lorentz: Vectorspinor" | Coupling.Tensor_1 -> invalid_arg "UFO.Model.propagator_of_lorentz: Tensor_1" | Coupling.Tensor_2 -> invalid_arg "UFO.Model.propagator_of_lorentz: Tensor_2" | 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; vertices = physical_vertices } + { model with + particles = physical_particles; + particle_array = physical_particle_array; + vertices = physical_vertices } let whizard_constants = [ "ZERO" ] let filter_constants parameters = List.filter (fun p -> not (List.mem (String.uppercase p.Parameter.name) whizard_constants)) parameters let classify_parameters model = let compare_parameters p1 p2 = compare p1.Parameter.sequence p2.Parameter.sequence in let rec classify (input, derived) = function | [] -> (List.sort compare_parameters input, List.sort compare_parameters derived) | p :: rest -> classify (match p.Parameter.nature with | Parameter.Internal -> (input, p :: derived) | Parameter.External -> (p :: input, derived)) rest in classify ([], []) (filter_constants (values model.parameters)) 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 in let 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 (String c.UFO_Coupling.value), Coupling.I)) let translate_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 = [] } - 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 - (* 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 String.uppercase p.Particle.mass with | "ZERO" -> Coupling.Vector | _ -> Coupling.Massive_Vector end | s -> s + type state = + { directory : string; + model : t } + + let initialized = ref None + + let is_initialized_from dir = + match !initialized with + | None -> false + | Some state -> dir = state.directory + + let dump_raw = ref false + let init dir = let model = filter_unphysical (parse_directory dir) in if !dump_raw then dump model; let tables = Lookup.of_model model in let vertices () = translate_vertices model tables in let particle f = tables.Lookup.particle f in let lorentz f = lorentz_of_particle (particle f) in let gauge_symbol () = "?GAUGE?" in let constant_symbol s = s in let parameters = translate_parameters model in M.setup ~color:(fun f -> UFOx.Color.omega (particle f).Particle.color) ~pdg:(fun f -> (particle f).Particle.pdg_code) ~lorentz ~propagator:(fun f -> propagator_of_lorentz (lorentz f)) ~width:(fun f -> Coupling.Constant) ~goldstone:(fun f -> None) ~conjugate:tables.Lookup.conjugate ~fermion:(fun f -> fermion_of_lorentz (lorentz f)) ~vertices ~flavors:[("All Flavors", tables.Lookup.flavors)] ~parameters:(fun () -> parameters) ~flavor_of_string:tables.Lookup.flavor_of_string ~flavor_to_string:(fun f -> (particle f).Particle.name) ~flavor_to_TeX:(fun f -> (particle f).Particle.texname) ~flavor_symbol:tables.Lookup.flavor_symbol ~gauge_symbol ~mass_symbol:(fun f -> (particle f).Particle.mass) ~width_symbol:(fun f -> (particle f).Particle.width) ~constant_symbol; initialized := Some { directory = dir; model = model } let ufo_directory = ref Config.default_UFO_dir - let load_UFO () = + let load () = if is_initialized_from !ufo_directory then () else init !ufo_directory + let include_all_fusions = ref false + + 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 -> Sets.String.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 -> + (l'.Lorentz.name, spins, l'.Lorentz.structure) :: 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 + module Whizard : sig val write : unit -> unit end = struct let write_header dir = Printf.printf "# WHIZARD Model file derived from UFO directory\n"; Printf.printf "# '%s'\n\n" dir; Printf.printf "model \"%s\"\n\n" (Filename.basename dir) let write_input_parameters parameters = let open Parameter in Printf.printf "# Independent (input) Parameters\n"; List.iter (fun p -> Printf.printf "parameter %s = %s\n" p.name (value_to_numeric p.value)) parameters; Printf.printf "\n" let write_derived_parameters parameters = let open Parameter in Printf.printf "# Dependent (derived) Parameters\n"; List.iter (fun p -> Printf.printf "derived %s = %s\n" p.name (value_to_expr alpha_s_half p.value)) parameters; Printf.printf "\n" let write_particles particles = let open Particle in Printf.printf "# Particles\n"; Printf.printf "# NB: hypercharge assignments appear to be unreliable\n"; Printf.printf "# therefore we can't infer the isospin\n"; Printf.printf "# NB: parton-, gauge- & handedness are unavailable\n"; List.iter (fun p -> if not p.is_anti then begin Printf.printf "particle \"%s\" %d ### parton? gauge? left?\n" p.name p.pdg_code; Printf.printf " spin %s charge %s color %s ### isospin?\n" (UFOx.Lorentz.rep_to_string p.spin) (charge_to_string p.charge) (UFOx.Color.rep_to_string p.color); Printf.printf " name \"%s\"\n" p.name; if p.antiname <> p.name then Printf.printf " anti \"%s\"\n" p.antiname; Printf.printf " tex_name \"%s\"\n" p.texname; if p.antiname <> p.name then Printf.printf " tex_anti \"%s\"\n" p.antitexname; Printf.printf " mass %s width %s\n\n" p.mass p.width end) (values particles); Printf.printf "\n" let write_vertices model vertices = Printf.printf "# Vertices (for phasespace generation only)\n"; Printf.printf "# NB: particles should be sorted increasing in mass.\n"; Printf.printf "# This is NOT implemented yet!\n"; List.iter (fun v -> let particles = String.concat " " (List.map (fun s -> "\"" ^ (SMap.find s model.particles).Particle.name ^ "\"") (Array.to_list v.Vertex.particles)) in Printf.printf "vertex %s\n" particles) (values vertices); Printf.printf "\n" let write () = - load_UFO (); match !initialized with - | None -> failwith "UFO.Whizard.write: can't happen" + | 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_vertices model model.vertices; exit 0 end - let options = Options.create + let options = + Options.create [ ("UFO_dir", Arg.String (fun name -> ufo_directory := name), "UFO model directory (default: " ^ !ufo_directory ^ ")"); ("write_WHIZARD", Arg.Unit Whizard.write, "write the WHIZARD model file (required once per model)"); ("long_flavors", Arg.Unit (fun () -> Lookup.flavor_format := Lookup.Long), "write use the UFO flavor names instead of integers"); ("dump", Arg.Set dump_raw, "dump UFO model for debugging the parser (must come _before_ exec!)"); - ("exec", Arg.Unit load_UFO, + ("all_fusions", Arg.Set include_all_fusions, + "include all fusions in the fortran module"); + ("exec", Arg.Unit load, "load the UFO model files (required _before_ using particles names)"); ("help", Arg.Unit (fun () -> prerr_endline "..."), "print information on the model")] end +module type Fortran_Target = + sig + + val fusion2 : + Algebra.QC.t -> string -> Coupling.lorentz3 -> + string -> string -> string -> string -> string -> Coupling.fuse2 -> unit + val fusion3 : + Algebra.QC.t -> string -> Coupling.lorentz4 -> + string -> string -> string -> string -> string -> + string -> string -> Coupling.fuse3 -> unit + val fusionn : + Algebra.QC.t -> string -> Coupling.lorentzn -> + string -> string list -> string list -> Coupling.fusen -> unit + + val lorentz : + ?only:Sets.String.t -> Format_Fortran.formatter -> unit -> unit + + val lorentz_module : + ?only:Sets.String.t -> ?name:string -> + Format_Fortran.formatter -> unit -> unit + + end + +module Targets = + struct + + module Fortran : Fortran_Target = + struct + + open Format_Fortran + + let fusion2 = UFO_targets.Fortran.fusion2 + let fusion3 = UFO_targets.Fortran.fusion3 + let fusionn = UFO_targets.Fortran.fusionn + + let lorentz_functions ff fusions () = + List.iter + (fun (name, s, l) -> UFO_targets.Fortran.lorentz ff name s l) + fusions + + let lorentz ?only ff () = + lorentz_functions ff (Model.fusions ?only ()) () + + let lorentz_module ?only ?(name="omega_amplitude_ufo") ff () = + let printf fmt = fprintf ff fmt + and nl = pp_newline ff in + printf "module %s" name; nl (); + printf " use kinds"; nl (); + printf " use omega95"; nl (); + printf " implicit none"; nl (); + printf " private"; nl (); + let fusions = Model.fusions ?only () in + List.iter + (fun (name, _, _) -> printf " public :: %s" name; nl ()) + fusions; + UFO_targets.Fortran.eps4_g4_g44_decl ff (); + UFO_targets.Fortran.eps4_g4_g44_init ff (); + printf "contains"; nl (); + lorentz_functions ff (Model.fusions ?only ()) (); + printf "end module %s" name; nl (); + pp_flush ff () + + end + + end + module type Test = sig val example : unit -> unit val suite : OUnit.test end +(* \thocwmodulesection{Obsolete} + Kept around as a source of ideas. *) + +module Unused = + struct + + module Q = Algebra.Q + + let translate_color_atom c = + let open UFOx.Color_Atom in + match c with + | Identity (i, j) -> 1 + | Identity8 (a, b) -> 1 + | T (a, i, j) -> 1 + | F (a, b, c) -> Combinatorics.sign [a;b;c] + | D (a, b, c) -> invalid_arg "d-tensor not supported yet" + | Epsilon (i, j, k) -> invalid_arg "epsilon-tensor not supported yet" + | EpsilonBar (i, j, k) -> invalid_arg "epsilon-tensor not supported yet" + | T6 (a, i, j) -> invalid_arg "T6-tensor not supported yet" + | K6 (i, j, k) -> invalid_arg "K6-tensor not supported yet" + | K6Bar (i, j, k) -> invalid_arg "K6-tensor not supported yet" + + let translate_color3_1 c = + match c with + | [ ([], q) ] -> q + | [ ([c1], q) ] -> Q.mul q (Q.make (translate_color_atom c1) 1) + | [] -> invalid_arg "translate_color3_1: empty" + | _ -> invalid_arg "translate_color3_1: sums of tensors not supported yet" + + let translate_color3 = function + | [| c |] -> translate_color3_1 c + | c -> + invalid_arg + (Printf.sprintf + "translate_color3: #color structures: %d > 1" (Array.length c)) + + let translate_color3 _ = + Color.Trivial3 + + (* Move the smallest index first, using antisymmetry + in $a,b$ and $c,d$ as well as symmetry in $(ab)(cd)$: *) + let normalize_quartet a b c d = + let a0 = List.hd (List.sort compare [a; b; c; d]) in + if a0 = a then + (a, b, c, d) + else if a0 = b then + (b, a, d, c) + else if a0 = c then + (c, d, a, b) + else + (d, c, b, a) + + (* [FF_1 (q, a, b, c, d)] represents the tensor $q f_{abe}f_{ecd}$ + and we assume that [normalize_quartet] has been applied to the + indices. *) + type color4_1 = + | C3_1 of Q.t + | FF_1 of Q.t * int * int * int * int + + (* [FF123 (q1, q2, q3, a, b, c, d)] represents the tensor triple + $(q_1 f_{abe}f_{ecd}, q_2 f_{ace}f_{edb}, q_3 f_{ade}f_{ecb})$ + and [FF132 (q1, q2, q3, a, b, c, d)] the triple + $(q_1 f_{abe}f_{ecd}, q_2 f_{ade}f_{ecb}, q_3 f_{ace}f_{edb})$ *) + + type color4 = + | C3 of Q.t + | FF123 of Q.t * Q.t * Q.t * int * int * int * int + | FF132 of Q.t * Q.t * Q.t * int * int * int * int + + let q2s q = + match Q.to_ratio q with + | n, 1 -> string_of_int n + | n, d -> string_of_int n ^ "/" ^ string_of_int d + + let color4_to_string = function + | C3 (q) -> q2s q + | FF123 (q1, q2, q3, a, b, c, d) -> + Printf.sprintf + "[%s*f(%d,%d,-1)*f(-1,%d,%d); \ + %s*f(%d,%d,-1)*f(-1,%d,%d); \ + %s*f(%d,%d,-1)*f(-1,%d,%d)]" + (q2s q1) a b c d + (q2s q2) a c d b + (q2s q3) a d b c + | FF132 (q1, q2, q3, a, b, c, d) -> + Printf.sprintf + "[%s*f(%d,%d,-1)*f(-1,%d,%d); \ + %s*f(%d,%d,-1)*f(-1,%d,%d); \ + %s*f(%d,%d,-1)*f(-1,%d,%d)]" + (q2s q1) a b c d + (q2s q2) a d b c + (q2s q3) a c d b + + let translate_color4_1_1 c = + Q.make (translate_color_atom c) 1 + +(* Take two lists of three indices each, find exactly one common index, + check that it is a summation index (i.\,e. not positive) and return + the remaining four indices in normal order (see [normalize_quartet]) + together with the sign of the permutations. *) + let translate_color4_ff abc abc' = + match ThoList.common abc abc' with + | [] -> invalid_arg "translate_color4_ff: not summation index" + | [s] -> + if s >= 1 then + invalid_arg "translate_color4_ff: invalid summation index" + else + begin match (Combinatorics.sort_signed abc, + Combinatorics.sort_signed abc') with + | (eps, [_; b; c]), (eps', [_; b'; c']) -> + let a, b, c, d = normalize_quartet b c b' c' in + FF_1 (Q.make (eps * eps') 1, a, b, c, d) + | _ -> failwith "translate_color4_ff: can't happen" + end + | _ -> + invalid_arg "translate_color4_ff: multiple summation indices" + + exception Unsupported_Color_Atom_Pair of string + let unsupported_color_atom_pair s = + raise (Unsupported_Color_Atom_Pair s) + + let translate_color_atom_pair c1 c2 = + let open UFOx.Color_Atom in + match c1, c2 with + | Identity8 (_, _), _ | _, Identity8 (_, _) -> + unsupported_color_atom_pair "quartic 8-8-couplings" + | Identity (i, j), Identity (i', l') -> + unsupported_color_atom_pair "quartic 3-3bar-couplings" + | T (a, i, j), T (a', i', j') -> + unsupported_color_atom_pair "quartic 3-3bar-couplings" + | F (a, b, c), F (a', b', c') -> + translate_color4_ff [a; b; c] [a'; b'; c'] + | T (a, i, j), F (a', b', c') + | F (a', b', c'), T (a, i, j) -> + unsupported_color_atom_pair "quartic 8-8-3-3bar-couplings" + | Identity (i, j), T (a', i', l') + | T (a', i', l'), Identity (i, j) -> + invalid_arg "open index" + | Identity (i, j), F (a', b', c') + | F (a', b', c'), Identity (i, j) -> + invalid_arg "open index" + | D (a, b, c), _ | _, D (a, b, c) -> + unsupported_color_atom_pair "d-tensor" + | Epsilon (i, j, k), _ | _, Epsilon (i, j, k) + | EpsilonBar (i, j, k), _| _, EpsilonBar (i, j, k) -> + unsupported_color_atom_pair "epsilon-tensor" + | T6 (a, i, j), _ | _, T6 (a, i, j) -> + unsupported_color_atom_pair "T6-tensor" + | K6 (i, j, k), _ | _, K6 (i, j, k) + | K6Bar (i, j, k), _ | _, K6Bar (i, j, k) -> + unsupported_color_atom_pair "K6-tensor" + + let translate_color4_1 c = + match c with + | [ ([], q) ] -> C3_1 (q) + | [ ([c1], q) ] -> + C3_1 (Q.mul q (translate_color4_1_1 c1)) + | [ ([c1; c2], q) ] -> + begin + try + match translate_color_atom_pair c1 c2 with + | FF_1 (eps, a, b, c, d) -> FF_1 (Q.mul q eps, a, b, c, d) + | C3_1 (eps) -> C3_1 (Q.mul q eps) + with + | Unsupported_Color_Atom_Pair s -> + prerr_endline + ("warning: translate_color4: passed through: " ^ + "unsupported color atom pair: " ^ s); + C3_1 Q.unit + end + | _ -> invalid_arg "translate_color4_1: too many atoms" + +(*l +We can not handle color tensors on their own, because UFO +allows to exchange signs between color and Lorentz tensors. + +Indeed, the \texttt{FeynRulesSM} file has +\begin{verbatim} + 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 = [ 'Metric(1,4)*Metric(2,3) - Metric(1,3)*Metric(2,4)', + 'Metric(1,4)*Metric(2,3) - Metric(1,2)*Metric(3,4)', + 'Metric(1,3)*Metric(2,4) - Metric(1,2)*Metric(3,4)' ], + couplings = {(1,1):C.GC_12,(0,0):C.GC_12,(2,2):C.GC_12}) +\end{verbatim} +i.e. +\begin{verbatim} + f(-1,1,2)*f(3,4,-1) * (Metric(1,4)*Metric(2,3) - Metric(1,3)*Metric(2,4)) + + f(-1,1,3)*f(2,4,-1) * (Metric(1,4)*Metric(2,3) - Metric(1,2)*Metric(3,4)) + + f(-1,1,4)*f(2,3,-1) * (Metric(1,3)*Metric(2,4) - Metric(1,2)*Metric(3,4)) += + f(-1,1,2)*f(3,4,-1) * (Metric(1,4)*Metric(2,3) - Metric(1,3)*Metric(4,2)) + + f(-1,1,3)*f(4,2,-1) * (Metric(1,2)*Metric(3,4) - Metric(1,4)*Metric(3,2)) + + f(-1,1,4)*f(2,3,-1) * (Metric(1,3)*Metric(2,4) - Metric(1,2)*Metric(3,4)) +\end{verbatim} +*) + + let translate_color4 c = + match Array.map translate_color4_1 c with + | [| C3_1 (q) |] -> C3 q + | [| FF_1 (q1, a1, b1, c1, d1); + FF_1 (q2, a2, b2, c2, d2); + FF_1 (q3, a3, b3, c3, d3) |] -> + if Q.abs q1 = Q.abs q2 && Q.abs q2 = Q.abs q3 then + if a1 = a2 && a2 = a3 then + let bcd1 = [b1; c1; d1] + and bcd2 = [b2; c2; d2] + and bcd3 = [b3; c3; d3] in + let eps1 = Combinatorics.sign bcd1 in + let eps2, bcd2 = + let eps = Combinatorics.sign bcd2 in + if eps = eps1 then + (Q.make eps 1, bcd2) + else + (Q.make eps 1, [b2; d2; c2]) + and eps3, bcd3 = + let eps = Combinatorics.sign bcd3 in + if eps = eps1 then + (Q.make eps 1, bcd3) + else + (Q.make eps 1, [b3; d3; c3]) in + if bcd2 = [c1; d1; b1] then + if bcd3 = [d1; b1; c1] then + FF123 (q1, Q.mul eps2 q2, Q.mul eps3 q3, a1, b1, c1, d1) + else + invalid_arg "translate_color4: mismatched indices b, c, d" + else if bcd2 = [d1; b1; c1] then + if bcd3 = [c1; d1; b1] then + FF132 (q1, Q.mul eps2 q2, Q.mul eps3 q3, a1, b1, c1, d1) + else + invalid_arg "translate_color4: mismatched indices b, c, d" + else + invalid_arg "translate_color4: mismatched indices b, c, d" + else + invalid_arg "translate_color4: mismatched indices a" + else + invalid_arg "translate_color4: mismatched couplings" + | c -> + (Printf.eprintf + "warning: translate_color4: passed through #color structures: %d\n" + (Array.length c)); + C3 Q.unit + + let translate_color4 _ = + Color.Trivial4 + + end Index: trunk/omega/src/targets.ml =================================================================== --- trunk/omega/src/targets.ml (revision 8252) +++ trunk/omega/src/targets.ml (revision 8253) @@ -1,8265 +1,8256 @@ (* targets.ml -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner Fabian Bach (only parts of this file) Marco Sekulla (only parts of this file) Bijan Chokoufe Nejad (only parts of this file) So Young Shim WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the 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"] (* This is part of OCaml 4.01. *) let (|>) fn x = x fn let (@@) fn x = fn x (* 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} It would be nice to safe 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" + + | UFO3 (c, v, s, Color.Trivial3) -> + failwith "print_current: V3 (UFO3): not implemented yet" + + | UFO3 (c, v, s, _) -> + failwith "print_current: V3 (UFO3): unexpected color" + 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: V3: not implemented" + failwith "print_current: V4: not implemented" | Dim6_AHWW_DPB _ -> - failwith "print_current: V3: not implemented" + failwith "print_current: V4: not implemented" | Dim6_AHWW_DPW _ -> - failwith "print_current: V3: not implemented" + failwith "print_current: V4: not implemented" | Dim6_AHWW_DW _ -> - failwith "print_current: V3: not implemented" + failwith "print_current: V4: not implemented" | Dim6_Vector4_DW _ -> - failwith "print_current: V3: not implemented" + failwith "print_current: V4: not implemented" | Dim6_Vector4_W _ -> - failwith "print_current: V3: not implemented" + failwith "print_current: V4: not implemented" | Dim6_Scalar2_Vector2_D _ -> - failwith "print_current: V3: not implemented" + failwith "print_current: V4: not implemented" | Dim6_Scalar2_Vector2_DP _ -> - failwith "print_current: V3: not implemented" + failwith "print_current: V4: not implemented" | Dim6_HWWZ_DW _ -> - failwith "print_current: V3: not implemented" + failwith "print_current: V4: not implemented" | Dim6_HWWZ_DPB _ -> - failwith "print_current: V3: not implemented" + failwith "print_current: V4: not implemented" | Dim6_HWWZ_DDPW _ -> - failwith "print_current: V3: not implemented" + failwith "print_current: V4: not implemented" | Dim6_HWWZ_DPW _ -> - failwith "print_current: V3: not implemented" + failwith "print_current: V4: not implemented" | Dim6_AHHZ_D _ -> - failwith "print_current: V3: not implemented" + failwith "print_current: V4: not implemented" | Dim6_AHHZ_DP _ -> - failwith "print_current: V3: not implemented" + failwith "print_current: V4: not implemented" | Dim6_AHHZ_PB _ -> - failwith "print_current: V3: not implemented" + failwith "print_current: V4: not implemented" | Dim6_Scalar2_Vector2_PB _ -> - failwith "print_current: V3: not implemented" + failwith "print_current: V4: not implemented" | Dim6_HHZZ_T _ -> - failwith "print_current: V3: not implemented" + failwith "print_current: V4: not implemented" + + | UFO4 (c, v, s, Color.Trivial4) -> + failwith "print_current: V4 (UFO4): not implemented yet" + + | UFO4 (c, v, s, _) -> + failwith "print_current: V4 (UFO4): unexpected color" + 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 -> failwith "Targets.VM: running width not available" | 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!" 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 : lorentz -> 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= function | 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: *) - -(* Default function to output spaces (copied from \texttt{format.ml}). *) - let blank_line = String.make 80 ' ' - let rec display_blanks oc n = - if n > 0 then - if n <= 80 then - output oc blank_line 0 n - else begin - output oc blank_line 0 80; - display_blanks oc (n - 80) - end - -(* Default function to output new lines (copied from \texttt{format.ml}). *) - let display_newline oc () = - output oc "\n" 0 1 - -(* [current_continuation_line] - \begin{itemize} - \item $\le0$: not continuing: print a straight newline, - \item $>0$: continuing: append [" &"] until we run up to [!continuation_lines]. - NB: [!continuation_lines < 0] means \emph{unlimited} continuation lines. - \end{itemize} *) - - let current_continuation_line = ref 1 - exception Continuation_Lines of int - - let fortran_newline oc () = - if !current_continuation_line > 0 then begin - if !continuation_lines >= 0 && !current_continuation_line > !continuation_lines then - raise (Continuation_Lines !current_continuation_line) - else begin - output oc " &" 0 2; - incr current_continuation_line - end - end; - display_newline oc () - - let nl () = - current_continuation_line := 0; - print_newline (); - current_continuation_line := 1 - -(* Make a formatter with default functions to output spaces and new lines. *) - let setup_fortran_formatter width oc = - set_all_formatter_output_functions - ~out:(output oc) - ~flush:(fun () -> flush oc) - ~newline:(fortran_newline oc) - ~spaces:(display_blanks oc); - set_margin (width - 2) + 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:decl wf ^ "_X" ^ string_of_int i + variable ~decl wf ^ "_X" ^ string_of_int i let multiple_variable ?(decl = false) amplitude dictionary wf = try - format_multiple_variable ~decl:decl wf (dictionary amplitude wf) + 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:decl wf) + (format_multiple_variable ~decl wf) (ThoList.range 1 (multiplicity wf)) with - | Not_found -> [variable ~decl:decl wf] + | 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 -> sprintf "cmplx (0.0_%s, 1.0_%s, kind=%s)" !kind !kind !kind | Const c when c < 0 -> sprintf "(%d.0_%s)" c !kind | Const c -> sprintf "%d.0_%s" c !kind | _ -> invalid_arg "format_constant" let rec eval_parameter' = function | I -> printf "cmplx (0.0_%s,@ 1.0_%s,@ kind=%s)" !kind !kind !kind | Const c when c < 0 -> printf "(%d.0_%s)" c !kind | Const c -> printf "%d.0_%s" c !kind | 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; 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 ")" | Atan2 (y, x) -> printf "@,atan2 ("; eval_parameter' y; printf ",@ "; eval_parameter' x; printf ")" + | Exp x -> printf "@,exp ("; eval_parameter' x; printf ")" | Conj x -> printf "@,conjg ("; 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 | Const _ -> 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) -> + | 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 | Sin e | Cos e | Tan e | Cot e | Conj e -> + | Sqrt e | Sin e | Cos e | Tan e | Cot e | Conj e | Exp 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 = - setup_fortran_formatter !line_length oc; + 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 "contains"; 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 + | UFO3 (c', v, s, Color.Legacy3) + | UFO3 (c', v, s, Color.Trivial3) -> + UFO.Targets.Fortran.fusion2 c' v s c wf1 p1 wf2 p2 fusion + + | UFO3 (c', v, s, _) -> + failwith "print_current: nontrivial color structure" (* 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. *) | 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 + | UFO4 (c', v, s, Color.Legacy4) + | UFO4 (c', v, s, Color.Trivial4) -> + UFO.Targets.Fortran.fusion3 c' v s c wf1 p1 wf2 p2 wf3 p3 fusion + + | UFO4 (c', v, s, _) -> + failwith "print_current: nontrivial color structure" + | 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 - | 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 (* \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 - | Vn (_, _, _) -> - invalid_arg "Targets.print_current: n-ary fusion" + | Vn (UFOn (c, v, s, Color.Legacy), fusion, constant) + | Vn (UFOn (c, v, s, Color.Trivial), fusion, constant) -> + 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 + UFO.Targets.Fortran.fusionn c v s g wfs ps fusion + + | Vn (UFOn (c, v, s, _), fusion, constant) -> + 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 -> failwith "Targets.Fortran: running width not yet available" | 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 "(" 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 "(" 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 "(" | _ -> 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 let print_braket amplitude dictionary name braket = let bra = F.bra braket and ket = F.ket braket in printf " @[<2>%s = %s@, + " name name; begin match Fermions.reverse_braket (CM.lorentz (F.flavor bra)) with | false -> printf "%s*(@," (multiple_variable amplitude dictionary bra); List.iter (print_current amplitude dictionary) ket; printf ")" | true -> printf "(@,"; List.iter (print_current amplitude dictionary) ket; printf ")*%s" (multiple_variable amplitude dictionary bra) end; nl () (* \begin{equation} \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 = 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 = printf " @[<2>integer, dimension(n_cindex,n_prt,n_cflow), save%s :: table_color_flows" protected; nl (); 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) let print_ghost_flags_table tuples = 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) 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 (); 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 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 = 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 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"; 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_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 (); printf " n = size (table_color_flows, dim=1)"; nl (); 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 (); printf " n = size (table_color_flows, dim=3)"; nl (); 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 (); printf " yorn = hel_is_allowed(hel) .and. "; printf "flv_col_is_allowed(flv,col)"; nl (); 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 (); 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; 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 (); 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 - setup_fortran_formatter line_length channel; + 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"; "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 (!module_name ^ "_ufo"); 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) + (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 () = 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_inquiry_function_openmp (); print_color_flows (); print_color_factors (); print_dispatch_functions (); nl (); - current_continuation_line := 0; + (* 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); - current_continuation_line := 1; + 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) + + (* FIXME: can be retired starting from O'Caml 4.02.0! *) + let vset_of_list list = + List.fold_right VSet.add list VSet.empty + + 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.V3 (Coupling.UFO3 (_, v, _, _), _, _) + | Coupling.V4 (Coupling.UFO4 (_, v, _, _), _, _) + | Coupling.Vn (Coupling.UFOn (_, 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 (); 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 - setup_fortran_formatter !line_length oc; + 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 () 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 - setup_fortran_formatter !line_length oc; + 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 (); 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 - + [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 - setup_fortran_formatter !line_length oc; + 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; + UFO.Targets.Fortran.lorentz_module + ~only:(ufo_fusions_used amplitudes) + ~name:(!module_name ^ "_ufo") + (Format_Fortran.formatter_of_out_channel oc) (); 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 _ = 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/fortran_unit.ml =================================================================== --- trunk/omega/src/fortran_unit.ml (revision 0) +++ trunk/omega/src/fortran_unit.ml (revision 8253) @@ -0,0 +1,26 @@ +(* fortran_unit.ml -- + + Copyright (C) 2019- by + + Wolfgang Kilian + Thorsten Ohl + Juergen Reuter + + WHIZARD is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + WHIZARD is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) + +let _ = + ignore (OUnit.run_test_tt_main Format_Fortran.Test.suite); + print_newline (); + exit 0 Index: trunk/omega/src/color.ml =================================================================== --- trunk/omega/src/color.ml (revision 8252) +++ trunk/omega/src/color.ml (revision 8253) @@ -1,358 +1,426 @@ (* color.ml -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) (* \thocwmodulesection{Quantum Numbers} *) type t = | Singlet | SUN of int | AdjSUN of int let conjugate = function | Singlet -> Singlet | SUN n -> SUN (-n) | AdjSUN n -> AdjSUN n 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 (* \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 end module Flow (* [: Flow] *) = struct type color = | Lines of int * int | Ghost type t = color list * color list let rank cflow = 2 (* \thocwmodulesubsection{Constructors} *) let ghost () = Ghost let of_list = function | [c1; c2] -> Lines (c1, c2) | _ -> invalid_arg "Color.Flow.of_list: num_lines != 2" let to_list = function | Lines (c1, c2) -> [c1; c2] | Ghost -> [0; 0] 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 | Lines _ -> 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 conjugate = function | Lines (c1, c2) -> Lines (-c2, -c1) | 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) let square f1 f2 = let rec square' acc f1' f2' = match f1', f2' with | [], [] -> Square (List.rev acc) | _, [] | [], _ -> Mismatch | Ghost :: rest1, Ghost :: rest2 -> square' acc rest1 rest2 | Lines (0, 0) :: rest1, Lines (0, 0) :: rest2 -> square' acc rest1 rest2 | Lines (0, c1') :: rest1, Lines (0, c2') :: rest2 -> square' ((c1', c2') :: acc) rest1 rest2 | Lines (c1, 0) :: rest1, Lines (c2, 0) :: rest2 -> square' ((c1, c2) :: acc) rest1 rest2 | Lines (0, _) :: _, _ | _ , Lines (0, _) :: _ | Lines (_, 0) :: _, _ | _, Lines (_, 0) :: _ -> Mismatch | Lines (_, _) :: _, Ghost :: _ | Ghost :: _, Lines (_, _) :: _ -> Mismatch | Lines (c1, c1') :: rest1, Lines (c2, c2') :: rest2 -> square' ((c1', c2') :: (c1, c2) :: acc) rest1 rest2 in square' [] (cross_out f1) (cross_out f2) (* 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 = let rec square2' acc f1' f2' = match f1', f2' with | [], [] -> Square (List.rev acc) | _, [] | [], _ -> Mismatch | Ghost :: rest1, Ghost :: rest2 -> square2' acc rest1 rest2 | Lines (0, 0) :: rest1, Lines (0, 0) :: rest2 -> square2' acc rest1 rest2 | Lines (0, _) :: rest1, Lines (0, _) :: rest2 | Lines (_, 0) :: rest1, Lines (_, 0) :: rest2 -> square2' acc rest1 rest2 | Lines (0, _) :: _, _ | _ , Lines (0, _) :: _ | Lines (_, 0) :: _, _ | _, Lines (_, 0) :: _ -> Mismatch | Lines (_, _) :: _, Ghost :: _ | Ghost :: _, Lines (_, _) :: _ -> Mismatch | Lines (c1, c1') :: rest1, Lines (c2, c2') :: rest2 -> square2' (((c1, c1'), (c2, c2')) :: acc) rest1 rest2 in square2' [] (cross_out f1) (cross_out 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) 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{Color Structure of Vertices } *) + +type pair3 = + | P3_12 | P3_23 | P3_31 + | P3_21 | P3_32 | P3_13 + +type vertex3 = + | Legacy3 + | Trivial3 + | Delta3 of pair3 + | Delta8 of pair3 + | T of pair3 + | F + | Eps + +type pair4 = + | P4_12 + | P4_13 + | P4_14 + | P4_23 + | P4_24 + | P4_34 + +type triplet4 = + | P4_123 + | P4_234 + | P4_341 + | P4_412 + +type cyclic4 = + | C4_234 + | C4_342 + | C4_423 + +type vertex4 = + | Legacy4 + | Trivial4 + | Delta13 of pair4 + | Delta18 of pair4 + | Delta38 of pair4 + | Delta33 of cyclic4 + | Delta88 of cyclic4 + | TT of cyclic4 + | FF of (int * int) * (int * int) + | TF of pair4 + | T4 of triplet4 + | F4 of triplet4 + | Eps4 of triplet4 + +let signed_order_pair (a, b as p) = + if a < b then + (1, p) + else + (-1, (b, a)) + +(* Use the symmetries of $f_{abe}f_{cde}$ to bring the indices + in a canonical oder with $a + Thorsten Ohl + Juergen Reuter + + WHIZARD is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + WHIZARD is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) + +let default_width = 80 + +let max_clines = ref (-1) (* 255 *) +exception Continuation_Lines of int + +(* Fortran style line continuation: *) + +type formatter = + { formatter : Format.formatter; + mutable current_cline : int; + mutable width : int } + +let formatter_of_formatter ?(width=default_width) ff = + { formatter = ff; + current_cline = 1; + width = width } + +(* Default function to output new lines. *) +let pp_output_function ff = + fst (Format.pp_get_formatter_output_functions ff.formatter ()) + +(* Default function to output spaces (copied from \texttt{format.ml}). *) +let blank_line = String.make 80 ' ' +let rec pp_display_blanks ff n = + if n > 0 then + if n <= 80 then + pp_output_function ff blank_line 0 n + else begin + pp_output_function ff blank_line 0 80; + pp_display_blanks ff (n - 80) + end + +let pp_display_newline ff = + pp_output_function ff "\n" 0 1 + +(* [ff.current_cline] + \begin{itemize} + \item $\le0$: not continuing: print a straight newline, + \item $>0$: continuing: append [" &"] until we run up to [!max_clines]. + NB: [!max_clines < 0] means \emph{unlimited} continuation lines. + \end{itemize} *) + +let pp_switch_line_continuation ff = function + | false -> ff.current_cline <- 0 + | true -> ff.current_cline <- 1 + +let pp_fortran_newline ff () = + if ff.current_cline > 0 then + begin + if !max_clines >= 0 && ff.current_cline > !max_clines then + raise (Continuation_Lines ff.current_cline) + else + begin + pp_output_function ff " &" 0 2; + ff.current_cline <- succ ff.current_cline + end + end; + pp_display_newline ff + +let pp_newline ff () = + pp_switch_line_continuation ff false; + Format.pp_print_newline ff.formatter (); + pp_switch_line_continuation ff true + +(* Make a formatter with default functions to output spaces and new lines. *) + +(*i +let unsafe_output oc s i j = + try + output oc s i j + with + | _ -> Printf.eprintf "unsafe_output: '%s'\n" s +i*) + +let pp_setup ff = + let out, flush = + Format.pp_get_formatter_output_functions ff.formatter () in + Format.pp_set_all_formatter_output_functions + ff.formatter ~out ~flush + ~newline:(pp_fortran_newline ff) ~spaces:(pp_display_blanks ff); + Format.pp_set_margin ff.formatter (ff.width - 2) + +(* This is bit of a headache, since [out_indent] was added to + [type formatter_out_functions] in version 4.06 in an incompatible + change. *) + +(*i + let setup width oc = + let formatter_out_functions = get_formatter_out_functions () in + set_formatter_out_functions + { formatter_out_functions with + out_string = output oc; + out_flush = (fun () -> flush oc); + out_newline = fortran_newline oc; + out_spaces = display_blanks oc }; + set_margin (width - 2) + i*) + +let std_formatter = + let ff = formatter_of_formatter Format.std_formatter in + pp_setup ff; + ff + +let formatter_of_out_channel ?(width=default_width) oc = + let ff = formatter_of_formatter ~width (Format.formatter_of_out_channel oc) in + pp_setup ff; + ff + +let formatter_of_buffer ?(width=default_width) b = + let ff = + { formatter = Format.formatter_of_buffer b; + current_cline = 1; + width = width } in + pp_setup ff; + ff + +let pp_set_formatter_out_channel ff ?(width=default_width) oc = + Format.pp_set_formatter_out_channel ff.formatter oc; + ff.width <- width; + pp_setup ff + +let set_formatter_out_channel ?(width=default_width) oc = + Format.pp_set_formatter_out_channel std_formatter.formatter oc; + std_formatter.width <- width; + pp_setup std_formatter + +let fprintf ff fmt = Format.fprintf ff.formatter fmt +let pp_flush ff = Format.pp_print_flush ff.formatter + +let printf fmt = fprintf std_formatter fmt +let newline = pp_newline std_formatter +let flush = pp_flush std_formatter +let switch_line_continuation = pp_switch_line_continuation std_formatter + +module Test = + struct + + open OUnit + + let input_line_opt ic = + try + Some (input_line ic) + with + | End_of_file -> None + + let read_lines ic = + let rec read_lines' acc = + match input_line_opt ic with + | Some line -> read_lines' (line :: acc) + | None -> List.rev acc + in + read_lines' [] + + let lines_of_file filename = + let ic = open_in filename in + let lines = read_lines ic in + close_in ic; + lines + + let equal_or_dump_lines lhs rhs = + if lhs = rhs then + true + else + begin + Printf.printf "Unexpected output:\n"; + List.iter (Printf.printf "< %s\n") lhs; + List.iter (Printf.printf "> %s\n") rhs; + false + end + + let format_and_compare f expected () = + bracket_tmpfile + ~prefix:"omega-" ~suffix:".f90" + (fun (name, oc) -> + (* There can be something left in the queue from [OUnit]! *) + Format.print_flush (); + f oc; + close_out oc; + (* [OUnit] uses [Format.printf]! *) + Format.set_formatter_out_channel stdout; + assert_bool "" (equal_or_dump_lines expected (lines_of_file name))) + () + + let suite = + "Format_Fortran" >::: + [ "formatter_of_out_channel" >:: + format_and_compare + (fun oc -> + let ff = formatter_of_out_channel ~width:20 oc in + let nl = pp_newline ff in + List.iter + (fprintf ff) + ["@[<2>lhs = rhs"; + "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; + "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"]; + nl ()) + [ "lhs = rhs + rhs &"; + " + rhs + rhs &"; + " + rhs + rhs &"; + " + rhs + rhs &"; + " + rhs + rhs &"; + " + rhs" ]; + + "formatter_of_buffer" >:: + format_and_compare + (fun oc -> + let buffer = Buffer.create 1024 in + let ff = formatter_of_buffer ~width:20 buffer in + let nl = pp_newline ff in + List.iter + (fprintf ff) + [" @[<2>lhs = rhs"; + "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; + "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"]; + nl (); + pp_flush ff (); + let ff' = formatter_of_out_channel ~width:20 oc in + fprintf ff' "do mu = 0, 3"; pp_newline ff' (); + fprintf ff' "%s" (Buffer.contents buffer); + fprintf ff' "end do"; + pp_newline ff' ()) + [ "do mu = 0, 3"; + " lhs = rhs + rhs &"; + " + rhs + rhs &"; + " + rhs + rhs &"; + " + rhs + rhs &"; + " + rhs + rhs &"; + " + rhs"; + "end do" ]; + + "formatter_of_out_channel+indentation" >:: + format_and_compare + (fun oc -> + let ff = formatter_of_out_channel ~width:20 oc in + let nl = pp_newline ff in + List.iter + (fprintf ff) + [" @[<4>lhs = rhs"; + "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; + "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"]; + nl ()) + [ " lhs = rhs + rhs &"; + " + rhs + rhs &"; + " + rhs + rhs &"; + " + rhs + rhs &"; + " + rhs + rhs &"; + " + rhs" ]; + + "set_formatter_out_channel" >:: + format_and_compare + (fun oc -> + let nl = newline in + set_formatter_out_channel ~width:20 oc; + List.iter + printf + ["@[<2>lhs = rhs"; + "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; + "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"; "@ + rhs"]; + nl ()) + [ "lhs = rhs + rhs &"; + " + rhs + rhs &"; + " + rhs + rhs &"; + " + rhs + rhs &"; + " + rhs + rhs &"; + " + rhs" ]; ] + + end Index: trunk/omega/src/thoArray.ml =================================================================== --- trunk/omega/src/thoArray.ml (revision 8252) +++ trunk/omega/src/thoArray.ml (revision 8253) @@ -1,246 +1,302 @@ (* thoArray.ml -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) 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=Pervasives.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" 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_find_first; + [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/color.mli =================================================================== --- trunk/omega/src/color.mli (revision 8252) +++ trunk/omega/src/color.mli (revision 8253) @@ -1,82 +1,156 @@ (* color.mli -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) (* \thocwmodulesection{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 val conjugate : t -> t val compare : t -> t -> int (* \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 (* 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 val factor : t -> t -> factor val zero : factor end module Flow : Flow -(*i - * Local Variables: - * mode:caml - * indent-tabs-mode:nil - * page-delimiter:"^(\\* .*\n" - * End: -i*) +(* \thocwmodulesection{Color Structure of Vertices } *) + +(* In order for the [Colorize]r to work on fusions, we must + permit to choose any permutation of the color tensors. *) + +(* Since $f_{a_1a_2a_3}$ and $\epsilon_{i_1i_2i_3}$ are totally + antisymmetric, we can take care of the permutations with a sign. + + For the other invariant tensors of rank $\le 3$, it suffices + to specify a pair, which is symmetric in the case of the adjoint + representation, but \emph{not} in the case of $N\otimes\bar N$. + We can however disambiguate the order in the latter case by + looking at the color representation of of the particles involved. *) + +(* TODO: support $d_{abc}$. *) + +type pair3 = + | P3_12 | P3_23 | P3_31 + | P3_21 | P3_32 | P3_13 + +type vertex3 = + | Legacy3 (* only for debugging *) + | Trivial3 + | Delta3 of pair3 (* $\delta_{\bar\imath_2i_3}$ *) + | Delta8 of pair3 (* $\delta^{a_2a_3}$ *) + | T of pair3 (* $T^{a_1}_{\bar\imath_2i_3}$ *) + | F (* $f^{a_1a_2a_3}$ *) + | Eps (* $\epsilon_{i_2i_3i_4}$ + and $\epsilon_{\bar\imath_2\bar\imath_3\bar\imath_4}$ *) + +(* For invariant tensors of rank $\le 4$, there are more + possibilities. We can choose a pair, which is equivalent + to choosing two pairs, as long as the order is irrelevant + or can be recovered. *) + +type pair4 = + | P4_12 + | P4_13 + | P4_14 + | P4_23 + | P4_24 + | P4_34 + +(* We can choose a triplet. *) + +type triplet4 = + | P4_123 + | P4_234 + | P4_341 + | P4_412 + +(* We can choose a cyclic permutation of three indices, when the + choice of the first index is irrelevant by symmetry. *) + +type cyclic4 = + | C4_234 + | C4_342 + | C4_423 + +type vertex4 = + | Legacy4 (* only for debugging *) + | Trivial4 + | Delta13 of pair4 (* $\delta_{\bar\imath_3i_4}$ *) + | Delta18 of pair4 (* $\delta^{a_3a_4}$ *) + | Delta38 of pair4 (* $\delta_{\bar\imath_1i_2}\delta^{a_3a_4}$ *) + | Delta33 of cyclic4 (* $\delta_{\bar\imath_1i_2}\delta_{\bar\imath_3i_4}$ *) + | Delta88 of cyclic4 (* $\delta^{a_1a_2}\delta^{a_3a_4}$ *) + | TT of cyclic4 (* $T^a_{\bar\imath_1i_2}T^a_{\bar\imath_3i_4}$ *) + | FF of (int * int) * (int * int) (* $f^{aa_1a_2}f^{aa_3a_4}$ *) + | TF of pair4 (* $T^a_{\bar\imath_1i_2}f^{aa_3a_4}$ *) + | T4 of triplet4 (* $T^{a_2}_{\bar\imath_3i_4}$ *) + | F4 of triplet4 (* $f^{a_2a_3a_4}$ *) + | Eps4 of triplet4 (* $\epsilon_{i_2i_3i_4}$ + and $\epsilon_{\bar\imath_2\bar\imath_3\bar\imath_4}$ *) + +type vertex = + | Legacy (* only for debugging *) + | Trivial + +val canonicalize_ff : + (int * int) * (int * int) -> int * ((int * int) * (int * int)) Index: trunk/omega/src/omega.ml =================================================================== --- trunk/omega/src/omega.ml (revision 8252) +++ trunk/omega/src/omega.ml (revision 8253) @@ -1,663 +1,695 @@ (* omega.ml -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) let (<<) f g x = f (g x) let (>>) f g x = g (f x) module P = Momentum.Default module P_Whizard = Momentum.DefaultW module type T = sig val main : unit -> unit type flavor val diagrams : flavor -> flavor -> flavor list -> ((flavor * Momentum.Default.t) * (flavor * Momentum.Default.t, flavor * Momentum.Default.t) Tree.t) list end module Make (Fusion_Maker : Fusion.Maker) (Target_Maker : Target.Maker) (M : Model.T) = struct module CM = Colorize.It(M) type flavor = M.flavor module Proc = Process.Make(M) (* \begin{dubious} We must have initialized the vertices \emph{before} applying [Fusion_Maker], at least if we want to continue using the vertex cache! \end{dubious} *) (* \begin{dubious} NB: this causes the constant initializers in [Fusion_Maker] more than once. Such side effects must be avoided if the initializers involve expensive computations. \emph{Relying on the fact that the functor will be called only once is not a good idea!} \end{dubious} *) module F = Fusion_Maker(P)(M) module CF = Fusion.Multi(Fusion_Maker)(P)(M) module T = Target_Maker(Fusion_Maker)(P)(M) module W = Whizard.Make(Fusion_Maker)(P)(P_Whizard)(M) module C = Cascade.Make(M)(P) + module VSet = + Set.Make (struct type t = F.constant Coupling.t let compare = compare end) + + (* FIXME: can be retired starting from O'Caml 4.02.0! *) + let vset_of_list list = + List.fold_right VSet.add list VSet.empty; + (* For the phase space, we need asymmetric DAGs. HACK: since we will not use this to compute amplitudes, there's no need to supply the proper statistics module and we may assume Dirac fermions. HACK: for the phase space, we should be able to work on the uncolored model. *) module PHS = Fusion.Helac(struct let max_arity () = pred (M.max_degree ()) end)(P)(M) (* Form a ['a list] from a ['a option array], containing the elements that are not [None] in order. *) let opt_array_to_list a = let rec opt_array_to_list' acc i a = if i < 0 then acc else begin match a.(i) with | None -> opt_array_to_list' acc (pred i) a | Some x -> opt_array_to_list' (x :: acc) (pred i) a end in opt_array_to_list' [] (Array.length a - 1) a (* Return a list of [CF.amplitude list]s, corresponig to the diagrams for a specific color flow for each flavor combination. *) let amplitudes_by_flavor amplitudes = List.map opt_array_to_list (Array.to_list (CF.process_table amplitudes)) (* \begin{dubious} If we plan to distiguish different couplings later on, we can no long map all instances of [coupling option] in the tree to [None]. In this case, we will need to normalize different fusion orders [Coupling.fuse2], [Coupling.fuse3] or [Coupling.fusen], because they would otherwise lead to inequivalent diagrams. Unfortunately, this stuff packaged deep in [Fusion.Tagged_Coupling]. \end{dubious} *) (*i let strip_fuse' = function | Coupling.V3 (v, f, c) -> Coupling.V3 (v, Coupling.F12, c) | Coupling.V4 (v, f, c) -> Coupling.V4 (v, Coupling.F123, c) | Coupling.Vn (v, f, c) -> Coupling.Vn (v, [], c) let strip_fuse = function | Some c -> Some (strip_fuse' c) | None -> None i*) (* \begin{dubious} The [Tree.canonicalize] below should be necessary to remove topologically equivalent duplicates. \end{dubious} *) (* Take a [CF.amplitude list] assumed to correspond to the same external states after stripping the color and return a pair of the list of external particles and the corresponding Feynman diagrams without color. *) let wf1 amplitude = match F.externals amplitude with | wf :: _ -> wf | [] -> failwith "Omega.forest_sans_color: no external particles" let uniq l = ThoList.uniq (List.sort compare l) let forest_sans_color = function | amplitude :: _ as amplitudes -> let externals = F.externals amplitude in let prune_color wf = (F.flavor_sans_color wf, F.momentum_list wf) in let prune_color_and_couplings (wf, c) = (prune_color wf, None) in (List.map prune_color externals, uniq (List.map (fun t -> Tree.canonicalize (Tree.map prune_color_and_couplings prune_color t)) (ThoList.flatmap (fun a -> F.forest (wf1 a) a) amplitudes))) | [] -> ([], []) let dag_sans_color = function | amplitude :: _ as amplitudes -> let prune_color wf = (F.flavor_sans_color wf, F.momentum_list wf) in let prune_color_and_couplings (wf, c) = (prune_color wf, None) in 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) type cache_mode = | Cache_Default | Cache_Initialize of string let cache_option = ref Cache_Default let unphysical_polarization = ref None (* \thocwmodulesection{Main Program} *) let main () = (* Delay evaluation of [M.external_flavors ()]! *) let usage () = "usage: " ^ Sys.argv.(0) ^ " [options] [" ^ String.concat "|" (List.map M.flavor_to_string (ThoList.flatmap snd (M.external_flavors ()))) ^ "]" and rev_scatterings = ref [] and rev_decays = ref [] and cascades = ref [] and checks = ref [] and output_file = ref None and print_forest = ref false and template = ref false and diagrams_all = ref None and diagrams_sans_color = ref None and diagrams_color_only = ref None and diagrams_LaTeX = ref false and quiet = ref false and write = ref true and params = ref false and poles = ref false and dag_out = ref None and dag0_out = ref None and phase_space_out = ref None in Options.parse (Options.cmdline "-target:" T.options @ Options.cmdline "-model:" M.options @ Options.cmdline "-fusion:" CF.options @ ThoList.flatmap debug ["a", "arguments", T.All, checks; "n", "# of input arguments", T.Arguments, checks; "m", "input momenta", T.Momenta, checks; "g", "internal Ward identities", T.Gauge, checks] @ [("-o", Arg.String (fun s -> output_file := Some s), "file write to given file instead of /dev/stdout"); ("-scatter", Arg.String (fun s -> rev_scatterings := s :: !rev_scatterings), "expr in1 in2 -> out1 out2 ..."); ("-scatter_file", Arg.String (fun s -> rev_scatterings := read_lines_rev s @ !rev_scatterings), "name each line: in1 in2 -> out1 out2 ..."); ("-decay", Arg.String (fun s -> rev_decays := s :: !rev_decays), "expr in -> out1 out2 ..."); ("-decay_file", Arg.String (fun s -> rev_decays := read_lines_rev s @ !rev_decays), "name each line: in -> out1 out2 ..."); ("-cascade", Arg.String (fun s -> cascades := s :: !cascades), "expr select diagrams"); ("-initialize", Arg.String (fun s -> cache_option := Cache_Initialize s), "dir precompute lookup tables and store them in directory"); ("-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 = match !output_file with | None -> stdout | Some name -> open_out name 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} *) 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 -> let selectors = let fin, fout = List.hd processes in C.to_selectors (C.of_string_list (List.length fin + List.length fout) !cascades) in let amplitudes = try begin match F.check_charges () with | [] -> () | violators -> let violator_strings = String.concat ", " (List.map (fun flist -> "(" ^ String.concat "," (List.map M.flavor_to_string flist) ^ ")") violators) in failwith ("charge violating vertices: " ^ violator_strings) end; CF.amplitudes (include_goldstones !checks) !unphysical_polarization CF.no_exclusions selectors processes with | exc -> begin Printf.eprintf "O'Mega: exception %s in amplitude construction!\n" (Printexc.to_string exc); flush stderr; CF.empty; end in if !write then T.amplitudes_to_channel cmdline output_channel !checks amplitudes; if not !quiet then begin List.iter (fun amplitude -> Printf.eprintf "SUMMARY: %d fusions, %d propagators" (F.count_fusions amplitude) (F.count_propagators amplitude); flush stderr; Printf.eprintf ", %d diagrams" (F.count_diagrams amplitude); Printf.eprintf "\n") (CF.processes amplitudes); + let couplings = + List.fold_left + (fun acc p -> + let fusions = ThoList.flatmap F.rhs (F.fusions p) + and brakets = ThoList.flatmap F.ket (F.brakets p) in + let couplings = + vset_of_list (List.map F.coupling (fusions @ brakets)) in + VSet.union acc couplings) + VSet.empty (CF.processes amplitudes) in + Printf.eprintf "SUMMARY: %d vertices\n" (VSet.cardinal couplings); + let ufo_couplings = + VSet.fold + (fun v acc -> + match v with + | Coupling.V3 (Coupling.UFO3 (_, v, _, _), _, _) + | Coupling.V4 (Coupling.UFO4 (_, v, _, _), _, _) + | Coupling.Vn (Coupling.UFOn (_, 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 ch = open_out name in begin try List.iter (fun (fin, fout) -> Printf.fprintf ch "%s -> %s ::\n" (String.concat " " (List.map M.flavor_to_string fin)) (String.concat " " (List.map M.flavor_to_string fout)); match fin with | [] -> failwith "Omega(): phase space: no incoming particles" | [f] -> PHS.phase_space_channels ch (PHS.amplitude_sans_color false PHS.no_exclusions selectors fin fout) | [f1; f2] -> PHS.phase_space_channels ch (PHS.amplitude_sans_color false PHS.no_exclusions selectors fin fout); PHS.phase_space_channels_flipped ch (PHS.amplitude_sans_color false PHS.no_exclusions selectors [f2; f1] fout) | _ -> failwith "Omega(): phase space: 3 or more incoming particles") processes; close_out ch with | exc -> begin close_out ch; Printf.eprintf "O'Mega: exception %s in phase space construction!\n" (Printexc.to_string exc); flush stderr end end | None -> () end; if !print_forest then List.iter (fun amplitude -> List.iter (fun t -> Printf.eprintf "%s\n" (Tree.to_string (Tree.map (fun (wf, _) -> variable wf) (fun _ -> "") t))) (F.forest (List.hd (F.externals amplitude)) amplitude)) (CF.processes amplitudes); begin match !diagrams_all with | Some name -> amplitudes_to_feynmf !diagrams_LaTeX name amplitudes | None -> () end; begin match !diagrams_sans_color with | Some name -> amplitudes_to_feynmf_sans_color !diagrams_LaTeX name amplitudes | None -> () end; begin match !diagrams_color_only with | Some name -> amplitudes_to_feynmf_color_only !diagrams_LaTeX name amplitudes | None -> () end; begin match !output_file with | None -> () | Some name -> close_out output_channel end; exit 0 end (* \begin{dubious} This was only intended for debugging O'Giga \ldots \end{dubious} *) let decode wf = (F.flavor wf, (F.momentum wf : Momentum.Default.t)) let diagrams in1 in2 out = match F.amplitudes false F.no_exclusions C.no_cascades [in1; in2] out with | a :: _ -> let wf1 = List.hd (F.externals a) and wf2 = List.hd (List.tl (F.externals a)) in let wf2 = decode wf2 in List.map (fun t -> (wf2, Tree.map (fun (wf, _) -> decode wf) decode t)) (F.forest wf1 a) | [] -> [] let diagrams in1 in2 out = failwith "Omega().diagrams: disabled" end Index: trunk/omega/src/UFOx.mli =================================================================== --- trunk/omega/src/UFOx.mli (revision 8252) +++ trunk/omega/src/UFOx.mli (revision 8253) @@ -1,127 +1,168 @@ (* vertex.mli -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) module Expr : sig type t val of_string : string -> t val of_strings : string list -> t val substitute : string -> t -> t -> t val half : string -> t end -module Index : +module type Index = sig + (* 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 : (int * 'r) list -> (int * 'r) list + + (* [summation indices] returns all summation indices in the + list [indices], i.\,e.~all negative indices. *) val summation : (int * 'r) list -> (int * 'r) list + val classes_to_string : ('r -> string) -> (int * 'r) list -> string + end -module Q : Algebra.Rational +module Index : Index module type Tensor = sig + type atom - type t = (atom list * Q.t) list + + (* A tensor is linear combination of products of [atom]s + with rational coefficients. *) + type t = (atom list * Algebra.Q.t) 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. *) + val map_indices : (int -> int) -> t -> t + + (* 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_of_int : int -> r val rep_conjugate : r -> r val rep_trivial : r -> bool + + (* There is not a 1-to-1 mapping between the representations + in the model files and the representations used by O'Mega, + e.\,g.~in [Coupling.lorentz]. We might need to use heuristics. *) type r_omega val omega : r -> r_omega + end module type Atom = sig type t + val map_indices : (int -> int) -> t -> t val of_expr : string -> UFOx_syntax.expr list -> t val to_string : t -> string type r val classify_indices : t list -> (int * r) list val rep_to_string : r -> string val rep_of_int : int -> r val rep_conjugate : r -> r val rep_trivial : r -> bool type r_omega val omega : r -> r_omega end module type Lorentz_Atom = sig - type t = private + + type dirac = private | C of int * int - | Epsilon of int * int * int * int | Gamma of int * int * int | Gamma5 of int * int | Identity of int * int - | Metric of int * int - | P 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 t = private + | Dirac of dirac + | Vector of 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 + type t = (* private *) | Identity of int * int + | Identity8 of int * int | T of int * int * int | F of int * int * int | D of int * int * int | Epsilon of int * int * int | EpsilonBar of int * int * int | T6 of int * int * int | K6 of int * int * int | K6Bar of int * int * int end module Color_Atom : Color_Atom module Color : Tensor with type atom = Color_Atom.t and type r_omega = Color.t module 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 module type Test = sig val example : unit -> unit val suite : OUnit.test end Index: trunk/omega/src/omega_SM_top.ml =================================================================== --- trunk/omega/src/omega_SM_top.ml (revision 8252) +++ trunk/omega/src/omega_SM_top.ml (revision 8253) @@ -1,624 +1,624 @@ (* omega_SM_top.ml -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) -(* \thocwmodulesection{SM with charge $_4/3$ top} *) +(* \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" ] type matter_field = L of int | N of int | U of int | D of int type gauge_boson = Ga | Wp | Wm | Z | Gl type other = Phip | Phim | Phi0 | H type flavor = M of matter_field | G of gauge_boson | O of other let matter_field f = M f let gauge_boson f = G f let other f = O f type field = | Matter of matter_field | Gauge of gauge_boson | Other of other let field = function | M f -> Matter f | G f -> Gauge f | O f -> Other f type gauge = unit let gauge_symbol () = failwith "Models.Anomtop.gauge_symbol: internal error" let family n = List.map matter_field [ L n; N n; U n; D n ] let external_flavors () = [ "1st Generation", ThoList.flatmap family [1; -1]; "2nd Generation", ThoList.flatmap family [2; -2]; "3rd Generation", ThoList.flatmap family [3; -3]; "Gauge Bosons", List.map gauge_boson [Ga; Z; Wp; Wm; Gl]; "Higgs", [O H]; "Goldstone Bosons", List.map other [Phip; Phim; Phi0] ] let flavors () = ThoList.flatmap snd (external_flavors ()) let spinor n = if n >= 0 then Spinor else ConjSpinor let lorentz = function | M f -> begin match f with | L n -> spinor n | N n -> spinor n | U n -> spinor n | D n -> spinor n end | G f -> begin match f with | Ga | Gl -> Vector | Wp | Wm | Z -> Massive_Vector end | O f -> Scalar let color = function | M (U n) -> Color.SUN (if n > 0 then 3 else -3) | M (D n) -> Color.SUN (if n > 0 then 3 else -3) | G Gl -> Color.AdjSUN 3 | _ -> Color.Singlet let 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.Const 1) | Wm -> Some (O Phim, Coupling.Const 1) | Z -> Some (O Phi0, Coupling.Const 1) | _ -> None end | _ -> None let conjugate = function | M f -> M (begin match f with | L n -> L (-n) | N n -> N (-n) | U n -> U (-n) | D n -> D (-n) end) | G f -> G (begin match f with | Gl -> Gl | Ga -> Ga | Z -> Z | Wp -> Wm | Wm -> Wp end) | O f -> O (begin match f with | Phip -> Phim | Phim -> Phip | Phi0 -> Phi0 | H -> H end) let fermion = function | M f -> begin match f with | L n -> if n > 0 then 1 else -1 | N n -> if n > 0 then 1 else -1 | U n -> if n > 0 then 1 else -1 | D n -> if n > 0 then 1 else -1 end | G f -> begin match f with | Gl | Ga | Z | Wp | Wm -> 0 end | O _ -> 0 (* Electrical charge, lepton number, baryon number. We could avoid the rationals altogether by multiplying the first and last by 3 \ldots *) module Ch = Charges.QQ let ( // ) = Algebra.Small_Rational.make let generation' = function | 1 -> [ 1//1; 0//1; 0//1] | 2 -> [ 0//1; 1//1; 0//1] | 3 -> [ 0//1; 0//1; 1//1] | -1 -> [-1//1; 0//1; 0//1] | -2 -> [ 0//1; -1//1; 0//1] | -3 -> [ 0//1; 0//1; -1//1] | n -> invalid_arg ("SM_top.generation': " ^ string_of_int n) let generation f = match f with | M (L n | N n | U n | D n) -> generation' n | G _ | O _ -> [0//1; 0//1; 0//1] let charge = function | M f -> begin match f with | L n -> if n > 0 then -1//1 else 1//1 | N n -> 0//1 | U (1|2) -> 2//3 | U ((-1)|(-2)) -> -2//3 | U 3 -> -4//3 | U (-3) -> 4//3 | U n -> invalid_arg ("SM_top.charge: up quark " ^ string_of_int n) | D n -> if n > 0 then -1//3 else 1//3 end | G f -> begin match f with | Gl | Ga | Z -> 0//1 | Wp -> 1//1 | Wm -> -1//1 end | O f -> begin match f with | H | Phi0 -> 0//1 | Phip -> 1//1 | Phim -> -1//1 end let lepton = function | M f -> begin match f with | L n | N n -> if n > 0 then 1//1 else -1//1 | U _ | D _ -> 0//1 end | G _ | O _ -> 0//1 let baryon = function | M f -> begin match f with | L _ | N _ -> 0//1 | U n | D n -> if n > 0 then 1//1 else -1//1 end | G _ | O _ -> 0//1 let charges f = [ charge f; lepton f; baryon f] @ generation f type constant = | Unit | Pi | Alpha_QED | Sin2thw | Sinthw | Costhw | E | G_weak | Vev | Q_lepton | Q_up | Q_down | Q_top | G_CC | G_NC_neutrino | G_NC_lepton | G_NC_up | G_NC_down | G_NC_top | I_Q_W | I_G_ZWW | G_WWWW | G_ZZWW | G_AZWW | G_AAWW | G_HWW | G_HHWW | G_HZZ | G_HHZZ | G_Htt | G_Hbb | G_Hcc | G_Htautau | G_H3 | G_H4 | Gs | I_Gs | G2 | Mass of flavor | Width of flavor (* Two integer counters for the QCD and EW order of the couplings. *) type orders = int * int let orders = function | _ -> (0,0) let input_parameters = [] let derived_parameters = [] let derived_parameter_arrays = [] let parameters () = { input = input_parameters; derived = derived_parameters; derived_arrays = derived_parameter_arrays } module F = Modeltools.Fusions (struct type f = flavor type c = constant let compare = compare let conjugate = conjugate end) (* \begin{equation} \mathcal{L}_{\textrm{EM}} = - e \sum_i q_i \bar\psi_i\fmslash{A}\psi_i \end{equation} *) let mgm ((m1, g, m2), fbf, c) = ((M m1, G g, M m2), fbf, c) let electromagnetic_currents' n = List.map mgm [ ((L (-n), Ga, L n), FBF (1, Psibar, V, Psi), Q_lepton); ((D (-n), Ga, D n), FBF (1, Psibar, V, Psi), Q_down) ] let em_up_type_currents = List.map mgm [ ((U (-1), Ga, U 1), FBF (1, Psibar, V, Psi), Q_up); ((U (-2), Ga, U 2), FBF (1, Psibar, V, Psi), Q_up); ((U (-3), Ga, U 3), FBF (1, Psibar, V, Psi), Q_top)] let electromagnetic_currents = ThoList.flatmap electromagnetic_currents' [1;2;3] @ em_up_type_currents let color_currents n = List.map mgm [ ((U (-n), Gl, U n), FBF ((-1), Psibar, V, Psi), Gs); ((D (-n), Gl, D n), FBF ((-1), Psibar, V, Psi), Gs) ] (* \begin{equation} \mathcal{L}_{\textrm{NC}} = - \frac{g}{2\cos\theta_W} \sum_i \bar\psi_i\fmslash{Z}(g_V^i-g_A^i\gamma_5)\psi_i \end{equation} *) let neutral_currents' n = List.map mgm [ ((L (-n), Z, L n), FBF (1, Psibar, VA, Psi), G_NC_lepton); ((N (-n), Z, N n), FBF (1, Psibar, VA, Psi), G_NC_neutrino); ((D (-n), Z, D n), FBF (1, Psibar, VA, Psi), G_NC_down) ] let neutral_up_type_currents = List.map mgm [ ((U (-1), Z, U 1), FBF (1, Psibar, VA, Psi), G_NC_up); ((U (-2), Z, U 2), FBF (1, Psibar, VA, Psi), G_NC_up); ((U (-3), Z, U 3), FBF (1, Psibar, VA, Psi), G_NC_top) ] let neutral_currents = ThoList.flatmap neutral_currents' [1;2;3] @ neutral_up_type_currents (* \begin{equation} \mathcal{L}_{\textrm{CC}} = - \frac{g}{2\sqrt2} \sum_i \bar\psi_i (T^+\fmslash{W}^+ + T^-\fmslash{W}^-)(1-\gamma_5)\psi_i \end{equation} *) let charged_currents' n = List.map mgm [ ((L (-n), Wm, N n), FBF (1, Psibar, VL, Psi), G_CC); ((N (-n), Wp, L n), FBF (1, Psibar, VL, Psi), G_CC) ] let charged_up_currents = List.map mgm [ ((U (-1), Wp, D 1), FBF (1, Psibar, VL, Psi), G_CC); ((U (-2), Wp, D 2), FBF (1, Psibar, VL, Psi), G_CC); ((U (-3), Wm, D 3), FBF (1, Psibar, VL, Psi), G_CC); ((D (-1), Wm, U 1), FBF (1, Psibar, VL, Psi), G_CC); ((D (-2), Wm, U 2), FBF (1, Psibar, VL, Psi), G_CC); ((D (-3), Wp, U 3), FBF (1, Psibar, VL, Psi), G_CC) ] let charged_currents = ThoList.flatmap charged_currents' [1;2;3] @ charged_up_currents let yukawa = [ ((M (U (-3)), O H, M (U 3)), FBF (1, Psibar, S, Psi), G_Htt); ((M (D (-3)), O H, M (D 3)), FBF (1, Psibar, S, Psi), G_Hbb); ((M (U (-2)), O H, M (U 2)), FBF (1, Psibar, S, Psi), G_Hcc); ((M (L (-3)), O H, M (L 3)), FBF (1, Psibar, S, Psi), G_Htautau) ] (* \begin{equation} \mathcal{L}_{\textrm{TGC}} = - e \partial_\mu A_\nu W_+^\mu W_-^\nu + \ldots - e \cot\theta_w \partial_\mu Z_\nu W_+^\mu W_-^\nu + \ldots \end{equation} *) let tgc ((g1, g2, g3), t, c) = ((G g1, G g2, G g3), t, c) let triple_gauge = List.map tgc [ ((Ga, Wm, Wp), Gauge_Gauge_Gauge 1, I_Q_W); ((Z, Wm, Wp), Gauge_Gauge_Gauge 1, I_G_ZWW); ((Gl, Gl, Gl), Gauge_Gauge_Gauge 1, I_Gs)] let qgc ((g1, g2, g3, g4), t, c) = ((G g1, G g2, G g3, G g4), t, c) let gauge4 = Vector4 [(2, C_13_42); (-1, C_12_34); (-1, C_14_23)] let minus_gauge4 = Vector4 [(-2, C_13_42); (1, C_12_34); (1, C_14_23)] let quartic_gauge = List.map qgc [ (Wm, Wp, Wm, Wp), gauge4, G_WWWW; (Wm, Z, Wp, Z), minus_gauge4, G_ZZWW; (Wm, Z, Wp, Ga), minus_gauge4, G_AZWW; (Wm, Ga, Wp, Ga), minus_gauge4, G_AAWW; (Gl, Gl, Gl, Gl), gauge4, G2 ] let gauge_higgs = [ ((O H, G Wp, G Wm), Scalar_Vector_Vector 1, G_HWW); ((O H, G Z, G Z), Scalar_Vector_Vector 1, G_HZZ) ] let gauge_higgs4 = [ (O H, O H, G Wp, G Wm), Scalar2_Vector2 1, G_HHWW; (O H, O H, G Z, G Z), Scalar2_Vector2 1, G_HHZZ ] let higgs = [ (O H, O H, O H), Scalar_Scalar_Scalar 1, G_H3 ] let higgs4 = [ (O H, O H, O H, O H), Scalar4 1, G_H4 ] let goldstone_vertices = [ ((O Phi0, G Wm, G Wp), Scalar_Vector_Vector 1, I_G_ZWW); ((O Phip, G Ga, G Wm), Scalar_Vector_Vector 1, I_Q_W); ((O Phip, G Z, G Wm), Scalar_Vector_Vector 1, I_G_ZWW); ((O Phim, G Wp, G Ga), Scalar_Vector_Vector 1, I_Q_W); ((O Phim, G Wp, G Z), Scalar_Vector_Vector 1, I_G_ZWW) ] let vertices3 = (electromagnetic_currents @ ThoList.flatmap color_currents [1;2;3] @ neutral_currents @ charged_currents @ yukawa @ triple_gauge @ gauge_higgs @ higgs @ goldstone_vertices) let vertices4 = quartic_gauge @ gauge_higgs4 @ higgs4 let vertices () = (vertices3, vertices4, []) (* For efficiency, make sure that [F.of_vertices vertices] is evaluated only once. *) let table = F.of_vertices (vertices ()) let fuse2 = F.fuse2 table let fuse3 = F.fuse3 table let fuse = F.fuse table let max_degree () = 4 let flavor_of_string = function | "e-" -> M (L 1) | "e+" -> M (L (-1)) | "mu-" -> M (L 2) | "mu+" -> M (L (-2)) | "tau-" -> M (L 3) | "tau+" -> M (L (-3)) | "nue" -> M (N 1) | "nuebar" -> M (N (-1)) | "numu" -> M (N 2) | "numubar" -> M (N (-2)) | "nutau" -> M (N 3) | "nutaubar" -> M (N (-3)) | "u" -> M (U 1) | "ubar" -> M (U (-1)) | "c" -> M (U 2) | "cbar" -> M (U (-2)) | "t" -> M (U 3) | "tbar" -> M (U (-3)) | "d" -> M (D 1) | "dbar" -> M (D (-1)) | "s" -> M (D 2) | "sbar" -> M (D (-2)) | "b" -> M (D 3) | "bbar" -> M (D (-3)) | "g" | "gl" -> G Gl | "A" -> G Ga | "Z" | "Z0" -> G Z | "W+" -> G Wp | "W-" -> G Wm | "H" -> O H | _ -> invalid_arg "Models.Anomtop.flavor_of_string" let flavor_to_string = function | M f -> begin match f with | L 1 -> "e-" | L (-1) -> "e+" | L 2 -> "mu-" | L (-2) -> "mu+" | L 3 -> "tau-" | L (-3) -> "tau+" | L _ -> invalid_arg "Models.Anomtop.flavor_to_string: invalid lepton" | N 1 -> "nue" | N (-1) -> "nuebar" | N 2 -> "numu" | N (-2) -> "numubar" | N 3 -> "nutau" | N (-3) -> "nutaubar" | N _ -> invalid_arg "Models.Anomtop.flavor_to_string: invalid neutrino" | U 1 -> "u" | U (-1) -> "ubar" | U 2 -> "c" | U (-2) -> "cbar" | U 3 -> "t" | U (-3) -> "tbar" | U _ -> invalid_arg "Models.Anomtop.flavor_to_string: invalid up type quark" | D 1 -> "d" | D (-1) -> "dbar" | D 2 -> "s" | D (-2) -> "sbar" | D 3 -> "b" | D (-3) -> "bbar" | D _ -> invalid_arg "Models.Anomtop.flavor_to_string: invalid down type quark" end | G f -> begin match f with | Gl -> "g" | Ga -> "A" | Z -> "Z" | Wp -> "W+" | Wm -> "W-" end | O f -> begin match f with | Phip -> "phi+" | Phim -> "phi-" | Phi0 -> "phi0" | H -> "H" end let flavor_to_TeX = function | M f -> begin match f with | L 1 -> "e^-" | L (-1) -> "e^+" | L 2 -> "\\mu^-" | L (-2) -> "\\mu^+" | L 3 -> "\\tau^-" | L (-3) -> "\\tau^+" | L _ -> invalid_arg "Models.Anomtop.flavor_to_TeX: invalid lepton" | N 1 -> "\\nu_e" | N (-1) -> "\\bar{\\nu}_e" | N 2 -> "\\nu_\\mu" | N (-2) -> "\\bar{\\nu}_\\mu" | N 3 -> "\\nu_\\tau" | N (-3) -> "\\bar{\\nu}_\\tau" | N _ -> invalid_arg "Models.Anomtop.flavor_to_TeX: invalid neutrino" | U 1 -> "u" | U (-1) -> "\\bar{u}" | U 2 -> "c" | U (-2) -> "\\bar{c}" | U 3 -> "t" | U (-3) -> "\\bar{t}" | U _ -> invalid_arg "Models.Anomtop.flavor_to_TeX: invalid up type quark" | D 1 -> "d" | D (-1) -> "\\bar{d}" | D 2 -> "s" | D (-2) -> "\\bar{s}" | D 3 -> "b" | D (-3) -> "\\bar{b}" | D _ -> invalid_arg "Models.Anomtop.flavor_to_TeX: invalid down type quark" end | G f -> begin match f with | Gl -> "g" | Ga -> "\\gamma" | Z -> "Z" | Wp -> "W^+" | Wm -> "W^-" end | O f -> begin match f with | Phip -> "phi+" | Phim -> "phi-" | Phi0 -> "phi0" | H -> "H" end let flavor_symbol = function | M f -> begin match f with | L n when n > 0 -> "l" ^ string_of_int n | L n -> "l" ^ string_of_int (abs n) ^ "b" | N n when n > 0 -> "n" ^ string_of_int n | N n -> "n" ^ string_of_int (abs n) ^ "b" | U n when n > 0 -> "u" ^ string_of_int n | U n -> "u" ^ string_of_int (abs n) ^ "b" | D n when n > 0 -> "d" ^ string_of_int n | D n -> "d" ^ string_of_int (abs n) ^ "b" end | G f -> begin match f with | Gl -> "gl" | Ga -> "a" | Z -> "z" | Wp -> "wp" | Wm -> "wm" end | O f -> begin match f with | Phip -> "pp" | Phim -> "pm" | Phi0 -> "p0" | H -> "h" end let pdg = function | M f -> begin match f with | L n when n > 0 -> 9 + 2*n | L n -> - 9 + 2*n | N n when n > 0 -> 10 + 2*n | N n -> - 10 + 2*n | U n when n > 0 -> 2*n | U n -> 2*n | D n when n > 0 -> - 1 + 2*n | D n -> 1 + 2*n end | G f -> begin match f with | Gl -> 21 | Ga -> 22 | Z -> 23 | Wp -> 24 | Wm -> (-24) end | O f -> begin match f with | Phip | Phim -> 27 | Phi0 -> 26 | H -> 25 end let mass_symbol f = "mass(" ^ string_of_int (abs (pdg f)) ^ ")" let width_symbol f = "width(" ^ string_of_int (abs (pdg f)) ^ ")" let constant_symbol = function | Unit -> "unit" | Pi -> "PI" | Alpha_QED -> "alpha" | E -> "e" | G_weak -> "g" | Vev -> "vev" | Sin2thw -> "sin2thw" | Sinthw -> "sinthw" | Costhw -> "costhw" | Q_lepton -> "qlep" | Q_up -> "qup" | Q_down -> "qdwn" | Q_top -> "qtop" | G_NC_lepton -> "gnclep" | G_NC_neutrino -> "gncneu" | G_NC_up -> "gncup" | G_NC_down -> "gncdwn" | G_NC_top -> "gnctop" | G_CC -> "gcc" | I_Q_W -> "iqw" | I_G_ZWW -> "igzww" | G_WWWW -> "gw4" | G_ZZWW -> "gzzww" | G_AZWW -> "gazww" | G_AAWW -> "gaaww" | G_HWW -> "ghww" | G_HZZ -> "ghzz" | G_HHWW -> "ghhww" | G_HHZZ -> "ghhzz" | G_Htt -> "ghtt" | G_Hbb -> "ghbb" | G_Htautau -> "ghtautau" | G_Hcc -> "ghcc" | G_H3 -> "gh3" | G_H4 -> "gh4" | Gs -> "gs" | I_Gs -> "igs" | G2 -> "gs**2" | Mass f -> "mass" ^ flavor_symbol f | Width f -> "width" ^ flavor_symbol f end module O = Omega.Make(Fusion.Mixed23)(Targets.Fortran) (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/permutation.ml =================================================================== --- trunk/omega/src/permutation.ml (revision 8252) +++ trunk/omega/src/permutation.ml (revision 8253) @@ -1,289 +1,335 @@ (* permutation.ml -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from cf. main AUTHORS file WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) module type T = sig type t val of_list : int list -> t val of_array : int array -> t val inverse : t -> t val compose : 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 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 "Permutation.of_list" -> invalid_arg "Permutation.of_array" let inverse p = snd (ThoList.ariadne_sort p) let list p l = List.map snd - (List.sort compare + (List.sort (fun (i, _) (j, _) -> compare i j) (try List.rev_map2 (fun i x -> (i, x)) p l with | Invalid_argument "List.rev_map2" -> invalid_arg "Permutation.list: length mismatch")) let array p a = try Array.of_list (list p (Array.to_list a)) with | Invalid_argument "Permutation.list: length mismatch" -> invalid_arg "Permutation.array: length mismatch" (* 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 "Permutation.of_list" -> invalid_arg "Permutation.of_array" 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 "Permutation.array: length mismatch" -> invalid_arg "Permutation.list: length mismatch" 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; 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 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 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_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/process.ml =================================================================== --- trunk/omega/src/process.ml (revision 8252) +++ trunk/omega/src/process.ml (revision 8253) @@ -1,403 +1,401 @@ (* process.ml -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) module type T = sig type flavor type t = flavor list * flavor list val incoming : t -> flavor list val outgoing : t -> flavor list type decay val parse_decay : string -> decay val expand_decays : decay list -> t list type scattering val parse_scattering : string -> scattering val expand_scatterings : scattering list -> t list type any type process = Any of any | Decay of decay | Scattering of scattering val parse_process : string -> process val remove_duplicate_final_states : int list list -> t list -> t list val diff : t list -> t list -> t list val crossing : t list -> (flavor list * int list * t) list end module Make (M : Model.T) = struct type flavor = M.flavor type t = flavor list * flavor list let incoming (fin, _ ) = fin let outgoing (_, fout) = fout (* \thocwmodulesection{Select Charge Conserving Processes} *) let allowed (fin, fout) = M.Ch.is_null (M.Ch.sum (List.map M.charges (List.map M.conjugate fin @ fout))) (* \thocwmodulesection{Parsing Process Descriptions} *) type 'a bag = 'a list type any = flavor bag list type decay = flavor bag * flavor bag list type scattering = flavor bag * flavor bag * flavor bag list type process = | Any of any | Decay of decay | Scattering of scattering let unique_flavors f_bags = List.for_all (function [f] -> true | _ -> false) f_bags let unique_final_state = function | Any fs -> unique_flavors fs | Decay (_, fs) -> unique_flavors fs | Scattering (_, _, fs) -> unique_flavors fs let parse_process process = let last = String.length process - 1 and flavor off len = M.flavor_of_string (String.sub process off len) in let add_flavors flavors = function | Any l -> Any (List.rev flavors :: l) | Decay (i, f) -> Decay (i, List.rev flavors :: f) | Scattering (i1, i2, f) -> Scattering (i1, i2, List.rev flavors :: f) in let rec scan_list so_far n = if n > last then so_far else let n' = succ n in match process.[n] with | ' ' | '\n' -> scan_list so_far n' | '-' -> scan_gtr so_far n' | c -> scan_flavors so_far [] n n' and scan_flavors so_far flavors w n = if n > last then add_flavors (flavor w (last - w + 1) :: flavors) so_far else let n' = succ n in match process.[n] with | ' ' | '\n' -> scan_list (add_flavors (flavor w (n - w) :: flavors) so_far) n' | ':' -> scan_flavors so_far (flavor w (n - w) :: flavors) n' n' | _ -> scan_flavors so_far flavors w n' and scan_gtr so_far n = if n > last then invalid_arg "expecting `>'" else let n' = succ n in match process.[n] with | '>' -> begin match so_far with | Any [i] -> scan_list (Decay (i, [])) n' | Any [i2; i1] -> scan_list (Scattering (i1, i2, [])) n' | Any _ -> invalid_arg "only 1 or 2 particles in |in>" | _ -> invalid_arg "too many `->'s" end | _ -> invalid_arg "expecting `>'" in match scan_list (Any []) 0 with | Any l -> Any (List.rev l) | Decay (i, f) -> Decay (i, List.rev f) | Scattering (i1, i2, f) -> Scattering (i1, i2, List.rev f) let parse_decay process = match parse_process process with | Any (i :: f) -> prerr_endline "missing `->' in process description, assuming decay."; (i, f) | Decay (i, f) -> (i, f) | _ -> invalid_arg "expecting decay description: got scattering" let parse_scattering process = match parse_process process with | Any (i1 :: i2 :: f) -> prerr_endline "missing `->' in process description, assuming scattering."; (i1, i2, f) | Scattering (i1, i2, f) -> (i1, i2, f) | _ -> invalid_arg "expecting scattering description: got decay" let expand_scatterings scatterings = ThoList.flatmap (function (fin1, fin2, fout) -> Product.fold (fun flist acc -> match flist with | fin1' :: fin2' :: fout' -> let fin_fout' = ([fin1'; fin2'], fout') in if allowed fin_fout' then fin_fout' :: acc else acc | [_] | [] -> failwith "Omega.expand_scatterings: can't happen") (fin1 :: fin2 :: fout) []) scatterings let expand_decays decays = ThoList.flatmap (function (fin, fout) -> Product.fold (fun flist acc -> match flist with | fin' :: fout' -> let fin_fout' = ([fin'], fout') in if allowed fin_fout' then fin_fout' :: acc else acc | [] -> failwith "Omega.expand_decays: can't happen") (fin :: fout) []) decays (* \thocwmodulesection{Remove Duplicate Final States} *) (* Test if all final states are the same. Identical to [ThoList.homogeneous] $\circ$ [(List.map snd)]. *) let rec homogeneous_final_state = function | [] | [_] -> true | (_, fs1) :: ((_, fs2) :: _ as rest) -> if fs1 <> fs2 then false else homogeneous_final_state rest let by_color f1 f2 = let c = Color.compare (M.color f1) (M.color f2) in if c <> 0 then c else compare f1 f2 module Pre_Bundle = struct type elt = t type base = elt let compare_elt (fin1, fout1) (fin2, fout2) = let c = ThoList.compare ~cmp:by_color fin1 fin2 in if c <> 0 then c else ThoList.compare ~cmp:by_color fout1 fout2 let compare_base b1 b2 = compare_elt b2 b1 end module Process_Bundle = Bundle.Dyn (Pre_Bundle) let to_string (fin, fout) = String.concat " " (List.map M.flavor_to_string fin) ^ " -> " ^ String.concat " " (List.map M.flavor_to_string fout) let fiber_to_string (base, fiber) = (to_string base) ^ " -> [" ^ (String.concat ", " (List.map to_string fiber)) ^ "]" let bundle_to_strings list = List.map fiber_to_string list (* Subtract $n+1$ from each element in [index_set] and drop all negative numbers from the result.*) let shift_left_pred' n index_set = List.fold_right (fun i acc -> let i' = i - n - 1 in if i' < 0 then acc else i' :: acc) index_set [] (* Convert 1-based indices for initial and final state to 0-based indices for the final state only. (NB: [ThoList.partitioned_sort] expects 0-based indices.) *) let shift_left_pred fin index_sets = let n = match fin with [_] -> 1 | [_;_] -> 2 | _ -> 0 in List.fold_right (fun iset acc -> match shift_left_pred' n iset with | [] -> acc | iset' -> iset' :: acc) index_sets [] module FSet = Set.Make (struct type t = flavor let compare = compare end) (* Take a list of final states and return a list of sets of flavors appearing in each slot. *) let flavors = function | [] -> [] | fs :: fs_list -> List.fold_right (List.map2 FSet.add) fs_list (List.map FSet.singleton fs) let flavor_sums flavor_sets = let _, result = List.fold_left (fun (n, acc) flavors -> if FSet.cardinal flavors = 1 then (succ n, acc) else (succ n, (n, flavors) :: acc)) (0, []) flavor_sets in List.rev result let overlapping s1 s2 = not (FSet.is_empty (FSet.inter s1 s2)) let rec merge_overlapping (n, flavors) = function | [] -> [([n], flavors)] | (n_list, flavor_set) :: rest -> if overlapping flavors flavor_set then (n::n_list, FSet.union flavors flavor_set) :: rest else (n_list, flavor_set) :: merge_overlapping (n, flavors) rest let overlapping_flavor_sums flavor_sums = List.rev_map (fun (n_list, flavor_set) -> (n_list, FSet.elements flavor_set)) (List.fold_right merge_overlapping flavor_sums []) - module ISet = Set.Make (struct type t = int let compare = compare end) - let integer_range n1 n2 = let rec integer_range' acc n' = if n' < n1 then acc else - integer_range' (ISet.add n' acc) (pred n') in - integer_range' ISet.empty n2 + integer_range' (Sets.Int.add n' acc) (pred n') in + integer_range' Sets.Int.empty n2 let coarsest_partition = function | [] -> invalid_arg "coarsest_partition: empty process list" | ((_, fs) :: _) as proc_list -> let fs_list = List.map snd proc_list in let overlaps = List.map fst (overlapping_flavor_sums (flavor_sums (flavors fs_list))) in let singletons = - ISet.elements - (List.fold_right ISet.remove + Sets.Int.elements + (List.fold_right Sets.Int.remove (List.concat overlaps) (integer_range 0 (pred (List.length fs)))) in List.map (fun n -> [n]) singletons @ overlaps module IPowSet = PowSet.Make (struct type t = int let compare = compare let to_string = string_of_int end) let merge_partitions p_list = IPowSet.to_lists (IPowSet.basis (IPowSet.union (List.map IPowSet.of_lists p_list))) (*i let merge_partitions p_list = let p' = merge_partitions p_list in List.iter (fun p -> Printf.eprintf "p = %s\n" (IPowSet.to_string (IPowSet.of_lists p))) p_list; Printf.eprintf "p' = %s\n" (IPowSet.to_string (IPowSet.of_lists p')); p' i*) let remove_duplicate_final_states cascade_partition = function | [] -> [] | [process] -> [process] | list -> if homogeneous_final_state list then list else let partition = coarsest_partition list in let pi (fin, fout) = let partition' = merge_partitions [partition; shift_left_pred fin cascade_partition] in (fin, ThoList.partitioned_sort by_color partition' fout) in Process_Bundle.base (Process_Bundle.of_list pi list) (*i let remove_duplicate_final_states partition list = let overlaps = coarsest_partition list in Printf.eprintf "::: %s\n" (String.concat ", " (List.map (fun ns -> "{" ^ (String.concat "," (List.map string_of_int ns)) ^ "}") overlaps)); List.iter (fun (fin, fout) -> Printf.eprintf ">>> %s\n" (to_string (fin, fout))) list; let result = remove_duplicate_final_states partition list in List.iter (fun (fin, fout) -> Printf.eprintf "<<< %s\n" (to_string (fin, fout))) result; result i*) type t' = t module PSet = Set.Make (struct type t = t' let compare = compare end) let set list = List.fold_right PSet.add list PSet.empty let diff list1 list2 = PSet.elements (PSet.diff (set list1) (set list2)) (* \begin{dubious} Not functional yet. \end{dubious} *) module Crossing_Projection = struct type elt = t type base = flavor list * int list * t let compare_elt (fin1, fout1) (fin2, fout2) = let c = ThoList.compare ~cmp:by_color fin1 fin2 in if c <> 0 then c else ThoList.compare ~cmp:by_color fout1 fout2 let compare_base (f1, _, _) (f2, _, _) = ThoList.compare ~cmp:by_color f1 f2 let pi (fin, fout as process) = let flist, indices = ThoList.ariadne_sort ~cmp:by_color (List.map M.conjugate fin @ fout) in (flist, indices, process) end module Crossing_Bundle = Bundle.Make (Crossing_Projection) let crossing processes = List.map (fun (fin, fout as process) -> (List.map M.conjugate fin @ fout, [], process)) processes end (*i * Local Variables: * mode:caml * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/src/opam_versions.sh =================================================================== --- trunk/omega/src/opam_versions.sh (revision 0) +++ trunk/omega/src/opam_versions.sh (revision 8253) @@ -0,0 +1,35 @@ +#! /bin/sh +######################################################################## +# This script is for developers only and needs not to be portable. +# This script assumes an opam installation with many versions of +# O'Caml available as switches. +######################################################################## +# tl;dr : don't try this at home, kids ;) +######################################################################## + +src=$(dirname $(realpath $0)) +root=$(dirname $(dirname $src)) +build=$root/_build +log=$src/opam_versions.out + +rm -f $log + +for switch in $(opam switch -s); do + opam switch $switch >/dev/null || exit 2 + opam switch show + eval $(opam env) + mkdir -p $build-$switch + cd $build-$switch + if [ ! -e config.status ]; then + cp -a $build/config.status . + ./config.status --recheck + ./config.status + fi + make -j $(getconf _NPROCESSORS_ONLN) -C omega && \ + make -j $(getconf _NPROCESSORS_ONLN) -C omega check + if [ "$?" = 0 ]; then + echo "$switch PASS" >> $log + else + echo "$switch FAIL" >> $log + fi +done Property changes on: trunk/omega/src/opam_versions.sh ___________________________________________________________________ Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: trunk/omega/src/colorize.ml =================================================================== --- trunk/omega/src/colorize.ml (revision 8252) +++ trunk/omega/src/colorize.ml (revision 8253) @@ -1,1680 +1,2263 @@ (* colorize.ml -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner Marco Sekulla So Young Shim WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the 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{Colorizing a Monochrome Model} *) module It (M : Model.T) = struct open Coupling module C = Color let incomplete s = failwith ("Colorize.It()." ^ s ^ " not done yet!") let invalid s = invalid_arg ("Colorize.It()." ^ s ^ " must not be evaluated!") let impossible s = invalid_arg ("Colorize.It()." ^ s ^ " can't happen! (but just did ...)") + let mismatch s = + invalid_arg ("Colorize.It()." ^ s ^ " mismatch of representations!") + let su0 s = invalid_arg ("Colorize.It()." ^ s ^ ": found SU(0)!") let colored_vertex s = invalid_arg ("Colorize.It()." ^ s ^ ": colored vertex!") let baryonic_vertex s = invalid_arg ("Colorize.It()." ^ s ^ ": baryonic (i.e. eps_ijk) vertices not supported yet!") let color_flow_ambiguous s = invalid_arg ("Colorize.It()." ^ s ^ ": ambiguous color flow!") let color_flow_of_string s = let c = int_of_string s in if c < 1 then invalid_arg ("Colorize.It()." ^ s ^ ": color flow # < 1!") else c type cf_in = int type cf_out = int type flavor = | 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 type flavor_sans_color = M.flavor let flavor_sans_color = function | White f -> f | CF_in (f, _) -> f | CF_out (f, _) -> f | CF_io (f, _, _) -> f | CF_aux f -> f let pullback f arg1 = f (flavor_sans_color arg1) type gauge = M.gauge type constant = M.constant let options = M.options let color = pullback M.color 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 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 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) 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 - module ISet = Set.Make (struct type t = int let compare = compare end) - (* We MUST NOT compute [nc] only once because [M.flavors] might change in a mutable [Model.Mutable] after loading a new model file! *) let nc () = let nc_set = List.fold_left (fun nc_set f -> match M.color f with | C.Singlet -> nc_set - | C.SUN nc -> ISet.add (abs nc) nc_set - | C.AdjSUN nc -> ISet.add (abs nc) nc_set) - ISet.empty (M.flavors ()) in - match ISet.elements nc_set with + | C.SUN nc -> Sets.Int.add (abs nc) nc_set + | C.AdjSUN nc -> Sets.Int.add (abs nc) nc_set) + Sets.Int.empty (M.flavors ()) in + match Sets.Int.elements nc_set with | [] -> 0 | [n] -> n | nc_list -> invalid_arg ("Colorize.It(): more than one value of N_C: " ^ String.concat ", " (List.map string_of_int nc_list)) 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 with | Failure "int_of_string" -> invalid_arg "Colorize().flavor_of_string: expecting integer" 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 ^ "//" 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}" let flavor_symbol = function | White f -> M.flavor_symbol f | CF_in (f, c) -> M.flavor_symbol f ^ "_" ^ string_of_int c ^ "_" | CF_out (f, c) -> M.flavor_symbol f ^ "__" ^ string_of_int c | CF_io (f, c1, c2) -> M.flavor_symbol f ^ "_" ^ string_of_int c1 ^ "_" ^ string_of_int c2 | CF_aux f -> M.flavor_symbol f ^ "__" 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} *) (* \thocwmodulesubsection{Auxiliary functions} *) + 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 + try + Some (Q.to_integer x) + with + | _ -> None + else + None + let mult_vertex3 x = function + | UFO3 (c, v, s, col) -> + UFO3 (QC.mul (of_int x) c, v, s, col) | 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 = function + | UFO3 (c, v, s, col) -> + UFO3 (QC.mul z c, v, s, col) + | v -> + begin match integer z with + | None -> invalid_arg "cmult_vertex3" + | Some x -> mult_vertex3 x v + end + let mult_vertex4 x = function + | UFO4 (c, v, s, col) -> + UFO4 (QC.mul (of_int x) c, v, s, col) | 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 = function + | UFO4 (c, v, s, col) -> + UFO4 (QC.mul z c, v, s, col) + | v -> + begin match integer z with + | None -> invalid_arg "cmult_vertex4" + | Some x -> mult_vertex4 x v + end + let mult_vertexn x = function | foo -> ignore (incomplete "mult_vertexn"); foo + let cmult_vertexn z = function + | foo -> ignore (incomplete "cmult_vertexn"); foo + let mult_vertex x = function | 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 = function + | 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) + (* 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 + | UFO4 (c, v, s, Color.Trivial4) -> + UFO4 (c, v, s, Color.Trivial4) + | UFO4 (c, v, s, _) -> + failwith "Colorize.permute_vertex4': incomplete" | 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) (* [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" (* \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) = + let colorize_fusion2_legacy 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" 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" end | C.AdjSUN _ -> begin match f1, f2 with | White _, CF_io (_, c1, c2') | CF_io (_, c1, c2'), White _ -> [CF_io (f, c1, c2'), v] | 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 sign = + let phase = begin match v with | V3 (Gauge_Gauge_Gauge _, _, _) | V3 (I_Gauge_Gauge_Gauge _, _, _) - | V3 (Aux_Gauge_Gauge _, _, _) -> 1 + | V3 (Aux_Gauge_Gauge _, _, _) -> of_int 1 | V3 (FBF (_, _, _, _), fuse2, _) -> begin match fuse2 with - | F12 -> 1 (* works, but needs theoretical underpinning *) - | F21 -> -1 (* dto. *) - | F31 -> 1 (* dto. *) - | F32 -> -1 (* transposition of [F12] (no testcase) *) - | F23 -> 1 (* transposition of [F21] (no testcase) *) - | F13 -> -1 (* transposition of [F12] (no testcase) *) + | 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 (UFO3 (_, _, _, Color.Legacy3), fuse2, _) -> + begin match fuse2 with + | F12 | F23 | F31 -> QC.make Q.null Q.unit + | F21 | F32 | F13 -> QC.make Q.null (Q.neg Q.unit) 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'), mult_vertex (-sign) v] + [CF_io (f, c1, c2'), cmult_vertex (QC.neg phase) v] else if c2' = c1 then - [CF_io (f, c2, c1'), mult_vertex ( sign) v] + [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" end +(* \thocwmodulesubsection{Cubic Vertices, UFO Version} *) + +(* 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.fuse2]. *) + +(* Eventually, the type [Coupling.fuse2] will be retired in + favor of [int * int * int] or even [int list]. This is why we + have code that is more general than required here. *) + + module PosMap = + Partial.Make (struct type t = int let compare = compare end) + + (* Note that we obtain the inverse of the ``permutation'' [l'] + here, e.\,g., [Permutation.Default.list [2;0;1]] + applied to [[1;2;3]] gives [[2;3;1]], + i.\,e.~the ``inverse'' of [[3;1;2]]. *) + 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 fuse2_to_list = function + | F12 -> [3;1;2] + | F21 -> [3;2;1] + | F23 -> [1;2;3] + | F32 -> [1;3;2] + | F31 -> [2;3;1] + | F13 -> [2;1;3] + + let partial_map_undoing_fuse2 fuse2 = + partial_map_undoing_permutation [1;2;3] (fuse2_to_list fuse2) + + (* Compute the partial maps once, not everytime anew! *) + let undo_F12 = partial_map_undoing_fuse2 F12 + let undo_F21 = partial_map_undoing_fuse2 F21 + let undo_F23 = partial_map_undoing_fuse2 F23 + let undo_F32 = partial_map_undoing_fuse2 F32 + let undo_F31 = partial_map_undoing_fuse2 F31 + let undo_F13 = partial_map_undoing_fuse2 F13 + + let undo_permutation_of_fuse2 fuse2 = + let fail _ = invalid_arg "permutation_of_fuse2" in + match fuse2 with + | F12 -> PosMap.apply_with_fallback fail undo_F12 + | F21 -> PosMap.apply_with_fallback fail undo_F21 + | F23 -> PosMap.apply_with_fallback fail undo_F23 + | F32 -> PosMap.apply_with_fallback fail undo_F32 + | F31 -> PosMap.apply_with_fallback fail undo_F31 + | F13 -> PosMap.apply_with_fallback fail undo_F13 + + (* The same can be expressed more concisely. *) + let undo_permutation_of_fuse2' fuse2 = + let fail () = invalid_arg "permutation_of_fuse2" in + match fuse2 with + | F12 -> (function 1 -> 2 | 2 -> 3 | 3 -> 1 | _ -> fail ()) + | F21 -> (function 1 -> 3 | 2 -> 2 | 3 -> 1 | _ -> fail ()) + | F23 -> (function 1 -> 1 | 2 -> 2 | 3 -> 3 | _ -> fail ()) + | F32 -> (function 1 -> 1 | 2 -> 3 | 3 -> 2 | _ -> fail ()) + | F31 -> (function 1 -> 3 | 2 -> 1 | 3 -> 2 | _ -> fail ()) + | F13 -> (function 1 -> 2 | 2 -> 1 | 3 -> 3 | _ -> fail ()) + + let pair3_to_ints = function + | C.P3_12 -> (1, 2) + | C.P3_23 -> (2, 3) + | C.P3_31 -> (3, 1) + | C.P3_21 -> (2, 1) + | C.P3_32 -> (3, 2) + | C.P3_13 -> (1, 3) + + let apply_fuse2 fuse2 pair3 = + let p = undo_permutation_of_fuse2 fuse2 + and i, j = pair3_to_ints pair3 in + (p i, p j) + + let colorize_fusion2_ufo f1 f2 f c v spins color fuse xtra = + let open Color in + let v = V3 (UFO3 (c, v, spins, Trivial3), fuse, xtra) in + match color with + | Trivial3 -> + begin match f1, f2 with + | White _, White _ -> [White f, v] + | _ -> mismatch "colorize_fusion2 Color.Trivial3" + end + | Delta3 perm -> + let i, j = apply_fuse2 fuse perm in + begin match i, j, f1, f2 with + | 1, 3, White _, CF_out (_, cf) + | 1, 2, CF_out (_, cf), White _ -> + [CF_out (f, cf), v] + | 3, 1, White _, CF_in (_, cf) + | 2, 1, CF_in (_, cf), White _ -> + [CF_in (f, cf), v] + | 2, 3, CF_in (_, cf2), CF_out (_, cf1) + | 3, 2, CF_out (_, cf1), CF_in (_, cf2) -> + if cf1 = cf2 then + [White f, v] + else + [] + | _ -> mismatch "colorize_fusion2 Color.Delta3" + end + + | F -> + begin match f1, f2 with + | CF_io (f1, c1, c1'), CF_io (f2, c2, c2') -> + let i = QC.make Q.null Q.unit in + if c1' = c2 then + [CF_io (f, c1, c2'), cmult_vertex (QC.neg i) v] + else if c2' = c1 then + [CF_io (f, c2, c1'), cmult_vertex ( i) v] + else + [] + | (CF_io _ | CF_aux _), (CF_io _ | CF_aux _) -> [] + | _ -> mismatch "colorize_fusion2 Color.F" + end + + | _ -> + incomplete "Colorize.colorize_fusion2_ufo" + + let colorize_fusion2 f1 f2 (f, v) = + match v with + | V3 (UFO3 (_, _, _, C.Legacy3), _, _) -> + colorize_fusion2_legacy f1 f2 (f, v) + | V3 (UFO3 (c, v, spins, color), fuse, xtra) -> + colorize_fusion2_ufo f1 f2 f c v spins color fuse xtra + | V3 _ -> colorize_fusion2_legacy f1 f2 (f, v) + | _ -> invalid_arg "Colorize.colorize_fusion2" + (* \thocwmodulesubsection{Quartic Vertices} *) - let colorize_fusion3 f1 f2 f3 (f, v) = + let colorize_fusion3_legacy 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" 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" 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" end +(* \thocwmodulesubsection{Quartic Vertices, UFO Version} *) + +(* Using again the normalization~$\tr(T_{a}T_{b}) = \delta_{ab}$ + with~\eqref{eq:f=tr(TTT)} and~\eqref{fTTT}, + we find the decomposition + \begin{equation} + \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} + and from this + \begin{multline} + f_{a_1a_2a} T_{a_1}^{i_1j_1}T_{a_2}^{i_2j_2} + f_{a_3a_4a} T_{a_3}^{i_3j_3}T_{a_4}^{i_4j_4} + = f_{a_1a_2a} T_{a_1}^{i_1j_1}T_{a_2}^{i_2j_2}T_{a}^{ij} + f_{a_3a_4b} T_{a_3}^{i_3j_3}T_{a_4}^{i_4j_4}T_{b}^{ji} \\ + = - \left( \delta^{i_1j_2}\delta^{i_2j}\delta^{ij_1} + - \delta^{i_1j}\delta^{ij_2}\delta^{i_2j_1}\right) + \left( \delta^{i_3j_4}\delta^{i_4i}\delta^{jj_3} + - \delta^{i_3i}\delta^{jj_4}\delta^{i_4j_3}\right) +%%% \\ +%%% = - \delta^{i_1j_2}\delta^{i_2j}\delta^{ij_1} +%%% \delta^{i_3j_4}\delta^{i_4i}\delta^{jj_3} +%%% + \delta^{i_1j_2}\delta^{i_2j}\delta^{ij_1} +%%% \delta^{i_3i}\delta^{jj_4}\delta^{i_4j_3} \qquad\qquad\\\qquad\qquad +%%% + \delta^{i_1j}\delta^{ij_2}\delta^{i_2j_1} +%%% \delta^{i_3j_4}\delta^{i_4i}\delta^{jj_3} +%%% - \delta^{i_1j}\delta^{ij_2}\delta^{i_2j_1} +%%% \delta^{i_3i}\delta^{jj_4}\delta^{i_4j_3} \\ + = \\ + - \delta^{i_1j_2}\delta^{i_2j_3}\delta^{i_3j_4}\delta^{i_4j_1} + + \delta^{i_1j_2}\delta^{i_2j_4}\delta^{i_3j_1}\delta^{i_4j_3} + + \delta^{i_1j_3}\delta^{i_2j_1}\delta^{i_3j_4}\delta^{i_4j_2} + - \delta^{i_1j_4}\delta^{i_2j_1}\delta^{i_3j_2}\delta^{i_4j_3} +%%% \\ +%%% = - \delta^{i_1j_2}\delta^{i_2j_3}\delta^{i_3j_4}\delta^{i_4j_1} +%%% + \delta^{i_1j_2}\delta^{i_2j_4}\delta^{i_4j_3}\delta^{i_3j_1} +%%% + \delta^{i_1j_3}\delta^{i_3j_4}\delta^{i_4j_2}\delta^{i_2j_1} +%%% - \delta^{i_1j_4}\delta^{i_4j_3}\delta^{i_3j_2}\delta^{i_2j_1} \\ +%%% = - \delta^{i_1j_2} \left( \delta^{i_2j_3}\delta^{i_3j_4}\delta^{i_4j_1} +%%% - \delta^{i_2j_4}\delta^{i_4j_3}\delta^{i_3j_1} \right) +%%% + \delta^{i_2j_1} \left( \delta^{i_1j_3}\delta^{i_3j_4}\delta^{i_4j_2} +%%% - \delta^{i_1j_4}\delta^{i_4j_3}\delta^{i_3j_2} \right)\\ +%%% = - \left( \delta^{i_4j_1}\delta^{i_1j_2}\delta^{i_2j_3} +%%% - \delta^{i_4j_2}\delta^{i_2j_1}\delta^{i_1j_3} \right)\delta^{i_3j_4} +%%% + \left( \delta^{i_3j_1}\delta^{i_1j_2}\delta^{i_2j_4} +%%% - \delta^{i_3j_2}\delta^{i_2j_1}\delta^{i_1j_4} \right)\delta^{i_4j_3} + \end{multline} *) + +(* +\fmfset{arrow_ang}{10} +\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 pa join pb = + pa choptip joindiameter .. pb choptail joindiameter + enddef;} +\begin{multline} +\parbox{20\unitlength}{% + \fmfframe(0,4)(0,4){% + \begin{fmfgraph*}(20,20) + \fmfleft{g1,g2} + \fmfright{g3,g4} + \fmfv{label=$1$}{g1} + \fmfv{label=$2$}{g2} + \fmfv{label=$3$}{g3} + \fmfv{label=$4$}{g4} + \fmf{gluon}{g1,v} + \fmf{gluon}{g2,v} + \fmf{gluon}{g3,v} + \fmf{gluon}{g4,v} + \fmfv{label=$g^2 f_{a_1a_2b}f_{a_3a_4b}$,label.d=10thick}{v} + \fmfdot{v} + \end{fmfgraph*}}} +\qquad\qquad\qquad\Longleftrightarrow\\ +\parbox{20\unitlength}{% + \fmfframe(0,4)(0,4){% + \begin{fmfgraph*}(20,20) + \fmfleft{g1,g2} + \fmfright{g4,g3} + \fmfv{label=$1$}{g1} + \fmfv{label=$2$}{g2} + \fmfv{label=$3$}{g3} + \fmfv{label=$4$}{g4} + \fmf{phantom}{g1,v} + \fmf{phantom}{g2,v} + \fmf{phantom}{g3,v} + \fmf{phantom}{g4,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(__g4,__v))) + sideways thick} + \fmfi{plain}{(vpath(__g4,__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}{vpath (__g4, __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} + \fmfi{phantom_arrow}{(reverse vpath (__g4, __v)) sideways thick} + \fmfv{label=$-\frac{g^2}{2} + \delta^{i_1j_2}\delta^{i_2j_3}\delta^{i_3j_4}\delta^{i_4j_1}$, + label.d=10thick}{v} + \end{fmfgraph*}}} +\qquad\qquad\qquad\qquad\qquad +\parbox{20\unitlength}{% + \fmfframe(0,4)(0,4){% + \begin{fmfgraph*}(20,20) + \fmfleft{g1,g2} + \fmfright{g4,g3} + \fmfv{label=$1$}{g1} + \fmfv{label=$2$}{g2} + \fmfv{label=$3$}{g3} + \fmfv{label=$4$}{g4} + \fmf{phantom}{g1,v} + \fmf{phantom}{g2,v} + \fmf{phantom}{g3,v} + \fmf{phantom}{g4,v} + \fmffreeze + \fmfi{plain}{(vpath(__g1,__v) join (reverse vpath(__g4,__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{plain}{(vpath(__g4,__v) join (reverse vpath(__g3,__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}{vpath (__g4, __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} + \fmfi{phantom_arrow}{(reverse vpath (__g4, __v)) sideways thick} + \fmfv{label=$-\frac{g^2}{2} + \delta^{i_1j_4}\delta^{i_4j_3}\delta^{i_3j_2}\delta^{i_2j_1}$, + label.d=10thick}{v} + \end{fmfgraph*}}}\\ +\parbox{20\unitlength}{% + \fmfframe(0,4)(0,4){% + \begin{fmfgraph*}(20,20) + \fmfleft{g1,g2} + \fmfright{g4,g3} + \fmfv{label=$1$}{g1} + \fmfv{label=$2$}{g2} + \fmfv{label=$3$}{g3} + \fmfv{label=$4$}{g4} + \fmf{phantom}{g1,v} + \fmf{phantom}{g2,v} + \fmf{phantom}{g3,v} + \fmf{phantom}{g4,v} + \fmffreeze + \fmfi{plain}{(vpath(__g1,__v) join (reverse vpath(__g2,__v))) + sideways thick} + \fmfi{plain}{(vpath(__g2,__v) join (reverse vpath(__g4,__v))) + sideways thick} + \fmfi{plain}{(vpath(__g3,__v) join (reverse vpath(__g1,__v))) + sideways thick} + \fmfi{plain}{(vpath(__g4,__v) join (reverse vpath(__g3,__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}{vpath (__g4, __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} + \fmfi{phantom_arrow}{(reverse vpath (__g4, __v)) sideways thick} + \fmfv{label=$\frac{g^2}{2} + \delta^{i_1j_2}\delta^{i_2j_4}\delta^{i_4j_3}\delta^{i_3j_1}$, + label.d=10thick}{v} + \end{fmfgraph*}}} +\qquad\qquad\qquad\qquad\qquad +\parbox{20\unitlength}{% + \fmfframe(0,4)(0,4){% + \begin{fmfgraph*}(20,20) + \fmfleft{g1,g2} + \fmfright{g4,g3} + \fmfv{label=$1$}{g1} + \fmfv{label=$2$}{g2} + \fmfv{label=$3$}{g3} + \fmfv{label=$4$}{g4} + \fmf{phantom}{g1,v} + \fmf{phantom}{g2,v} + \fmf{phantom}{g3,v} + \fmf{phantom}{g4,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(__g4,__v))) + sideways thick} + \fmfi{plain}{(vpath(__g4,__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}{vpath (__g4, __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} + \fmfi{phantom_arrow}{(reverse vpath (__g4, __v)) sideways thick} + \fmfv{label=$\frac{g^2}{2} + \delta^{i_1j_3}\delta^{i_3j_4}\delta^{i_4j_2}\delta^{i_2j_1}$, + label.d=10thick}{v} + \end{fmfgraph*}}}\\ +\end{multline} *) + + (* Summing over the the permutations of~$\{2,3,4\}$, + i.\,e.~$\mathcal{P}_4$ in~\eqref{eq:P4}, we recover~\eqref{eq:4GV}. + However, there is no need to do that and things are + actually simpler, because the Lorentz structure remains + the same and there is no need for us to touch it. *) + + (* \begin{dubious} + FIXME: think deeper! + We're probably fooling ourselves here regarding + ignoring [fuse], since our testcase is the fully + symmetric 4-gluon-vertex. + \end{dubious} *) + +(* Eventually, the type [Coupling.fuse3] will be retired in + favor of [int * int * int * int] or even [int list]. This is why we + have code that is more general than required here. *) + + let fuse3_to_list = function + | F123 -> [4;1;2;3] + | F231 -> [4;2;3;1] + | F312 -> [4;3;1;2] + | F132 -> [4;1;3;2] + | F321 -> [4;3;2;1] + | F213 -> [4;2;1;3] + | F124 -> [3;1;2;4] + | F241 -> [3;2;4;1] + | F412 -> [3;4;1;2] + | F142 -> [3;1;4;2] + | F421 -> [3;4;2;1] + | F214 -> [3;2;1;4] + | F134 -> [2;1;3;4] + | F341 -> [2;3;4;1] + | F413 -> [2;4;1;3] + | F143 -> [2;1;4;3] + | F431 -> [2;4;3;1] + | F314 -> [2;3;1;4] + | F234 -> [1;2;3;4] + | F342 -> [1;3;4;2] + | F423 -> [1;4;2;3] + | F243 -> [1;2;4;3] + | F432 -> [1;4;3;2] + | F324 -> [1;3;2;4] + + let partial_map_undoing_fuse3 fuse3 = + partial_map_undoing_permutation [1;2;3;4] (fuse3_to_list fuse3) + + (* Compute the partial maps once, not everytime anew! *) + let undo_F123 = partial_map_undoing_fuse3 F123 + let undo_F231 = partial_map_undoing_fuse3 F231 + let undo_F312 = partial_map_undoing_fuse3 F312 + let undo_F132 = partial_map_undoing_fuse3 F132 + let undo_F321 = partial_map_undoing_fuse3 F321 + let undo_F213 = partial_map_undoing_fuse3 F213 + let undo_F124 = partial_map_undoing_fuse3 F124 + let undo_F241 = partial_map_undoing_fuse3 F241 + let undo_F412 = partial_map_undoing_fuse3 F412 + let undo_F142 = partial_map_undoing_fuse3 F142 + let undo_F421 = partial_map_undoing_fuse3 F421 + let undo_F214 = partial_map_undoing_fuse3 F214 + let undo_F134 = partial_map_undoing_fuse3 F134 + let undo_F341 = partial_map_undoing_fuse3 F341 + let undo_F413 = partial_map_undoing_fuse3 F413 + let undo_F143 = partial_map_undoing_fuse3 F143 + let undo_F431 = partial_map_undoing_fuse3 F431 + let undo_F314 = partial_map_undoing_fuse3 F314 + let undo_F234 = partial_map_undoing_fuse3 F234 + let undo_F342 = partial_map_undoing_fuse3 F342 + let undo_F423 = partial_map_undoing_fuse3 F423 + let undo_F243 = partial_map_undoing_fuse3 F243 + let undo_F432 = partial_map_undoing_fuse3 F432 + let undo_F324 = partial_map_undoing_fuse3 F324 + + let undo_permutation_of_fuse3 fuse3 = + let fail _ = invalid_arg "permutation_of_fuse3" in + match fuse3 with + | F123 -> PosMap.apply_with_fallback fail undo_F123 + | F231 -> PosMap.apply_with_fallback fail undo_F231 + | F312 -> PosMap.apply_with_fallback fail undo_F312 + | F132 -> PosMap.apply_with_fallback fail undo_F132 + | F321 -> PosMap.apply_with_fallback fail undo_F321 + | F213 -> PosMap.apply_with_fallback fail undo_F213 + | F124 -> PosMap.apply_with_fallback fail undo_F124 + | F241 -> PosMap.apply_with_fallback fail undo_F241 + | F412 -> PosMap.apply_with_fallback fail undo_F412 + | F142 -> PosMap.apply_with_fallback fail undo_F142 + | F421 -> PosMap.apply_with_fallback fail undo_F421 + | F214 -> PosMap.apply_with_fallback fail undo_F214 + | F134 -> PosMap.apply_with_fallback fail undo_F134 + | F341 -> PosMap.apply_with_fallback fail undo_F341 + | F413 -> PosMap.apply_with_fallback fail undo_F413 + | F143 -> PosMap.apply_with_fallback fail undo_F143 + | F431 -> PosMap.apply_with_fallback fail undo_F431 + | F314 -> PosMap.apply_with_fallback fail undo_F314 + | F234 -> PosMap.apply_with_fallback fail undo_F234 + | F342 -> PosMap.apply_with_fallback fail undo_F342 + | F423 -> PosMap.apply_with_fallback fail undo_F423 + | F243 -> PosMap.apply_with_fallback fail undo_F243 + | F432 -> PosMap.apply_with_fallback fail undo_F432 + | F324 -> PosMap.apply_with_fallback fail undo_F324 + + let apply_fuse3 fuse3 (a1, a2, a3, a4) = + let p = undo_permutation_of_fuse3 fuse3 in + (p a1, p a2, p a3, p a4) + + let colorize_fusion3_ufo f1 f2 f3 f c v spins color fuse xtra = + let open Color in + match color with + | Trivial4 -> + let v = V4 (UFO4 (c, v, spins, color), fuse, xtra) in + colorize_fusion3_legacy f1 f2 f3 (f, v) + | FF ((a1, a2), (a3, a4)) -> + let v eps = + let c' = if eps < 0 then QC.neg c else c in + V4 (UFO4 (c', v, spins, Trivial4), fuse, xtra) in + let eps, ((a1, a2), (a3, a4)) + = canonicalize_ff ((a1, a2), (a3, a4)) in + begin match a1, a2, a3, a4, f1, f2, f3 with + | 1, 2, 3, 4, CF_io (_, i1, j1), CF_io (_, i2, j2), CF_io (_, i3, j3) + | 1, 3, 2, 4, CF_io (_, i2, j2), CF_io (_, i3, j3), CF_io (_, i1, j1) + | 1, 4, 2, 3, CF_io (_, i3, j3), CF_io (_, i1, j1), CF_io (_, i2, j2) -> + + (* FIXME: hack alert! Better canonicalize to cyclic [a2], [a3], + [a4]!!! *) + let eps = if a2 = 3 then -eps else eps in + + if j1 = i2 && j2 = i3 then (* $-\delta^{i_4j_1}\delta^{i_1j_2}\delta^{i_2j_3}\delta^{i_3j_4}$ *) + [CF_io (f, i1, j3), v (-eps)] + else if j2 = i1 && j1 = i3 then (* $+\delta^{i_4j_2}\delta^{i_2j_1}\delta^{i_1j_3}\delta^{i_3j_4}$ *) + [CF_io (f, i2, j3), v ( eps)] + else if j3 = i1 && j1 = i2 then (* $+\delta^{i_4j_3}\delta^{i_3j_1}\delta^{i_1j_2}\delta^{i_2j_4}$ *) + [CF_io (f, i3, j2), v ( eps)] + else if j3 = i2 && j2 = i1 then (* $-\delta^{i_4j_3}\delta^{i_3j_2}\delta^{i_2j_1}\delta^{i_1j_4}$ *) + [CF_io (f, i3, j1), v (-eps)] + else + [] + + | _, _, _, _, CF_io _, CF_io _, CF_io _ -> + Printf.eprintf "(%d, %d), (%d, %d) %d\n" a1 a2 a3 a4 eps; + failwith "Colorize.colorize_fusion3_ufo: incomplete" + + | _, _, _, _, + (CF_io _ | CF_aux _), + (CF_io _ | CF_aux _), + (CF_io _ | CF_aux _) -> + [] + + | _ -> + impossible "f_{abe}*f_{cde} for non-adjoints" + + end + | _ -> failwith "Colorize.colorize_fusion3_ufo: incomplete" + + + let colorize_fusion3 f1 f2 f3 (f, v) = + match v with + | V4 (UFO4 (_, _, _, C.Legacy4), _, _) -> + colorize_fusion3_legacy f1 f2 f3 (f, v) + | V4 (UFO4 (c, v, spins, color), fuse, xtra) -> + colorize_fusion3_ufo f1 f2 f3 f c v spins color fuse xtra + | V4 _ -> colorize_fusion3_legacy f1 f2 f3 (f, v) + | _ -> invalid_arg "Colorize.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 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 () let fuse2 f1 f2 = ThoList.flatmap (colorize_fusion2 f1 f2) (M.fuse2 (flavor_sans_color f1) (flavor_sans_color f2)) let fuse3 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_list flist = ThoList.flatmap (colorize_fusionn flist) (M.fuse (List.map flavor_sans_color flist)) 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} *) let count_color_strings f_list = let rec count_color_strings' n_in n_out n_glue = function | f :: rest -> begin match M.color f with | C.Singlet -> count_color_strings' n_in n_out n_glue rest | C.SUN nc -> if nc > 0 then count_color_strings' (succ n_in) n_out n_glue rest else if nc < 0 then count_color_strings' n_in (succ n_out) n_glue rest else su0 "count_color_strings" | C.AdjSUN _ -> count_color_strings' (succ n_in) (succ n_out) (succ n_glue) rest end | [] -> (n_in, n_out, n_glue) in count_color_strings' 0 0 0 f_list let external_color_flows f_list = let n_in, n_out, n_glue = 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 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 tail_opt = function | [] -> [] | _ :: tail -> tail let head_req = function | [] -> invalid_arg "Colorize.It().colorize_crossed_amplitude1: insufficient flows" | x :: _ -> x let rec colorize_crossed_amplitude1 ghosts acc f_list (ecf_in, ecf_out) = match f_list, ecf_in, ecf_out with | [], [], [] -> [List.rev acc] | [], _, _ -> invalid_arg "Colorize.It().colorize_crossed_amplitude1: leftover flows" | f :: rest, _, _ -> begin match M.color f with | C.Singlet -> colorize_crossed_amplitude1 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) else if nc < 0 then colorize_crossed_amplitude1 ghosts (CF_out (f, head_req ecf_out) :: acc) rest (ecf_in, tail_opt 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 if ghosts then colorize_crossed_amplitude1 ghosts (CF_aux f :: acc) rest (tail_opt ecf_in, tail_opt ecf_out) else [] end else colorize_crossed_amplitude1 ghosts (CF_io (f, ecf_in', ecf_out') :: acc) rest (tail_opt ecf_in, tail_opt 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 f_list = ThoList.rev_flatmap (colorize_crossed_amplitude1 (external_ghosts f_list) f_list) (external_color_flows f_list) 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. *) 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 () 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 module Ch = CM.Ch let charges = CM.charges let flavor_sans_color = CM.flavor_sans_color 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 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/thoList.ml =================================================================== --- trunk/omega/src/thoList.ml (revision 8252) +++ trunk/omega/src/thoList.ml (revision 8253) @@ -1,335 +1,408 @@ (* thoList.ml -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) let 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 (* 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 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 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' (* 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 "tl" -> invalid_arg "ThoList.transpose: not rectangular" let compare ?(cmp=Pervasives.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 Pervasives.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 rec clone n x = if n < 0 then invalid_arg "ThoList.clone" else if n = 0 then [] else x :: clone (pred n) x 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 -module ISet = Set.Make (struct type t = int let compare = Pervasives.compare end) - exception Overlapping_indices exception Out_of_bounds let iset_of_list list = - List.fold_right ISet.add list ISet.empty + List.fold_right Sets.Int.add list Sets.Int.empty let iset_list_union list = - List.fold_right ISet.union list ISet.empty + List.fold_right Sets.Int.union list Sets.Int.empty let complement_index_sets n index_set_lists = let index_sets = List.map iset_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 -> ISet.cardinal s + acc) 0 index_sets in - if size_index_sets <> ISet.cardinal index_set then + 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 ISet.exists (fun i -> i < 0 || i >= n) index_set then + else if Sets.Int.exists (fun i -> i < 0 || i >= n) index_set then raise Overlapping_indices else - match ISet.elements (ISet.diff (iset_of_list (range 0 (pred n))) index_set) with + match Sets.Int.elements + (Sets.Int.diff (iset_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=Pervasives.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) -> Pervasives.compare n1 n2) (List.map2 (fun n a -> (n, a)) indices sorted)) let lexicographic ?(cmp=Pervasives.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 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 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 to_string a2s alist = + "[" ^ String.concat "; " (List.map a2s alist) ^ "]" + + +module Test = + struct + + open OUnit + + 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_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 = + "ThoList" >::: + [suite_alist_of_list; + suite_complement] + + end (*i * Local Variables: * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * compile-command:"ocamlc -o vertex thoList.ml{i,} pmap.ml{i,} vertex.ml" * End: i*) Index: trunk/omega/src/Makefile.sources =================================================================== --- trunk/omega/src/Makefile.sources (revision 8252) +++ trunk/omega/src/Makefile.sources (revision 8253) @@ -1,292 +1,293 @@ # Makefile.sources -- Makefile component for O'Mega ## ## Process Makefile.am with automake to include this file in Makefile.in ## ######################################################################## # # Copyright (C) 1999-2019 by # Wolfgang Kilian # Thorsten Ohl # Juergen Reuter # with contributions from # cf. main AUTHORS file # # WHIZARD is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # WHIZARD is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ######################################################################## ## ## 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 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 = UFOx_syntax.ml UFOx.ml UFO_syntax.ml UFO.ml -UFO_ML = UFOx_syntax.ml UFO_syntax.ml $(UFO_MLD) UFOx.ml UFO.ml +UFO_ML_PRIMARY = UFOx_syntax.ml UFOx.ml UFO_syntax.ml UFO_targets.ml UFO.ml +UFO_ML = UFOx_syntax.ml UFO_syntax.ml $(UFO_MLD) UFOx.ml UFO_targets.ml UFO.ml OMEGA_MLL = $(CASCADE_MLL) $(VERTEX_MLL) $(UFO_MLL) OMEGA_MLY = $(CASCADE_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. ######################################################################## OMEGA_CORE_ML_PART1 = \ OUnit.ml OUnitDiff.ml \ - config.ml partial.ml pmap.ml \ - thoList.ml thoArray.ml thoString.ml permutation.ml bundle.ml powSet.ml \ + config.ml partial.ml pmap.ml sets.ml format_Fortran.ml \ + thoList.ml thoArray.ml thoString.ml bundle.ml powSet.ml \ thoFilename.ml cache.ml progress.ml trie.ml linalg.ml tree2.ml \ - algebra.ml options.ml product.ml combinatorics.ml partition.ml tree.ml \ + algebra.ml options.ml product.ml combinatorics.ml \ + permutation.ml partition.ml tree.ml \ tuple.ml topology.ml DAG.ml momentum.ml phasespace.ml \ charges.ml color.ml modeltools.ml whizard.ml OMEGA_CORE_ML_PART2 = \ $(VERTEX_ML) $(UFO_ML) $(CASCADE_ML) OMEGA_CORE_ML_PART2_PRIMARY = \ $(VERTEX_ML_PRIMARY) $(UFO_ML_PRIMARY) $(CASCADE_ML_PRIMARY) OMEGA_CORE_ML_PART3 = \ colorize.ml process.ml fusion.ml omega.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_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 \ 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 = \ 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_CORE_CMO = $(OMEGA_CORE_ML:.ml=.cmo) OMEGA_CORE_CMX = $(OMEGA_CORE_ML:.ml=.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_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/try_ufo.sh =================================================================== --- trunk/omega/src/try_ufo.sh (revision 0) +++ trunk/omega/src/try_ufo.sh (revision 8253) @@ -0,0 +1,26 @@ +#! /bin/sh + +jobs=12 + +UFO_SM=$HOME/physics/SM/ +UFO_SMEFT=$HOME/physics/SMEFT_mW_UFO/ +UFO_SMEFT=$HOME/physics/SMEFTsim_A_U35_alphaScheme_UFO_v2_1/ + +root=$HOME/physics/whizard +build=$root/_build + +case X"$1" in + X"-SM") UFO=$UFO_SM; shift;; + X"-SMEFT") UFO=$UFO_SMEFT; shift;; + *) UFO=$UFO_SM;; +esac + +OCAMLFLAGS="-w -D -warn-error +P" +make OCAMLFLAGS="$OCAMLFLAGS" -j $jobs -C $build/omega/src || exit 1 +make -j $jobs -C $build/omega/bin omega_UFO.opt || exit 1 + +omega="$build/omega/bin/omega_UFO.opt -model:UFO_dir $UFO -model:exec -target:parameter_module parameters_ufo" + +( $omega -params; $omega -scatter "$1" ) > omega_amplitude.f90 + +gfortran -Wall -c -I ../../_build/omega/src/ omega_amplitude.f90 Property changes on: trunk/omega/src/try_ufo.sh ___________________________________________________________________ Added: svn:executable ## -0,0 +1 ## +* \ No newline at end of property Index: trunk/omega/src/UFO_targets.mli =================================================================== --- trunk/omega/src/UFO_targets.mli (revision 0) +++ trunk/omega/src/UFO_targets.mli (revision 8253) @@ -0,0 +1,93 @@ +(* uFO_targets.mli -- + + Copyright (C) 1999-2017 by + + Wolfgang Kilian + Thorsten Ohl + Juergen Reuter + with contributions from + Christian Speckner + + WHIZARD is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + WHIZARD is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) + +(* \thocwmodulesection{Generating Code for UFO Lorentz Structures} *) + +module type T = + sig + + (* NB: The [spins : int list] argument is \emph{not} sufficient + to determine the domain and codomain of the function. We + will need to inspect the flavors, where the Lorentz structure + is referenced. *) + val lorentz : + Format_Fortran.formatter -> string -> Coupling.lorentz array -> + UFOx.Lorentz.t -> unit + + val fusion2 : + Algebra.QC.t -> string -> Coupling.lorentz3 -> + string -> string -> string -> string -> string -> Coupling.fuse2 -> unit + val fusion3 : + Algebra.QC.t -> string -> Coupling.lorentz4 -> + string -> string -> string -> string -> string -> + string -> string -> Coupling.fuse3 -> unit + val fusionn : + Algebra.QC.t -> string -> Coupling.lorentzn -> + 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 + + end + +module Fortran : T + +(* only for debugging: *) +module Lorentz_Fusion : sig + type t + val parse : Coupling.lorentz list -> UFOx.Lorentz.t -> t + val to_string : t -> string +end + +module type Dirac = + 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 test_suite : OUnit.test + end + +module Dirac : Dirac Index: trunk/omega/src/UFO.mli =================================================================== --- trunk/omega/src/UFO.mli (revision 8252) +++ trunk/omega/src/UFO.mli (revision 8253) @@ -1,57 +1,89 @@ (* vertex.mli -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) 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 -val parse_directory : string -> t -val dump : t -> unit - + exception Unhandled of string module Model : Model.T +val parse_directory : string -> t + +module type Fortran_Target = + sig + + val fusion2 : + Algebra.QC.t -> string -> Coupling.lorentz3 -> + string -> string -> string -> string -> string -> Coupling.fuse2 -> unit + val fusion3 : + Algebra.QC.t -> string -> Coupling.lorentz4 -> + string -> string -> string -> string -> string -> + string -> string -> Coupling.fuse3 -> unit + val fusionn : + Algebra.QC.t -> string -> Coupling.lorentzn -> + string -> string list -> string list -> Coupling.fusen -> unit + + val lorentz : + ?only:Sets.String.t -> Format_Fortran.formatter -> unit -> unit + + val lorentz_module : + ?only:Sets.String.t -> ?name:string -> + Format_Fortran.formatter -> unit -> unit + + end + +module Targets : + sig + module Fortran : Fortran_Target + end + module type Test = sig val example : unit -> unit val suite : OUnit.test end Index: trunk/omega/src/combinatorics.mli =================================================================== --- trunk/omega/src/combinatorics.mli (revision 8252) +++ trunk/omega/src/combinatorics.mli (revision 8253) @@ -1,170 +1,171 @@ (* combinatorics.mli -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter with contributions from Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) (* This type is defined just for documentation. Below, most functions will construct a (possibly nested) [list] of partitions or permutations of a ['a seq]. *) type 'a seq = 'a list (* \thocwmodulesection{Simple Combinatorial Functions} *) (* The functions \begin{subequations} \begin{align} \ocwlowerid{factorial}:\;& n \to n! \\ \ocwlowerid{binomial}:\; & (n, k) \to \binom{n}{k} = \frac{n!}{k!(n-k)!} \\ \ocwlowerid{multinomial}:\; & \lbrack n_1; n_2; \ldots; n_k \rbrack \to \binom{n_1+n_2+\ldots+n_k}{n_1,n_2,\ldots,n_k} = \frac{(n_1+n_2+\ldots+n_k)!}{n_1!n_2!\cdots n_k!} \end{align} \end{subequations} have not been optimized. They can quickly run out of the range of native integers. *) val factorial : int -> int val binomial : int -> int -> int val multinomial : int list -> int (* [symmetry l] returns the size of the symmetric group on~[l], i.\,e.~the product of the factorials of the numbers of identical elements. *) val symmetry : 'a list -> int (* \thocwmodulesection{Partitions} *) (* $\ocwlowerid{partitions}\, \lbrack n_1;n_2;\ldots;n_k \rbrack\, \lbrack x_1;x_2;\ldots;x_n\rbrack$, where $n=n_1+n_2+\ldots+n_k$, returns all inequivalent partitions of $\lbrack x_1;x_2;\ldots;x_n\rbrack$ into parts of size $n_1$, $n_2$, \ldots, $n_k$. The order of the $n_i$ is not respected. There are \begin{equation} \frac{1}{S(n_1,n_2,\ldots,n_k)} \binom{n_1+n_2+\ldots+n_k}{n_1,n_2,\ldots,n_k} \end{equation} such partitions, where the symmetry factor~$S(n_1,n_2,\ldots,n_k)$ is the size of the permutation group of~$\lbrack n_1;n_2;\ldots;n_k \rbrack$ as determined by the function [symmetry]. *) val partitions : int list -> 'a seq -> 'a seq list list (* [ordered_partitions] is identical to [partitions], except that the order of the $n_i$ is respected. There are \begin{equation} \binom{n_1+n_2+\ldots+n_k}{n_1,n_2,\ldots,n_k} \end{equation} such partitions. *) val ordered_partitions : int list -> 'a seq -> 'a seq list list (* [keystones m l] is equivalent to [partitions m l], except for the special case when the length of~[l] is even and~[m] contains a part that has exactly half the length of~[l]. In this case only the half of the partitions is created that has the head of~[l] in the longest part. *) val keystones : int list -> 'a seq -> 'a seq list list (* It can be beneficial to factorize a common part in the partitions and keystones: *) val factorized_partitions : int list -> 'a seq -> ('a seq * 'a seq list list) list val factorized_keystones : int list -> 'a seq -> ('a seq * 'a seq list list) list (* \thocwmodulesubsection{Special Cases} *) (* [partitions] is built from components that can be convenient by themselves, even thepugh they are just special cases of [partitions]. [split k l] returns the list of all inequivalent splits of the list~[l] into one part of length~[k] and the rest. There are \begin{equation} \frac{1}{S(|l|-k,k)} \binom{|l|}{k} \end{equation} such splits. After replacing the pairs by two-element lists, [split k l] is equivalent to [partitions [k; length l - k] l].*) val split : int -> 'a seq -> ('a seq * 'a seq) list (* Create both equipartitions of lists of even length. There are \begin{equation} \binom{|l|}{k} \end{equation} such splits. After replacing the pairs by two-element lists, the result of [ordered_split k l] is equivalent to [ordered_partitions [k; length l - k] l].*) val ordered_split : int -> 'a seq -> ('a seq * 'a seq) list (* [multi_split n k l] returns the list of all inequivalent splits of the list~[l] into~[n] parts of length~[k] and the rest. *) val multi_split : int -> int -> 'a seq -> ('a seq list * 'a seq) list val ordered_multi_split : int -> int -> 'a seq -> ('a seq list * 'a seq) list (* \thocwmodulesection{Choices} *) (* $\ocwlowerid{choose}\,n\,\lbrack x_1;x_2;\ldots;x_n\rbrack$ returns the list of all $n$-element subsets of~$\lbrack x_1;x_2;\ldots;x_n\rbrack$. [choose n] is equivalent to $(\ocwlowerid{map}\,\ocwlowerid{fst})\circ (\ocwlowerid{ordered\_split}\,\ocwlowerid{n})$. *) val choose : int -> 'a seq -> 'a seq list (* [multi_choose n k] is equivalent to $(\ocwlowerid{map}\,\ocwlowerid{fst})\circ (\ocwlowerid{multi\_split}\,\ocwlowerid{n}\,\ocwlowerid{k})$. *) val multi_choose : int -> int -> 'a seq -> 'a seq list list val ordered_multi_choose : int -> int -> 'a seq -> 'a seq list list (* \thocwmodulesection{Permutations} *) val permute : 'a seq -> 'a seq list (* \thocwmodulesubsection{Graded Permutations} *) val permute_signed : 'a seq -> (int * 'a seq) list val permute_even : 'a seq -> 'a seq list val permute_odd : 'a seq -> 'a seq list +val permute_cyclic : 'a seq -> 'a seq list (* \thocwmodulesubsection{Tensor Products of Permutations} *) (* In other words: permutations which respect compartmentalization. *) val permute_tensor : 'a seq list -> 'a seq list list val permute_tensor_signed : 'a seq list -> (int * 'a seq list) list val permute_tensor_even : 'a seq list -> 'a seq list list val permute_tensor_odd : 'a seq list -> 'a seq list list val sign : ?cmp:('a -> 'a -> int) -> 'a seq -> int (* \thocwmodulesubsection{Sorting} *) val sort_signed : ?cmp:('a -> 'a -> int) -> 'a seq -> int * 'a seq (* \thocwmodulesubsection{Unit Tests} *) module Test : sig val suite : OUnit.test end (*i * Local Variables: * indent-tabs-mode:nil * page-delimiter:"^(\\* .*\n" * End: i*) Index: trunk/omega/tests/ward.f90 =================================================================== --- trunk/omega/tests/ward.f90 (revision 8252) +++ trunk/omega/tests/ward.f90 (revision 8253) @@ -1,106 +0,0 @@ -! ward.f90 -- -! ward.f90 -- check On Shell Ward Identities in O'Mega -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! Copyright (C) 1999-2019 by -! Wolfgang Kilian -! Thorsten Ohl -! Juergen Reuter -! Christian Speckner -! -! WHIZARD is free software; you can redistribute it and/or modify it -! under the terms of the GNU General Public License as published by -! the Free Software Foundation; either version 2, or (at your option) -! any later version. -! -! WHIZARD is distributed in the hope that it will be useful, but -! WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -module interface_ward_physical - use omega_interface - use amplitude_ward_physical - implicit none - private - public :: load -contains - pure 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_ward_physical - -module interface_ward_unphysical - use omega_interface - use amplitude_ward_unphysical - implicit none - private - public :: load -contains - pure 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_ward_unphysical - -program ward - use kinds - use ward_lib - use interface_ward_physical, load_physical => load - use interface_ward_unphysical, load_unphysical => load - use parameters_ward - implicit none - integer, parameter :: N = 1000 - real(kind=default), parameter :: THRESHOLD=0.7 - real(kind=default), parameter :: ROOTS = 1000 - integer, parameter :: SEED = 42 - integer :: failures, attempts - call init_parameters () - call check (load_physical (), load_unphysical (), & - roots = ROOTS, threshold = THRESHOLD, n = N, seed = SEED, & - failures = failures, attempts = attempts) - if (failures .gt. attempts) then - stop 2 - else if (failures .gt. 0) then - print *, failures, " failures in ", attempts, " attempts" - stop 1 - end if -end program ward - Index: trunk/omega/tests/compare.f90 =================================================================== --- trunk/omega/tests/compare.f90 (revision 8252) +++ trunk/omega/tests/compare.f90 (revision 8253) @@ -1,310 +0,0 @@ -! compare.f90 -- -! compare.f90 -- compare amplitudes created by two versions of O'Mega -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -! -! Copyright (C) 1999-2019 by -! Wolfgang Kilian -! Thorsten Ohl -! Juergen Reuter -! Christian Speckner -! -! WHIZARD is free software; you can redistribute it and/or modify it -! under the terms of the GNU General Public License as published by -! the Free Software Foundation; either version 2, or (at your option) -! any later version. -! -! WHIZARD is distributed in the hope that it will be useful, but -! WITHOUT ANY WARRANTY; without even the implied warranty of -! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the -! GNU General Public License for more details. -! -! You should have received a copy of the GNU General Public License -! along with this program; if not, write to the Free Software -! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. -! -!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! - -module compare_lib - - use kinds - use constants - use omega95 - - use parameters_QCD - - use amplitude_compare_v1, & - v1_number_particles_in => number_particles_in, & - v1_number_particles_out => number_particles_out, & - v1_number_spin_states => number_spin_states, & - v1_spin_states => spin_states, & - v1_number_flavor_states => number_flavor_states, & - v1_flavor_states => flavor_states, & - v1_number_color_flows => number_color_flows, & - v1_color_flows => color_flows, & - v1_number_color_indices => number_color_indices, & - v1_number_color_factors => number_color_factors, & - v1_color_factors => color_factors, & - v1_color_sum => color_sum, & - v1_reset_helicity_selection => reset_helicity_selection, & - v1_new_event => new_event, & - v1_is_allowed => is_allowed, & - v1_get_amplitude => get_amplitude - - use amplitude_compare_v2, & - v2_number_particles_in => number_particles_in, & - v2_number_particles_out => number_particles_out, & - v2_number_spin_states => number_spin_states, & - v2_spin_states => spin_states, & - v2_number_flavor_states => number_flavor_states, & - v2_flavor_states => flavor_states, & - v2_number_color_flows => number_color_flows, & - v2_color_flows => color_flows, & - v2_number_color_indices => number_color_indices, & - v2_number_color_factors => number_color_factors, & - v2_color_factors => color_factors, & - v2_color_sum => color_sum, & - v2_reset_helicity_selection => reset_helicity_selection, & - v2_new_event => new_event, & - v2_is_allowed => is_allowed, & - v2_get_amplitude => get_amplitude - - implicit none - - contains - - subroutine quantum_numbers (match, n_out, n_flv, n_hel, n_col) - logical, intent(out) :: match - integer, intent(out) :: n_out, n_flv, n_hel, n_col - integer, dimension(v1_number_particles_in()+v1_number_particles_out(), & - v1_number_flavor_states()) :: v1_table_flavor_states - integer, dimension(v2_number_particles_in()+v2_number_particles_out(), & - v2_number_flavor_states()) :: v2_table_flavor_states - integer, dimension(v1_number_particles_in()+v1_number_particles_out(), & - v1_number_spin_states()) :: v1_table_spin_states - integer, dimension(v2_number_particles_in()+v2_number_particles_out(), & - v2_number_spin_states()) :: v2_table_spin_states - integer, dimension(v1_number_color_indices(), & - v1_number_particles_in()+v1_number_particles_out(), & - v1_number_color_flows()) :: v1_table_color_flows - integer, dimension(v2_number_color_indices(), & - v2_number_particles_in()+v2_number_particles_out(), & - v2_number_color_flows()) :: v2_table_color_flows - logical, dimension(v1_number_particles_in()+v1_number_particles_out(), & - v1_number_color_flows()) :: v1_table_ghost_flags - logical, dimension(v2_number_particles_in()+v2_number_particles_out(), & - v2_number_color_flows()) :: v2_table_ghost_flags - type(omega_color_factor), dimension(v1_number_color_factors()) :: v1_table_color_factors - type(omega_color_factor), dimension(v2_number_color_factors()) :: v2_table_color_factors - match = .true. - n_out = v1_number_particles_out () - n_flv = v1_number_flavor_states () - n_hel = v1_number_spin_states () - n_col = v1_number_color_flows () - call v1_flavor_states (v1_table_flavor_states) - call v2_flavor_states (v2_table_flavor_states) - call v1_spin_states (v1_table_spin_states) - call v2_spin_states (v2_table_spin_states) - call v1_color_flows (v1_table_color_flows, v1_table_ghost_flags) - call v2_color_flows (v2_table_color_flows, v2_table_ghost_flags) - call v1_color_factors (v1_table_color_factors) - call v2_color_factors (v2_table_color_factors) - if ( size (v1_table_flavor_states, dim=2) & - .ne. size (v2_table_flavor_states, dim=2)) then - match = .false. - print *, "#flavor_states don't match!" - else if (any (v1_table_flavor_states .ne. v2_table_flavor_states)) then - match = .false. - print *, "flavor states don't match!" - print *, "CAVEAT: this might be due to simple reordering!" - end if - if ( size (v1_table_spin_states, dim=2) & - .ne. size (v2_table_spin_states, dim=2)) then - match = .false. - print *, "#spin_states don't match!" - else if (any (v1_table_spin_states .ne. v2_table_spin_states)) then - match = .false. - print *, "spin states don't match!" - print *, "CAVEAT: this might be due to simple reordering!" - end if - if ( size (v1_table_color_flows, dim=3) & - .ne. size (v2_table_color_flows, dim=3)) then - match = .false. - print *, "#color_flows don't match!" - else if (any (v1_table_color_flows .ne. v2_table_color_flows)) then - match = .false. - print *, "color flows don't match!" - print *, "CAVEAT: this might be due to simple reordering!" - else if (any (v1_table_ghost_flags .neqv. v2_table_ghost_flags)) then - match = .false. - print *, "ghost flags don't match!" - print *, "CAVEAT: this might be due to simple reordering!" - end if - if ( size (v1_table_color_factors) & - .ne. size (v2_table_color_factors)) then - match = .false. - print *, "#color_factors don't match!" - else if (any (.not. color_factors_equal (v1_table_color_factors, & - v2_table_color_factors))) then - match = .false. - print *, "color factors don't match!" - print *, "CAVEAT: this might be due to simple reordering!" - end if - end subroutine quantum_numbers - - elemental function color_factors_equal (cf1, cf2) result (eq) - logical :: eq - type(omega_color_factor), intent(in) :: cf1, cf2 - eq = (cf1%i1 .eq. cf2%i1) .and. (cf1%i2 .eq. cf2%i2) .and. (cf1%factor .eq. cf2%factor) - end function color_factors_equal - - pure function dot (p, q) result (pq) - real(kind=default), dimension(0:), intent(in) :: p, q - real(kind=default) :: pq - pq = p(0)*q(0) - dot_product (p(1:), q(1:)) - end function dot - - pure function mass2 (p) result (m2) - real(kind=default), dimension(0:), intent(in) :: p - real(kind=default) :: m2 - m2 = p(0)*p(0) - p(1)*p(1) - p(2)*p(2) - p(3)*p(3) - end function mass2 - - pure subroutine beams (roots, m1, m2, p1, p2) - real(kind=default), intent(in) :: roots, m1, m2 - real(kind=default), dimension(0:), intent(out) :: p1, p2 - real(kind=default) :: m12, m22 - m12 = m1**2 - m22 = m2**2 - p1(0) = (roots**2 + m12 - m22) / (2*roots) - p1(1:2) = 0 - p1(3) = sqrt (p1(0)**2 - m12) - p2(0) = roots - p1(0) - p2(1:3) = - p1(1:3) - end subroutine beams - - ! The massless RAMBO algorithm - subroutine massless_isotropic_decay (roots, p) - real(kind=default), intent(in) :: roots - real(kind=default), dimension(0:,:), intent(out) :: p - real(kind=default), dimension(0:3,size(p,dim=2)) :: q - real(kind=default), dimension(0:3) :: qsum - real(kind=default), dimension(4) :: ran - real(kind=default) :: c, s, f, qabs, x, r, z - integer :: k - ! Generate isotropic null vectors - do k = 1, size (p, dim = 2) - call random_number (ran) - ! generate a x*exp(-x) distribution for q(0,k) - q(0,k)= -log(ran(1)*ran(2)) - c = 2*ran(3)-1 - f = 2*PI*ran(4) - s = sqrt(1-c*c) - q(2,k) = q(0,k)*s*sin(f) - q(3,k) = q(0,k)*s*cos(f) - q(1,k) = q(0,k)*c - enddo - ! Boost and rescale the vectors - qsum = sum (q, dim = 2) - qabs = sqrt (dot (qsum, qsum)) - x = roots/qabs - do k = 1, size (p, dim = 2) - r = dot (q(0:,k), qsum) / qabs - z = (q(0,k)+r)/(qsum(0)+qabs) - p(1:3,k) = x*(q(1:3,k)-qsum(1:3)*z) - p(0,k) = x*r - enddo - end subroutine massless_isotropic_decay - - subroutine expect (x, y, tolerance) - real(kind=default), intent(in) :: x, y - integer, intent(in) :: tolerance - if (abs (x - y) .gt. tolerance * epsilon (max (x, y))) then - stop 1 - end if - end subroutine expect - -end module compare_lib - -program compare - use kinds - use compare_lib - use parameters_QCD - implicit none - logical :: match - real(kind=default), parameter :: ROOTS = 1000 - real(kind=default), parameter :: SCALE = 100 - integer, parameter :: N = 10 - integer :: n_out, n_flv, n_hel, n_col - integer :: i, i_flv, i_hel, i_col, failed_moduli, failed_phases - integer :: is1, is2, is3, is4, is5, is6 - real(kind=default), dimension(:,:), allocatable :: p - complex(kind=default), dimension(:), allocatable :: a1, a2 - real(kind=default) :: r1, r2, phi1, phi2, tolerance - integer :: size - integer, dimension(:), allocatable :: seed - character(len=*), parameter :: fmt_pfx = & - "(1X,'evt=',I4,', flv=',I3,', col=',I3,', hel=',I3,', '," - call random_seed (size = size) - allocate (seed(size)) - seed = 42 - call random_seed (put = seed) - deallocate (seed) - call init_parameters - call v1_reset_helicity_selection (-1.0_default, -1) - call v2_reset_helicity_selection (-1.0_default, -1) - call quantum_numbers (match, n_out, n_flv, n_hel, n_col) - if (match) then - allocate (p(0:3,2+n_out)) - allocate (a1(n_hel), a2(n_hel)) - call beams (ROOTS, 0.0_default, 0.0_default, p(:,1), p(:,2)) - failed_moduli = 0 - failed_phases = 0 - do i = 1, N - call massless_isotropic_decay (ROOTS, p(:,3:)) - call v1_new_event (p) - call v2_new_event (p) - do i_flv = 1, n_flv - do i_col = 1, n_col - do i_hel = 1, n_hel - a1(i_hel) = v1_get_amplitude (i_flv, i_hel, i_col) - a2(i_hel) = v2_get_amplitude (i_flv, i_hel, i_col) - end do - tolerance = SCALE * epsilon (SCALE) & - * ((sum (abs (a1)) + sum (abs (a2))) / n_hel) - do i_hel = 1, n_hel - if (abs (a1(i_hel) - a2(i_hel)) .gt. tolerance) then - r1 = abs (a1(i_hel)) - r2 = abs (a2(i_hel)) - if (abs (r1 - r2) .gt. tolerance) then - write (unit = *, & - fmt = fmt_pfx // "'moduli= ',E10.4,', ',E10.4)") & - i, i_flv, i_col, i_hel, r1, r2 - failed_moduli = failed_moduli + 1 - else - phi1 = atan2 (real (a1(i_hel)), imag (a1(i_hel))) - phi2 = atan2 (real (a2(i_hel)), imag (a2(i_hel))) - write (unit = *, & - fmt = fmt_pfx // "'phases= ',F10.4,', ',F10.4)") & - i, i_flv, i_col, i_hel, phi1, phi2 - failed_phases = failed_phases + 1 - end if - end if - end do - end do - end do - end do - deallocate (p) - deallocate (a1, a2) - print *, failed_moduli + failed_phases, " failures (", & - failed_moduli, " moduli, ", failed_phases, " phases) in ", & - N * n_flv * n_hel * i_col, " attempts" - if (failed_moduli .gt. 0) then - stop 2 - else if (failed_phases .gt. 0) then - stop 1 - end if - else - stop 3 - end if -end program compare - Index: trunk/omega/tests/keystones_tools.f90 =================================================================== --- trunk/omega/tests/keystones_tools.f90 (revision 0) +++ trunk/omega/tests/keystones_tools.f90 (revision 8253) @@ -0,0 +1,211 @@ +! keystones_tools.f90 -- tools for fusion/keystone/vertex tests +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! Copyright (C) 2019- by +! Wolfgang Kilian +! Thorsten Ohl +! Juergen Reuter +! +! WHIZARD is free software; you can redistribute it and/or modify it +! under the terms of the GNU General Public License as published by +! the Free Software Foundation; either version 2, or (at your option) +! any later version. +! +! WHIZARD is distributed in the hope that it will be useful, but +! WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +module keystones_tools + ! use ieee_arithmetic + use kinds + use constants + ! use tao_random_numbers + use omega95 + + implicit none + private + + public :: make_random + + interface make_random + module procedure & + make_random_real, & + make_random_real_vector, & + make_random_real_array, & + make_random_complex, & + make_random_complex_vector, & + make_random_complex_array, & + make_random_momentum, & + make_random_momentum_vector, & + make_random_vector, & + make_random_vector_vector, & + make_random_tensor, & + make_random_tensor_vector, & + make_random_tensor2odd, & + make_random_tensor2odd_vector, & + make_random_spinor, & + make_random_spinor_vector, & + make_random_conjspinor, & + make_random_conjspinor_vector + end interface make_random + +contains + + subroutine make_random_real (x, range) + real(kind=default), intent(inout) :: x + real(kind=default), intent(in), optional :: range + call random_number (x) + x = 2*x - 1 + if (present (range)) then + x = range * x + end if + end subroutine make_random_real + + subroutine make_random_real_vector (x, range) + real(kind=default), dimension(:), intent(inout) :: x + real(kind=default), intent(in), optional :: range + call random_number (x) + x = 2*x - 1 + if (present (range)) then + x = range * x + end if + end subroutine make_random_real_vector + + subroutine make_random_real_array (x, range) + real(kind=default), dimension(:,:), intent(inout) :: x + real(kind=default), intent(in), optional :: range + call random_number (x) + x = 2*x - 1 + if (present (range)) then + x = range * x + end if + end subroutine make_random_real_array + + subroutine make_random_complex (z, range) + complex(kind=default), intent(inout) :: z + real(kind=default), intent(in), optional :: range + real(kind=default) :: x, y + call make_random_real (x, range) + call make_random_real (y, range) + z = cmplx (x, y, kind=default) + end subroutine make_random_complex + + subroutine make_random_complex_vector (z, range) + complex(kind=default), dimension(:), intent(inout) :: z + real(kind=default), intent(in), optional :: range + real(kind=default), dimension(size(z)) :: x, y + call make_random_real_vector (x, range) + call make_random_real_vector (y, range) + z = cmplx (x, y, kind=default) + end subroutine make_random_complex_vector + + subroutine make_random_complex_array (z, range) + complex(kind=default), dimension(:,:), intent(inout) :: z + real(kind=default), intent(in), optional :: range + real(kind=default), dimension(size(z, dim=1),size(z, dim=2)) :: x, y + call make_random_real_array (x, range) + call make_random_real_array (y, range) + z = cmplx (x, y, kind=default) + end subroutine make_random_complex_array + + subroutine make_random_momentum (p, range) + type(momentum), intent(inout) :: p + real(kind=default), intent(in), optional :: range + call make_random_real (p%t, range) + call make_random_real_vector (p%x, range) + end subroutine make_random_momentum + + subroutine make_random_momentum_vector (p, range) + type(momentum), dimension(:), intent(inout) :: p + real(kind=default), intent(in), optional :: range + integer :: i + do i = 1, size(p) + call make_random_momentum (p(i), range) + end do + end subroutine make_random_momentum_vector + + subroutine make_random_vector (v, range) + type(vector), intent(inout) :: v + real(kind=default), intent(in), optional :: range + call make_random_complex (v%t, range) + call make_random_complex_vector (v%x, range) + end subroutine make_random_vector + + subroutine make_random_vector_vector (v, range) + type(vector), dimension(:), intent(inout) :: v + real(kind=default), intent(in), optional :: range + integer :: i + do i = 1, size(v) + call make_random_vector (v(i), range) + end do + end subroutine make_random_vector_vector + + subroutine make_random_spinor (psi, range) + type(spinor), intent(inout) :: psi + real(kind=default), intent(in), optional :: range + call make_random_complex_vector (psi%a, range) + end subroutine make_random_spinor + + subroutine make_random_spinor_vector (psi, range) + type(spinor), dimension(:), intent(inout) :: psi + real(kind=default), intent(in), optional :: range + integer :: i + do i = 1, size(psi) + call make_random_spinor (psi(i), range) + end do + end subroutine make_random_spinor_vector + + subroutine make_random_conjspinor (psibar, range) + type(conjspinor), intent(inout) :: psibar + real(kind=default), intent(in), optional :: range + call make_random_complex_vector (psibar%a, range) + end subroutine make_random_conjspinor + + subroutine make_random_conjspinor_vector (psibar, range) + type(conjspinor), dimension(:), intent(inout) :: psibar + real(kind=default), intent(in), optional :: range + integer :: i + do i = 1, size(psibar) + call make_random_conjspinor (psibar(i), range) + end do + end subroutine make_random_conjspinor_vector + + subroutine make_random_tensor (t, range) + type(tensor), intent(inout) :: t + real(kind=default), intent(in), optional :: range + call make_random_complex_array (t%t, range) + end subroutine make_random_tensor + + subroutine make_random_tensor_vector (t, range) + type(tensor), dimension(:), intent(inout) :: t + real(kind=default), intent(in), optional :: range + integer :: i + do i = 1, size(t) + call make_random_tensor (t(i), range) + end do + end subroutine make_random_tensor_vector + + subroutine make_random_tensor2odd (t, range) + type(tensor2odd), intent(inout) :: t + real(kind=default), intent(in), optional :: range + call make_random_complex_vector (t%e, range) + call make_random_complex_vector (t%b, range) + end subroutine make_random_tensor2odd + + subroutine make_random_tensor2odd_vector (t, range) + type(tensor2odd), dimension(:), intent(inout) :: t + real(kind=default), intent(in), optional :: range + integer :: i + do i = 1, size(t) + call make_random_tensor2odd (t(i), range) + end do + end subroutine make_random_tensor2odd_vector + +end module keystones_tools Index: trunk/omega/tests/ward_identities_UFO.list =================================================================== --- trunk/omega/tests/ward_identities_UFO.list (revision 0) +++ trunk/omega/tests/ward_identities_UFO.list (revision 8253) @@ -0,0 +1,16 @@ +# ward_identities_UFO.list -- +#! +# ---------------------------------------------------------------------- +# thr n roots model i process ... +# ---------------------------------------------------------------------- +eeaa 0.30 1000 1000 SM 3 scatter e+ e- -> a a +eeaaa 0.30 1000 1000 SM 3 scatter e+ e- -> a a a +uuaa 0.25 1000 1000 SM 3 scatter u u~ -> a a +uuga 0.25 1000 1000 SM 3 scatter u u~ -> g a +uuag 0.25 1000 1000 SM 3 scatter u u~ -> a g +uugg 0.25 1000 1000 SM 3 scatter u u~ -> g g +uugga 0.25 1000 1000 SM 3 scatter u u~ -> g g a +uuagg 0.20 1000 1000 SM 3 scatter u u~ -> a g g +uuggg 0.20 1000 1000 SM 3 scatter u u~ -> g g g +gggg 0.50 1000 1000 SM 3 scatter g g -> g g +ggggg 0.50 1000 1000 SM 3 scatter g g -> g g g Index: trunk/omega/tests/parameters_SM_Higgs_recola.f90 =================================================================== --- trunk/omega/tests/parameters_SM_Higgs_recola.f90 (revision 0) +++ trunk/omega/tests/parameters_SM_Higgs_recola.f90 (revision 8253) @@ -0,0 +1,167 @@ +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! Copyright (C) 1999-2019 by +! Wolfgang Kilian +! Thorsten Ohl +! Juergen Reuter +! with contributions from +! cf. main AUTHORS file +! +! WHIZARD is free software; you can redistribute it and/or modify it +! under the terms of the GNU General Public License as published by +! the Free Software Foundation; either version 2, or (at your option) +! any later version. +! +! WHIZARD is distributed in the hope that it will be useful, but +! WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +module parameters_sm_higgs_recola + use kinds + use constants + + implicit none + private + + real(default), dimension(27), public :: mass, width + real(default), public :: as + complex(default), public :: gs, igs, ig, unit + + real(default), public :: e, g, e_em + real(default), public :: sinthw, costhw, sin2thw, tanthw + real(default), public :: qelep, qeup, qedwn + real(default), public :: ttop, tbot, tch, ttau, tw + real(default), public :: ltop, lbot, lc, ltau, lw + complex(default), public :: qlep, qup, qdwn, gcc, qw, & + gzww, gwww, ghww, ghhww, ghzz, ghhzz, & + ghbb, ghtt, ghcc, ghtautau, gh3, gh4, ghmm, ghee, & + ! ghgaga, ghgaz, ghgg, ghmm, & + iqw, igzww, igwww, gw4, gzzww, gazww, gaaww + real(default), public :: vev + complex(default), dimension(2), public :: & + gncneu, gnclep, gncup, gncdwn + + public :: init_parameters, model_update_alpha_s + + real(default), parameter :: & + GF = 1.16639E-5_default ! Fermi constant + !!! This corresponds to 1/alpha = 137.03598949333 + real(default), parameter :: & + alpha = 1.0_default/137.03598949333_default + complex(default), parameter :: & + alphas = 0.1178_default ! Strong coupling constant (Z point) + +contains + + subroutine init_parameters + + mass(1:27) = 0 + width(1:27) = 0 + mass(3) = 0.095_default ! s-quark mass + mass(4) = 1.2_default ! c-quark mass + ! mass(5) = 4.2_default ! b-quark mass + ! mass(6) = 173.1_default ! t-quark mass + ! width(6) = 1.523_default ! t-quark width + ! mass(11) = 0.000510997_default ! electron mass + mass(13) = 0.105658389_default ! muon mass + mass(15) = 1.77705_default ! tau-lepton mas + mass(23) = 91.1882_default ! Z-boson mass + width(23) = 2.443_default ! Z-boson width + mass(24) = 80.419_default ! W-boson mass + width(24) = 2.049_default ! W-boson width + mass(25) = 200._default ! Higgs mass + width(25) = 1.419_default ! Higgs width + +! Recola defaults: + mass = 0 + width = 0 + mass(6) = 173.1_default ! top + mass(23) = 91.153480619183_default ! Z + width(23) = 2.4942663787728_default + mass(24) = 80.357973609878_default ! W + width(24) = 2.0842989982782_default + mass(25) = 125 ! H + ! mass(11) = 0.000510997_default ! electron mass + mass(13) = 0.105658389_default ! muon mass + + ttop = 4.0_default * mass(6)**2 / mass(25)**2 + tbot = 4.0_default * mass(5)**2 / mass(25)**2 + tch = 4.0_default * mass(4)**2 / mass(25)**2 + ttau = 4.0_default * mass(15)**2 / mass(25)**2 + tw = 4.0_default * mass(24)**2 / mass(25)**2 + !ltop = 4.0_default * mass(6)**2 / mass(23)**2 + !lbot = 4.0_default * mass(5)**2 / mass(23)**2 + !lc = 4.0_default * mass(4)**2 / mass(23)**2 + !ltau = 4.0_default * mass(15)**2 / mass(23)**2 + !lw = 4.0_default * mass(24)**2 / mass(23)**2 + + e_em = sqrt(4.0_default * PI * alpha) + vev = 1 / sqrt (sqrt (2.0_default) * GF) ! v (Higgs vev) + costhw = mass(24) / mass(23) ! cos(theta-W) + sinthw = sqrt (1.0_default-costhw**2) ! sin(theta-W) + sin2thw = sinthw**2 + tanthw = sinthw/costhw + e = 2.0_default * sinthw * mass(24) / vev ! em-coupling (GF scheme) + qelep = - 1 + qeup = 2.0_default / 3.0_default + qedwn = - 1.0_default / 3.0_default + g = e / sinthw + ig = cmplx (0.0_default, 1.0_default, kind=default) * g + gcc = - g / 2 / sqrt (2.0_default) + gncneu(1) = - g / 2 / costhw * ( + 0.5_default) + gnclep(1) = - g / 2 / costhw * ( - 0.5_default - 2 * qelep * sin2thw) + gncup(1) = - g / 2 / costhw * ( + 0.5_default - 2 * qeup * sin2thw) + gncdwn(1) = - g / 2 / costhw * ( - 0.5_default - 2 * qedwn * sin2thw) + gncneu(2) = - g / 2 / costhw * ( + 0.5_default) + gnclep(2) = - g / 2 / costhw * ( - 0.5_default) + gncup(2) = - g / 2 / costhw * ( + 0.5_default) + gncdwn(2) = - g / 2 / costhw * ( - 0.5_default) + qlep = - e * qelep + qup = - e * qeup + qdwn = - e * qedwn + qw = e + iqw = (0,1)*qw + gzww = g * costhw + igzww = (0,1)*gzww + gwww = g + igwww = (0,1)*gwww + gw4 = gwww**2 + gzzww = gzww**2 + gazww = gzww * qw + gaaww = qw**2 + ghww = mass(24) * g + ghhww = g**2 / 2.0_default + ghzz = mass(23) * g / costhw + ghhzz = g**2 / 2.0_default / costhw**2 + ghtt = - mass(6) / vev + ghbb = - mass(5) / vev + ghcc = - mass(4) / vev + ghtautau = - mass(15) / vev + ghmm = - mass(13) / vev + ghee = - mass(11) / vev + ! ghmm = 0 + ! ghee = 0 + gh3 = - 3 * mass(25)**2 / vev + gh4 = - 3 * mass(25)**2 / vev**2 + !!! Color flow basis, divide by sqrt(2) + gs = sqrt(2.0_default*PI*alphas) + igs = cmplx (0.0_default, 1.0_default, kind=default) * gs + + unit = 1.0_default + + end subroutine init_parameters + + subroutine model_update_alpha_s (alpha_s) + real(default), intent(in) :: alpha_s + gs = sqrt(2.0_default*PI*alpha_s) + igs = cmplx (0.0_default, 1.0_default, kind=default) * gs + end subroutine model_update_alpha_s + +end module parameters_sm_higgs_recola Index: trunk/omega/tests/comparisons_UFO.list =================================================================== --- trunk/omega/tests/comparisons_UFO.list (revision 8252) +++ trunk/omega/tests/comparisons_UFO.list (revision 8253) @@ -1,98 +1,105 @@ -# comparisons_UFO.list -- -# ---------------------------------------------------------------------- -# thr abs n roots model mode process ... -# ---------------------------------------------------------------------- -# QCD +### comparisons_UFO.list -- +#! +### -------------------------------------------------------------------- +### thr abs n roots model mode process ... +### -------------------------------------------------------------------- +### QCD uudd 0.75 1E-11 1000 1000 SM scatter u ubar -> d dbar | u u~ -> d d~ uucc 0.75 1E-11 1000 1000 SM scatter u ubar -> c cbar | u u~ -> c c~ -uugg 0.25 1E-11 1000 1000 SM scatter u ubar -> g g | u u~ -> g g -uuggg 0.30 1E-11 1000 1000 SM scatter u ubar -> g g g | u u~ -> g g g uuga 0.30 1E-11 1000 1000 SM scatter u ubar -> g A | u u~ -> g a -uugga 0.30 1E-11 1000 1000 SM scatter u ubar -> g g A | u u~ -> g g a -ddgg 0.25 1E-11 1000 1000 SM scatter d dbar -> g g | d d~ -> g g ddga 0.30 1E-11 1000 1000 SM scatter d dbar -> g A | d d~ -> g a -# ---------------------------------------------------------------------- -# VB Higgs +uugg 0.25 1E-11 1000 1000 SM scatter u ubar -> g g | u u~ -> g g +ddgg 0.25 1E-11 1000 1000 SM scatter d dbar -> g g | d d~ -> g g +uugga 0.30 1E-11 1000 1000 SM scatter u ubar -> g g A | u u~ -> g g a +uuggg 0.30 1E-11 1000 1000 SM scatter u ubar -> g g g | u u~ -> g g g +### -------------------------------------------------------------------- +### VB Higgs wwhh 0.65 1E-11 1000 1000 SM scatter W+ W- -> H H whwh 0.65 1E-11 1000 1000 SM scatter W+ H -> W+ H hhww 0.70 1E-11 1000 1000 SM scatter H H -> W+ W- zzhh 0.70 1E-11 1000 1000 SM scatter Z Z -> H H zhzh 0.70 1E-11 1000 1000 SM scatter Z H -> Z H hhzz 0.70 1E-11 1000 1000 SM scatter H H -> Z Z -# ---------------------------------------------------------------------- -# Higgs +### -------------------------------------------------------------------- +### Higgs hhhh 0.75 1E-11 1000 1000 SM scatter H H -> H H hhhhh 0.75 1E-11 1000 1000 SM scatter H H -> H H H hhhhhh 0.75 1E-11 1000 1000 SM scatter H H -> H H H H -# ---------------------------------------------------------------------- -# VBS +### -------------------------------------------------------------------- +### VBS wwww 0.50 1E-11 1000 1000 SM scatter W+ W- -> W+ W- wwww_1 0.50 1E-11 1000 1000 SM scatter W+ W+ -> W+ W+ wwww_2 0.50 1E-11 1000 1000 SM scatter W+ W- -> W- W+ wwww_3 0.50 1E-11 1000 1000 SM scatter W- W- -> W- W- aaww 0.55 1E-11 1000 1000 SM scatter A A -> W+ W- | a a -> W+ W- awaw 0.55 1E-11 1000 1000 SM scatter A W- -> A W- | a W- -> a W- awwa 0.55 1E-11 1000 1000 SM scatter A W- -> W- A | a W- -> W- a -wwaa 0.60 1E-11 1000 1000 SM scatter W+ W- -> A A | W+ W- -> a a -wwzz 0.55 1E-11 1000 1000 SM scatter W+ W- -> Z Z +wwaa 0.55 1E-11 1000 1000 SM scatter W+ W- -> A A | W+ W- -> a a +wwzz 0.50 1E-11 1000 1000 SM scatter W+ W- -> Z Z wzwz 0.55 1E-11 1000 1000 SM scatter W+ Z -> W+ Z wzwz_1 0.55 1E-11 1000 1000 SM scatter W- Z -> W- Z wzzw 0.55 1E-11 1000 1000 SM scatter W+ Z -> Z W+ wzzw_1 0.55 1E-11 1000 1000 SM scatter W+ Z -> W+ Z wwaz 0.55 1E-11 1000 1000 SM scatter W+ W- -> A Z | W+ W- -> a Z -wwza 0.55 1E-11 1000 1000 SM scatter W+ W- -> Z A | W+ W- -> Z a +wwza 0.50 1E-11 1000 1000 SM scatter W+ W- -> Z A | W+ W- -> Z a zaww 0.55 1E-11 1000 1000 SM scatter A Z -> W+ W- | a Z -> W+ W- azww 0.55 1E-11 1000 1000 SM scatter Z A -> W+ W- | Z a -> W+ W- wawz 0.55 1E-11 1000 1000 SM scatter W+ A -> W+ Z | W+ a -> W+ Z wazw 0.55 1E-11 1000 1000 SM scatter W+ A -> Z W+ | W+ a -> Z W+ wzwa 0.55 1E-11 1000 1000 SM scatter W+ Z -> W+ A | W+ Z -> W+ a wzaw 0.55 1E-11 1000 1000 SM scatter W+ Z -> A W+ | W+ Z -> a W+ -# ---------------------------------------------------------------------- -# NC +### -------------------------------------------------------------------- +### NC eemm 0.60 1E-11 1000 1000 SM scatter e+ e- -> mu+ mu- emem 0.60 1E-11 1000 1000 SM scatter e- mu- -> e- mu- eemmmm 0.60 1E-11 1000 1000 SM scatter e+ e- -> mu+ mu- mu+ mu- eeee 0.60 1E-11 1000 1000 SM scatter e+ e- -> e+ e- eeee_2 0.60 1E-11 1000 1000 SM scatter e- e- -> e- e- eeee_3 0.60 1E-11 1000 1000 SM scatter e+ e+ -> e+ e+ eeeeee 0.60 1E-11 1000 1000 SM scatter e+ e- -> e+ e- e+ e- eaea 0.60 1E-11 1000 1000 SM scatter e- A -> e- A | e- a -> e- a eeaa 0.60 1E-11 1000 1000 SM scatter e+ e- -> A A | e+ e- -> a a aaee 0.60 1E-11 1000 1000 SM scatter A A -> e+ e- | a a -> e+ e- eeaaa 0.60 1E-11 1000 1000 SM scatter e+ e- -> A A A | e+ e- -> a a a eeaaaa 0.60 1E-11 1000 1000 SM scatter e+ e- -> A A A A | e+ e- -> a a a a ezez 0.25 1E-11 1000 1000 SM scatter e- Z -> e- Z eezz 0.30 1E-11 1000 1000 SM scatter e+ e- -> Z Z zzee 0.25 1E-11 1000 1000 SM scatter Z Z -> e+ e- eaez 0.25 1E-11 1000 1000 SM scatter e- A -> e- Z | e- a -> e- Z eeaz 0.25 1E-11 1000 1000 SM scatter e+ e- -> A Z | e+ e- -> a Z azee 0.25 1E-11 1000 1000 SM scatter A Z -> e+ e- | a Z -> e+ e- enuenu 0.60 1E-11 1000 1000 SM scatter e- numu -> e- numu | e- vm -> e- vm eenunu 0.60 1E-11 1000 1000 SM scatter e+ e- -> nue nuebar | e+ e- -> ve ve~ nu4 0.60 1E-11 1000 1000 SM scatter nue nue -> nue nue | ve ve -> ve ve eedd 0.60 1E-11 1000 1000 SM scatter e+ e- -> d dbar | e+ e- -> d d~ eded 0.60 1E-11 1000 1000 SM scatter e+ d -> e+ d | e+ d -> e+ d eeuu 0.60 1E-11 1000 1000 SM scatter e+ e- -> u ubar | e+ e- -> u u~ eueu 0.60 1E-11 1000 1000 SM scatter e+ u -> e+ u | e+ u -> e+ u uuee 0.60 1E-11 1000 1000 SM scatter u ubar -> e+ e-| u u~ -> e+ e- uuaa 0.45 1E-11 1000 1000 SM scatter u ubar -> A A | u u~ -> a a uuaz 0.25 1E-11 1000 1000 SM scatter u ubar -> A Z | u u~ -> a Z -# ---------------------------------------------------------------------- -# CC +### -------------------------------------------------------------------- +### CC enumunu 0.80 1E-11 1000 1000 SM scatter e- nuebar -> mu- numubar | e- ve~ -> mu- vm~ emununu 0.75 1E-11 1000 1000 SM scatter e- mu+ -> nue numubar | e- mu+ -> ve vm~ uuww 0.35 1E-11 1000 1000 SM scatter u ubar -> W+ W- | u u~ -> W+ W- -# ---------------------------------------------------------------------- -# CC/NC interferences +### -------------------------------------------------------------------- +### CC/NC interferences enuwa 0.60 1E-11 1000 1000 SM scatter e- nuebar -> W- A | e- ve~ -> W- a ewnua 0.75 1E-11 1000 1000 SM scatter e- W+ -> nue A | e- W+ -> ve a wenua 0.75 1E-11 1000 1000 SM scatter e+ W- -> nuebar A | e+ W- -> ve~ a enuwz 0.60 1E-11 1000 1000 SM scatter e- nuebar -> W- Z | e- ve~ -> W- Z ewnuz 0.75 1E-11 1000 1000 SM scatter e- W+ -> nue Z | e- W+ -> ve Z -# ---------------------------------------------------------------------- -# Pure QCD -gggg 0.30 1E-11 1000 1000 SM scatter g g -> g g +### -------------------------------------------------------------------- +### Top Yukawa +tthh 0.80 1E-11 1000 1000 SM scatter t tbar -> H H | t t~ -> H H +ttgh 0.80 1E-11 1000 1000 SM scatter t tbar -> g H | t t~ -> g H +tbwh 0.80 1E-11 1000 1000 SM scatter t bbar -> W+ H | t b~ -> W+ H +### -------------------------------------------------------------------- +### Pure QCD +ggg 0.70 1E-11 1000 1000 SM decay g -> g g +gggg 0.60 1E-11 1000 1000 SM scatter g g -> g g ggggg 0.30 1E-11 1000 1000 SM scatter g g -> g g g -# Other +### Other eenu2H 0.75 1E-11 1000 1000 SM scatter e+ e- -> nue nuebar H | e+ e- -> ve ve~ H -# ---------------------------------------------------------------------- +### ---------------------------------------------------------------------- Index: trunk/omega/tests/omega_unit.ml =================================================================== --- trunk/omega/tests/omega_unit.ml (revision 8252) +++ trunk/omega/tests/omega_unit.ml (revision 8253) @@ -1,196 +1,201 @@ (* omega_unit.ml -- Copyright (C) 1999-2019 by Wolfgang Kilian Thorsten Ohl Juergen Reuter Christian Speckner WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) open OUnit let unattended = ref true let skip_if_unattended () = skip_if !unattended "not suitable for unattended tests" let trivial_test = "trivial" >:: (bracket (fun () -> true) (fun b -> assert_bool "always true" b) (fun b -> ())) let short_random_list n = let l = ref [] in for i = 1 to n do l := Random.int 1024 :: !l done; !l let allowed_recursion_depth () = let rec allowed_recursion_depth' n = try allowed_recursion_depth' (succ n) with | Stack_overflow -> n in allowed_recursion_depth' 0 let long_random_list factor = let n = factor * allowed_recursion_depth () in let l = ref [] in for i = 1 to n do l := Random.int n :: !l done; !l module Integer = struct type t = int let compare = compare let pp_printer = Format.pp_print_int let pp_print_sep = OUnitDiff.pp_comma_separator end module Integer_List = OUnitDiff.ListSimpleMake(Integer) module ThoList_Unit_Tests = struct let inner_list = ThoList.range 1 5 let outer_list = List.map (( * ) 10) (ThoList.range 1 4) let f n = List.map ((+) n) inner_list let flatmap = "flatmap" >:: (fun () -> let result = ThoList.flatmap f outer_list and expected = List.flatten (List.map f outer_list) in assert_equal expected result) let rev_flatmap = "rev_flatmap" >:: (fun () -> let result = ThoList.rev_flatmap f outer_list and expected = List.rev (ThoList.flatmap f outer_list) in Integer_List.assert_equal expected result) let flatmap_stack_overflow = "flatmap_stack_overflow" >:: (fun () -> skip_if !unattended "memory limits not suitable for unattended tests"; let l = long_random_list 2 in let f n = List.map ((+) n) (short_random_list 2) in assert_raises Stack_overflow (fun () -> ThoList.flatmap f l)) let rev_flatmap_no_stack_overflow = "rev_flatmap_no_stack_overflow" >:: (fun () -> skip_if !unattended "memory limits not suitable for unattended tests"; let l = long_random_list 10 in let f n = List.map ((+) n) (short_random_list 10) in ignore (ThoList.rev_flatmap f l); assert_bool "always true" true) let suite = "ThoList" >::: [flatmap; flatmap_stack_overflow; rev_flatmap; rev_flatmap_no_stack_overflow ] end module IListSet = Set.Make (struct type t = int list let compare = compare end) let list_elements_unique l = let rec list_elements_unique' set = function | [] -> true | x :: rest -> if IListSet.mem x set then false else list_elements_unique' (IListSet.add x set) rest in list_elements_unique' IListSet.empty l let ilistset_test = "IListSet" >:: (fun () -> assert_bool "true" (list_elements_unique [[1];[2]]); assert_bool "false" (not (list_elements_unique [[1];[1]]))) module Combinatorics_Unit_Tests = struct let permute = "permute" >:: (fun () -> let n = 8 in let l = ThoList.range 1 n in let result = Combinatorics.permute l in assert_equal (Combinatorics.factorial n) (List.length result); assert_bool "unique" (list_elements_unique result)) let permute_no_stack_overflow = "permute_no_stack_overflow" >:: (fun () -> skip_if !unattended "memory limits not suitable for unattended tests"; let n = 10 in (* n = 10 needs 1 GB, n = 11 needs 7.3 GB *) let l = ThoList.range 1 n in let result = Combinatorics.permute l in assert_equal (Combinatorics.factorial n) (List.length result)) let suite = "Combinatorics" >::: [permute; permute_no_stack_overflow] end let selftest_suite = "testsuite" >::: [trivial_test; ilistset_test] module Permutation_Test_Using_Lists = Permutation.Test(Permutation.Using_Lists) module Permutation_Test_Using_Arrays = Permutation.Test(Permutation.Using_Arrays) +module Dirac = UFO_targets.Dirac + let suite = "omega" >::: [selftest_suite; ThoList_Unit_Tests.suite; + ThoList.Test.suite; ThoArray.Test.suite; Partial.Test.suite; Permutation_Test_Using_Lists.suite; Permutation_Test_Using_Arrays.suite; Combinatorics_Unit_Tests.suite; - Combinatorics.Test.suite] + Combinatorics.Test.suite; + Format_Fortran.Test.suite; + Dirac.test_suite] let _ = ignore (run_test_tt_main ~arg_specs:[("-attended", Arg.Clear unattended, " run tests that depend on the environment"); ("-unattended", Arg.Set unattended, " don't run tests depend on the environment")] suite); exit 0 Index: trunk/omega/tests/compare_driver_recola.sh =================================================================== --- trunk/omega/tests/compare_driver_recola.sh (revision 0) +++ trunk/omega/tests/compare_driver_recola.sh (revision 8253) @@ -0,0 +1,174 @@ +#! /bin/sh +# compare_driver_UFO.sh -- +######################################################################## + +omega_template="$1" +shift 1 + +models="SM_Higgs" + +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'" + flavors_omega="`echo \"$process\" | sed 's/ *|.*$//'`" + flavors_recola="`echo \"$process\" | sed 's/^.*| *//'`" + eval process_recola_$module="'$flavors_recola'" + ###################################################################### + omega="`echo $omega_template | sed s/%%%/$model/g`" + $omega "$@" \ + -target:parameter_module parameters_${model}_recola \ + -target:module amplitude_compare_recola_${module} \ + -$mode "$flavors_omega" 2>/dev/null + ;; + esac + +done + +for module in $modules; do + +cat < 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_recola_${module} + +EOF + +done + +######################################################################## + +cat < load +EOF +done + +for model in $models; do +cat < init_parameters +EOF +done + +cat < 0) then + print *, failures, 'failures in', $n, 'attempts' + failed_processes = failed_processes + 1 + end if + +EOF +done + +cat < 0) then + print *, failed_processes, " failed processes in ", attempted_processes, " attempts" + stop 1 + end if +end program compare_recola +EOF + +exit 0 + Index: trunk/omega/tests/ufo_unit.ml =================================================================== --- trunk/omega/tests/ufo_unit.ml (revision 8252) +++ trunk/omega/tests/ufo_unit.ml (revision 8253) @@ -1,84 +1,132 @@ (* omega_unit.ml -- Copyright (C) 1999-2016 by Wolfgang Kilian Thorsten Ohl Juergen Reuter WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) +let lorentz_of_string = function + | "Scalar" -> Coupling.Scalar + | "Spinor" -> Coupling.Spinor + | "ConjSpinor" -> Coupling.ConjSpinor + | "Majorana" -> Coupling.Majorana + | "Maj_Ghost" -> Coupling.Maj_Ghost + | "Vector" -> Coupling.Vector + | "Massive_Vector" -> Coupling.Massive_Vector + | "Vectorspinor" -> Coupling.Vectorspinor + | "Tensor_1" -> Coupling.Tensor_1 + | "Tensor_2" -> Coupling.Tensor_2 + | s -> invalid_arg ("lorentz_of_string: " ^ s) + let _ = let my_name = Sys.argv.(0) in let file = ref None and line = ref None and dir = ref None and lorentz = ref None and color = ref None + and targets = ref None + and dirac = ref false + and spins = ref [] and skip_tests = ref false and skip_example = ref false and timing = ref false and verbose = ref false and usage = "usage: " ^ my_name ^ " ..." in Arg.parse (Arg.align [ ("-dir", Arg.String (fun s -> dir := Some s), "name UFO output files"); ("-file", Arg.String (fun s -> file := Some s), "name UFO output file"); ("-line", Arg.String (fun s -> line := Some s), "line UFO fragment"); ("-lorentz", Arg.String (fun s -> lorentz := Some s), "expr UFO Lorentz tensor"); ("-color", Arg.String (fun s -> color := Some s), "expr UFO color tensor"); + ("-targets", Arg.String (fun s -> targets := Some s), + "expr UFO lorentz tensor parsing"); + ("-dirac", Arg.Set dirac, " check Dirac matrices"); + ("-spin", Arg.String (fun s -> spins := s :: !spins), + "name add a lorentz representation"); ("-skip-tests", Arg.Set skip_tests, " skip the tests"); ("-skip-example", Arg.Set skip_example, " skip the example"); ("-timing", Arg.Set timing, " provide timing information"); ("-v", Arg.Set verbose, " be more verbose"); ("-verbose", Arg.Set verbose, " be more verbose") ]) (fun s -> raise (Arg.Bad s)) usage; begin match !file with | None -> () | Some name -> ignore (UFO.parse_file name) end; begin match !line with | None -> () | Some s -> ignore (UFO.parse_string s) end; begin match !dir with | None -> () | Some s -> ignore (UFO.parse_directory s) end; begin match !color with | None -> () | Some s -> let t = UFOx.Color.of_string s in print_endline (UFOx.Color.to_string t); print_endline (UFOx.Index.classes_to_string UFOx.Color.rep_to_string (UFOx.Color.classify_indices t)) end; begin match !lorentz with | None -> () | Some s -> let t = UFOx.Lorentz.of_string s in print_endline (UFOx.Lorentz.to_string t); print_endline (UFOx.Index.classes_to_string UFOx.Lorentz.rep_to_string (UFOx.Lorentz.classify_indices t)) end; + begin match !targets with + | None -> () + | Some s -> + let open Format_Fortran in + let nl = newline in + let t = UFOx.Lorentz.of_string s in + let spins = List.rev_map lorentz_of_string !spins in + let buffer = Buffer.create 1024 in + print_endline (UFOx.Lorentz.to_string t); + print_endline + (UFO_targets.Lorentz_Fusion.to_string + (UFO_targets.Lorentz_Fusion.parse spins t)); + UFO_targets.Fortran.lorentz + (formatter_of_buffer buffer) + "foo" (Array.of_list spins) t; + printf "module omega_amplitude"; nl (); + printf " use kinds"; nl (); + printf " use omega95"; nl (); + printf " implicit none"; nl (); + printf " private"; nl (); + UFO_targets.Fortran.eps4_g4_g44_decl std_formatter (); + UFO_targets.Fortran.eps4_g4_g44_init std_formatter (); + printf "contains"; nl (); + printf "%s" (Buffer.contents buffer); + Buffer.reset buffer; + printf "end module omega_amplitude"; nl () + end; exit 0 Index: trunk/omega/tests/keystones_omegalib_generate.ml =================================================================== --- trunk/omega/tests/keystones_omegalib_generate.ml (revision 0) +++ trunk/omega/tests/keystones_omegalib_generate.ml (revision 8253) @@ -0,0 +1,79 @@ +(* keystones_omegalib_generate.ml -- + + Copyright (C) 2019-2019 by + + Wolfgang Kilian + Thorsten Ohl + Juergen Reuter + + WHIZARD is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + WHIZARD is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) + +open Coupling +open Keystones + +let vector_spinor_current tag = + { tag = Printf.sprintf "vector_spinor_current__%s_ff" tag; + keystones = [ { ket = (ConjSpinor, 0); + name = Printf.sprintf "f_%sf" tag; + args = [G (0); F (Vector, 1); F (Spinor, 2)] }; + { ket = (Vector, 1); + name = Printf.sprintf "%s_ff" tag; + args = [G (0); F (ConjSpinor, 0); F (Spinor, 2)] }; + { ket = (Spinor, 2); + name = Printf.sprintf "f_f%s" tag; + args = [G (0); F (ConjSpinor, 0); F (Vector, 1)] } ] } + +let scalar_spinor_current tag = + { tag = Printf.sprintf "scalar_spinor_current__%s_ff" tag; + keystones = [ { ket = (ConjSpinor, 0); + name = Printf.sprintf "f_%sf" tag; + args = [G (0); F (Scalar, 1); F (Spinor, 2)] }; + { ket = (Scalar, 1); + name = Printf.sprintf "%s_ff" tag; + args = [G (0); F (ConjSpinor, 0); F (Spinor, 2)] }; + { ket = (Spinor, 2); + name = Printf.sprintf "f_f%s" tag; + args = [G (0); F (ConjSpinor, 0); F (Scalar, 1)] } ] } + +(* NB: the vertex is anti-symmetric in the scalars and we need to + use a cyclic permutation. *) +let vector_scalar_current = + { tag = "vector_scalar_current__v_ss"; + keystones = [ { ket = (Vector, 0); + name = "v_ss"; + args = [G (0); F (Scalar, 1); P (1); F (Scalar, 2); P (2)] }; + { ket = (Scalar, 2); + name = "s_vs"; + args = [G (0); F (Vector, 0); P (0); F (Scalar, 1); P (1)] } ] } + +let scalar_vector_current tag = + { tag = Printf.sprintf "transversal_vector_current__s_vv_%s" tag; + keystones = [ { ket = (Scalar, 0); + name = Printf.sprintf "s_vv_%s" tag; + args = [G (0); F (Vector, 1); P (1); F (Vector, 2); P (2)] }; + { ket = (Vector, 1); + name = Printf.sprintf "v_sv_%s" tag; + args = [G (0); F (Scalar, 0); P (0); F (Vector, 2); P (2)] } ] } + +let vertices = + List.concat + [ List.map vector_spinor_current ["v"; "a"; "vl"; "vr"]; + List.map scalar_spinor_current ["s"; "p"; "sl"; "sr"]; + [ vector_scalar_current ]; + List.map scalar_vector_current ["t"; "6D"; "6DP"] ] + +let _ = + Keystones.generate ~reps:10000 ~threshold:0.70 vertices; + exit 0 Index: trunk/omega/tests/compare_lib.f90 =================================================================== --- trunk/omega/tests/compare_lib.f90 (revision 8252) +++ trunk/omega/tests/compare_lib.f90 (revision 8253) @@ -1,306 +1,618 @@ ! compare_lib.f90 -- ! compare_lib.f90 -- compare two O'Mega versions !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! ! ! Copyright (C) 1999-2019 by ! Wolfgang Kilian ! Thorsten Ohl ! Juergen Reuter ! Christian Speckner ! ! WHIZARD is free software; you can redistribute it and/or modify it ! under the terms of the GNU General Public License as published by ! the Free Software Foundation; either version 2, or (at your option) ! any later version. ! ! WHIZARD is distributed in the hope that it will be useful, but ! WITHOUT ANY WARRANTY; without even the implied warranty of ! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the ! GNU General Public License for more details. ! ! You should have received a copy of the GNU General Public License ! along with this program; if not, write to the Free Software ! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. ! !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! module compare_lib ! use ieee_arithmetic use kinds use constants use tao_random_numbers use omega95 use omega_interface use omega_testtools implicit none private public :: check + public :: omega_flavor_states, omega_squared_matrix_element + public :: massless_isotropic_decay, rambo, beams, dot, rambo_check contains elemental function ieee_is_nan (x) result (yorn) logical :: yorn real (kind=default), intent(in) :: x yorn = (x /= x) end function ieee_is_nan subroutine check (v1, v2, roots, threshold, n, & failures, attempts, seed, abs_threshold, ignore_phase) type(omega_procedures), intent(in) :: v1, v2 real(kind=default), intent(in) :: roots, threshold integer, intent(in) :: n integer, intent(out) :: failures, attempts integer, intent(in), optional :: seed real(kind=default), intent(in), optional :: abs_threshold logical, intent(in), optional :: ignore_phase logical :: modulus_only logical :: match, passed integer :: n_out, n_flv, n_hel, n_col integer :: i, i_flv, i_hel, i_col real(kind=default), dimension(:,:), allocatable :: p complex(kind=default) :: a1, a2 real(kind=default) :: asq1, asq2, s_asq1, s_asq2 character(len=80) :: msg modulus_only = .false. if (present (ignore_phase)) then modulus_only = ignore_phase end if failures = 0 attempts = 0 a1 = 0 a2 = 0 asq1 = 0 asq2 = 0 s_asq1 = 0 s_asq2 = 0 call quantum_numbers (v1, v2, n_out, n_flv, n_hel, n_col, match) if (.not.match) then failures = 1 return end if if (present (seed)) then call tao_random_seed (seed) end if call v1%reset_helicity_selection (-1.0_default, -1) call v2%reset_helicity_selection (-1.0_default, -1) allocate (p(0:3,2+n_out)) call beams (ROOTS, 0.0_default, 0.0_default, p(:,1), p(:,2)) do i = 1, N if (n_out > 1) then call massless_isotropic_decay (ROOTS, p(:,3:)) end if if (n_out == 1) then p(:,3) = p(:,1) + p(:,2) end if call v1%new_event (p) call v2%new_event (p) do i_flv = 1, n_flv do i_hel = 1, n_hel attempts = attempts + 1 passed = .true. do i_col = 1, n_col a1 = v1%get_amplitude (i_flv, i_hel, i_col) a2 = v2%get_amplitude (i_flv, i_hel, i_col) if (ieee_is_nan (real (a1)) .or. ieee_is_nan (aimag (a1))) then write (*, "(1X,'evt=',I5,', flv=',I3,', col=',I3,': ', A)") & i, i_flv, i_col, "v1 amplitude NaN" end if if (ieee_is_nan (real (a2)) .or. ieee_is_nan (aimag (a2))) then write (*, "(1X,'evt=',I5,', flv=',I3,', col=',I3,': ', A)") & i, i_flv, i_col, "v2 amplitude NaN" end if write (msg, "(1X,'evt=',I5,', flv=',I3,', col=',I3,', hel=',I3)") & i, i_flv, i_col, i_hel if (modulus_only) then call expect (abs (a1), abs (a2), trim(msg), passed, & quiet=.true., threshold=threshold, & abs_threshold=abs_threshold) else call expect (a1, a2, trim(msg), passed, & quiet=.true., threshold=threshold, & abs_threshold=abs_threshold) end if end do write (msg, "(1X,'evt=',I5,', flv=',I3,', hel=',I3)") & i, i_flv, i_hel asq1 = v1%color_sum (i_flv, i_hel) s_asq1 = s_asq1 + asq1 asq2 = v2%color_sum (i_flv, i_hel) s_asq2 = s_asq2 + asq2 call expect (asq1, asq2, trim(msg), passed, & quiet=.true., threshold=threshold, & abs_threshold=abs_threshold) if (.not.passed) then failures = failures + 1 end if end do end do end do print *, 'Summed results: ' print *, 's_asq1, s_asq2 = ', s_asq1, s_asq2 deallocate (p) end subroutine check subroutine quantum_numbers (v1, v2, n_out, n_flv, n_hel, n_col, match) type(omega_procedures), intent(in) :: v1, v2 integer, intent(out) :: n_out, n_flv, n_hel, n_col logical, intent(out) :: match integer, dimension(:,:), allocatable :: & v1_flavor_states, v2_flavor_states, & v1_spin_states, v2_spin_states integer, dimension(:,:,:), allocatable :: & v1_color_flows, v2_color_flows logical, dimension(:,:), allocatable :: & v1_ghost_flags, v2_ghost_flags type(omega_color_factor), dimension(:), allocatable :: & v1_color_factors, v2_color_factors integer :: n_in, n_prt, n_cix, n_cfs n_in = v1%number_particles_in () n_out = v1%number_particles_out () n_prt = n_in + n_out n_flv = v1%number_flavor_states () n_hel = v1%number_spin_states () n_cix = v1%number_color_indices () n_col = v1%number_color_flows () n_cfs = v1%number_color_factors () match = .true. if (v2%number_particles_in () .ne. n_in) then print *, "number_particles_in don't match!" match = .false. end if if (v2%number_particles_out () .ne. n_out) then print *, "number_particles_out don't match!" match = .false. end if if (v2%number_flavor_states () .ne. n_flv) then print *, "number_flavor_states don't match!" match = .false. end if if (v2%number_spin_states () .ne. n_hel) then print *, "number_spin_states don't match!" match = .false. end if if (v2%number_color_indices () .ne. n_cix) then print *, "number_color_indices don't match!" match = .false. end if if (v2%number_color_flows () .ne. n_col) then print *, "number_color_flows don't match!" match = .false. end if ! We save only the symmetric part in the OVM !if (v2%number_color_factors () .ne. n_cfs) then !print *, "number_color_factors don't match!" !match = .false. !end if if (match) then allocate (v1_flavor_states(n_prt,n_flv), v2_flavor_states(n_prt,n_flv)) allocate (v1_spin_states(n_prt,n_hel), v2_spin_states(n_prt,n_hel)) allocate (v1_color_flows(n_cix,n_prt,n_col), & v2_color_flows(n_cix,n_prt,n_col)) allocate (v1_ghost_flags(n_prt,n_col), v2_ghost_flags(n_prt,n_col)) !allocate (v1_color_factors(n_cfs), v2_color_factors(n_cfs)) call v1%flavor_states (v1_flavor_states) call v2%flavor_states (v2_flavor_states) call v1%spin_states (v1_spin_states) call v2%spin_states (v2_spin_states) call v1%color_flows (v1_color_flows, v1_ghost_flags) call v2%color_flows (v2_color_flows, v2_ghost_flags) !call v1%color_factors (v1_color_factors) !call v2%color_factors (v2_color_factors) if (any (v1_flavor_states .ne. v2_flavor_states)) then print *, "flavor states don't match!" print *, "CAVEAT: this might be due to simple reordering!" match = .false. end if if (any (v1_spin_states .ne. v2_spin_states)) then print *, "spin states don't match!" print *, "CAVEAT: this might be due to simple reordering!" match = .false. end if if (any (v1_color_flows .ne. v2_color_flows)) then print *, "color flows don't match!" print *, "CAVEAT: this might be due to simple reordering!" match = .false. end if if (any (v1_ghost_flags .neqv. v2_ghost_flags)) then print *, "ghost flags don't match!" print *, "CAVEAT: this might be due to simple reordering!" match = .false. end if !if (any (.not. color_factors_equal (v1_color_factors, & !v2_color_factors))) then !print *, "color_factors don't match!" !print *, "CAVEAT: this might be due to simple reordering!" !match = .false. !end if deallocate (v1_flavor_states, v2_flavor_states) deallocate (v1_spin_states, v2_spin_states) deallocate (v1_color_flows, v2_color_flows) deallocate (v1_ghost_flags, v2_ghost_flags) !deallocate (v1_color_factors, v2_color_factors) end if end subroutine quantum_numbers elemental function color_factors_equal (cf1, cf2) result (eq) logical :: eq type(omega_color_factor), intent(in) :: cf1, cf2 eq = (cf1%i1 .eq. cf2%i1) .and. (cf1%i2 .eq. cf2%i2) .and. (cf1%factor .eq. cf2%factor) end function color_factors_equal + subroutine omega_flavor_states (proc, flavors) + type(omega_procedures) :: proc + integer, dimension(:,:), allocatable, intent(inout) :: flavors + integer :: n_in, n_out, n_prt, n_flv + n_in = proc%number_particles_in () + n_out = proc%number_particles_out () + n_prt = n_in + n_out + n_flv = proc%number_flavor_states () + if (allocated (flavors)) then + if (any (size (flavors) /= (/ n_prt, n_flv /))) then + deallocate (flavors) + allocate (flavors (n_prt, n_flv)) + end if + else + allocate (flavors (n_prt, n_flv)) + end if + call proc%flavor_states (flavors) + end subroutine omega_flavor_states + + subroutine omega_squared_matrix_element (proc, p, asq, error) + type(omega_procedures) :: proc + real(kind=default), dimension(0:,:), intent(in) :: p + real(kind=default), intent(out) :: asq + logical, intent(out) :: error + real(kind=default) :: asq_sum + integer :: i_hel + call proc%new_event (p) + error = .false. + if (proc%number_flavor_states () /= 1) then + print *, "ambiguous flavor in omega amplitude" + error = .true. + return + end if + asq_sum = 0 + do i_hel = 1, proc%number_spin_states () + asq_sum = asq_sum + proc%color_sum (1, i_hel) + end do + asq = asq_sum / 4 + end subroutine omega_squared_matrix_element + pure function dot (p, q) result (pq) real(kind=default), dimension(0:), intent(in) :: p, q real(kind=default) :: pq pq = p(0)*q(0) - dot_product (p(1:), q(1:)) end function dot pure subroutine beams (roots, m1, m2, p1, p2) real(kind=default), intent(in) :: roots, m1, m2 real(kind=default), dimension(0:), intent(out) :: p1, p2 real(kind=default) :: m12, m22 m12 = m1**2 m22 = m2**2 p1(0) = (roots**2 + m12 - m22) / (2*roots) p1(1:2) = 0 p1(3) = sqrt (p1(0)**2 - m12) p2(0) = roots - p1(0) p2(1:3) = - p1(1:3) end subroutine beams ! The massless RAMBO algorithm subroutine massless_isotropic_decay (roots, p) real(kind=default), intent(in) :: roots real(kind=default), dimension(0:,:), intent(out) :: p real(kind=default), dimension(0:3,size(p,dim=2)) :: q real(kind=default), dimension(0:3) :: qsum real(kind=double), dimension(4) :: ran_double real(kind=default), dimension(4) :: ran real(kind=default) :: c, s, f, qabs, x, r, z integer :: k ! Generate isotropic null vectors do k = 1, size (p, dim = 2) ! if default is not double or single, we can't use ! tao_random_number directly ... call tao_random_number (ran_double) ran = ran_double ! generate a x*exp(-x) distribution for q(0,k) q(0,k)= -log(ran(1)*ran(2)) c = 2*ran(3)-1 f = 2*PI*ran(4) s = sqrt(1-c*c) q(2,k) = q(0,k)*s*sin(f) q(3,k) = q(0,k)*s*cos(f) q(1,k) = q(0,k)*c enddo ! Boost and rescale the vectors qsum = sum (q, dim = 2) qabs = sqrt (dot (qsum, qsum)) x = roots/qabs do k = 1, size (p, dim = 2) r = dot (q(0:,k), qsum) / qabs z = (q(0,k)+r)/(qsum(0)+qabs) p(1:3,k) = x*(q(1:3,k)-qsum(1:3)*z) p(0,k) = x*r enddo end subroutine massless_isotropic_decay + !------------------------------------------------------ + ! RAMBO, R. Kleiss, W.J. Stirling, S.D. Ellis. + ! Comp. Phys. Commun. 40 (1986) 359 + !------------------------------------------------------ + subroutine rambo (roots, m, p, weight, unweighted) + implicit none + real(kind=default), intent(in) :: roots + real(kind=default), dimension(:), intent(in) :: m + real(kind=default), dimension(0:,:), intent(out) :: p + real(kind=default), intent(out) :: weight + logical, intent(in) :: unweighted + + real(kind=default), dimension(0:3,size(m)):: q + real(kind=default), dimension(0:3) :: sum_q + real(kind=default) :: mass_sum_q + + real(kind=default), dimension(4) :: random + real(kind=default) :: random_weight + real(kind=double), dimension(4) :: random_double + real(kind=double) :: random_weight_double + + real(kind=default), dimension(size(m)):: m2, e, v, p2 + + real(kind=default) :: a,accu,bq,costh,phi,f0,g,g0,pm2 + real(kind=default) :: sinth,sm2,w,wt2,wt3,wtm,wtmax,x,x2,xmax,sum_m + real(kind=default) :: b(3) + + integer :: i, iter, k, num_massive + + real(kind=default), dimension(:), allocatable, save :: z + real(kind=default), save :: twopi, log_pi_over_2 + real(kind=default), parameter :: ACC = 1d-14 + + integer, parameter :: MAX_ITERATIONS = 6 + integer, save :: underflows = 0, overflows = 0, excessive_weights = 0 + + if (size(p,dim=2) /= size(m)) then + print *, 'rambo: mismatch of array dimensions of M and P' + stop + end if + + ! initialize the factorials for the phase space weight + if (allocated(z)) then + if (size(z) < size(m)) then + deallocate (z) + end if + end if + if (.not.allocated(z)) then + allocate (z(size(m))) + ! z(1) = ??? + twopi = 8 * atan (1.0_default) + log_pi_over_2 = log (twopi / 4) + z(2) = log_pi_over_2 + do k = 3, size(z) + z(k) = z(k-1) + log_pi_over_2 - 2 * log (real (k-2, kind=default)) + end do + do k = 3, size(z) + z(k) = z(k) - log (real (k-1, kind=default)) + end do + end if + + ! check whether total energy suffices and count nonzero masses + num_massive = count (m /= 0) + sum_m = sum (abs (m)) + if (sum_m > roots) then + print *, ' RAMBO FAILS: TOTAL MASS =', sum_m, & + ' IS NOT', ' SMALLER THAN TOTAL ENERGY =', roots + stop + end if + + ! generate N massless momenta + generate: do + + do i = 1, size(m) + call tao_random_number (random_double) + random = random_double + costh = 2 * random(1) - 1 + sinth = sqrt (1 - costh*costh) + phi = twopi * random(2) + q(0,i) = -log (random(3)*random(4)) + q(3,i) = q(0,i) * costh + q(2,i) = q(0,i) * sinth * cos (phi) + q(1,i) = q(0,i) * sinth * sin (phi) + end do + + ! compute the parameters of the conformal transformation + sum_q = sum (q, dim=2) + mass_sum_q = sqrt (dot (sum_q, sum_q)) + b = - sum_q(1:3) / mass_sum_q + g = sum_q(0) / mass_sum_q + a = 1 / (1 + g) + x = roots / mass_sum_q + + ! TRANSFORM THE Q'S CONFORMALLY INTO THE P'S + do i = 1, size(m) + bq = b(1) * q(1,i) + b(2) * q(2,i) + b(3) * q(3,i) + p(1:3,i) = x * (q(1:3,i) + b * (q(0,i) + a*bq)) + p(0,i) = x * (g*q(0,i) + bq) + end do + + ! for unweighted massless momenta, we're done + weight = 1 + if (num_massive == 0 .and. unweighted) then + exit generate + end if + + ! CALCULATE WEIGHT AND POSSIBLE WARNINGS + weight = log_pi_over_2 + if (size(m) /= 2) then + weight = (2*size(m) - 4) * log (roots) + z(size(m)) + end if + if (weight < - 180) then + if (underflows <= 5) then + call rambo_flow (weight, 'under') + end if + underflows = underflows + 1 + end if + if (weight > 174) then + if (overflows <= 5) then + call rambo_flow (weight, 'over') + end if + overflows = overflows + 1 + end if + + ! return FOR WEIGHTED MASSLESS MOMENTA + if (num_massive /= 0) then + + ! MASSIVE PARTICLES: RESCALE THE MOMENTA BY A FACTOR X + xmax = sqrt (1 - (sum_m/roots)**2) + m2 = m**2 + p2 = p(0,:)**2 + + x = xmax + accu = roots * ACC + + iter = 0 + solve: do + f0 = - roots + g0 = 0 + x2 = x*x + do i = 1, size(m) + e(i) = sqrt (m2(i) + x2 * p2(i)) + f0 = f0 + e(i) + g0 = g0 + p2(i) / e(i) + end do + if (abs (f0) > accu) then + iter = iter + 1 + if (iter <= MAX_ITERATIONS) then + x = x - f0 / (x*g0) + cycle solve + else + print *, ' RAMBO WARNS:', MAX_ITERATIONS, & + ' ITERATIONS DID NOT GIVE THE', & + ' DESIRED ACCURACY =', ACC + end if + end if + exit solve + end do solve + + v = x * p(0,:) + P(1:3,:) = x * P(1:3,:) + P(0,:) = e + + ! CALCULATE THE MASS-EFFECT WEIGHT FACTOR + wt2 = product (v / e) + wt3 = sum (v**2 / e) + wtm = (2*size(m) - 3) * log (x) + LOG (wt2 / wt3 * roots) + + if (unweighted) then + + ! UNWEIGHTED MASSIVE MOMENTA REQUIRED: ESTIMATE MAXIMUM WEIGHT + weight = exp (wtm) + if (num_massive <= 1) then + ! ONE MASSIVE PARTICLE + wtmax = xmax**(4*size(m) - 6) + elseif (num_massive > 2) then + ! MORE THAN TWO MASSIVE PARTICLES: AN ESTIMATE ONLY + wtmax = xmax**(2*size(m) - 5 + num_massive) + else + ! TWO MASSIVE PARTICLES + sm2 = sum (m2) + ! this was wrong (always 0) in thr orignal) + pm2 = product (m2, mask = (m2 /= 0)) + wtmax = ((1 - sm2 / (roots**2))**2 & + - 4*pm2 / roots**4)**(size(m) - 1.5_default) + end if + + ! DETERMINE WHETHER OR NOT TO ACCEPT THIS EVENT + w = weight / wtmax + if (w > 1) then + print *, ' RAMBO WARNS: ESTIMATE FOR MAXIMUM WEIGHT =', & + wtmax, ' EXCEEDED BY A FACTOR ', w + excessive_weights = excessive_weights + 1 + end if + call tao_random_number (random_weight_double) + random_weight = random_weight_double + if (w < random_weight) then + cycle generate + end if + weight = 1 + + else + + ! return FOR WEIGHTED MASSIVE MOMENTA + weight = weight + wtm + if (weight < -180) then + if (underflows <= 5) then + call rambo_flow (weight, 'under') + end if + underflows = underflows + 1 + end if + if (weight > 174) then + if (overflows <= 5) then + call rambo_flow (weight, 'over') + end if + overflows = overflows + 1 + end if + weight = exp (weight) + end if + + else + weight = exp (weight) + end if + + exit generate + end do generate + + end subroutine rambo + + subroutine rambo_check (roots, m, p, quiet) + real(kind=default), intent(in) :: roots + real(kind=default), dimension(:), intent(in) :: m + real(kind=default), dimension(0:,:), intent(in) :: p + logical, intent (in) :: quiet + real(kind=default), dimension(0:3) :: sum_p + integer :: mu, i + logical :: passed + real(kind=default), parameter :: & + THRESHOLD_MOMENTUM = 0.95, & + THRESHOLD_MASS = 0.45 + passed = .true. + sum_p = sum (p, dim=2) + call expect (sum_p(0), roots, 'energy momentum', & + passed, threshold=THRESHOLD_MOMENTUM, quiet=quiet) + do mu = 1, 3 + call expect_zero (sum_p(mu), roots, 'spatial momentum', & + passed, threshold=THRESHOLD_MOMENTUM, quiet=quiet) + end do + do i = 1, size(m) + call expect (dot (p(:,i), p(:,i)), m(i)**2, 'mass shell', & + passed, threshold=THRESHOLD_MASS, quiet=quiet) + end do + if (.not.passed .and. .not.quiet) then + do i = 1, size (m) + print *, 'M(', i, ') = ', sqrt (abs (dot (p(:,i), p(:,i)))), & + 'vs. ', m(i) + end do + do mu = 0, 3 + print *, 'sum p(', mu, ',:) = ', sum_p(mu) + end do + end if + end subroutine rambo_check + + subroutine rambo_flow (w, f) + implicit none + real(kind=default), intent(in) :: w + character(len=*), intent(in) :: f + print *, ' RAMBO WARNS: WEIGHT = EXP(', w,') MAY ', f + end subroutine rambo_flow + end module compare_lib Index: trunk/omega/tests/vertex_unit.ml =================================================================== --- trunk/omega/tests/vertex_unit.ml (revision 8252) +++ trunk/omega/tests/vertex_unit.ml (revision 8253) @@ -1,68 +1,65 @@ (* omega_unit.ml -- Copyright (C) 1999-2014 by Wolfgang Kilian Thorsten Ohl Juergen Reuter WHIZARD is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 2, or (at your option) any later version. WHIZARD is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) module M = Modellib_SM.SM(Modellib_SM.SM_no_anomalous) module List_Test = Permutation.Test(Permutation.Using_Lists) module Array_Test = Permutation.Test(Permutation.Using_Arrays) module Vertex_Test = Vertex.Test(M) module Parser_Test = Vertex.Parser_Test module Model_Test = Vertex.Modelfile_Test let _ = let my_name = Sys.argv.(0) in let skip_tests = ref false and skip_example = ref false and timing = ref false and verbose = ref false and usage = "usage: " ^ my_name ^ " ..." in Arg.parse (Arg.align [ ("-skip-tests", Arg.Set skip_tests, " skip the tests"); ("-skip-example", Arg.Set skip_example, " skip the example"); ("-timing", Arg.Set timing, " provide timing information"); ("-v", Arg.Set verbose, " be more verbose"); ("-verbose", Arg.Set verbose, " be more verbose") ]) (fun s -> raise (Arg.Bad s)) usage; if not !skip_tests then begin let suite = OUnit.(>:::) "All" - [Partial.Test.suite; - List_Test.suite; - Array_Test.suite; - Vertex_Test.suite; + [Vertex_Test.suite; Parser_Test.suite; Model_Test.suite] in ignore (OUnit.run_test_tt ~verbose:!verbose suite) end; if !timing then begin print_endline "List based:"; List_Test.time (); print_endline "Array based:"; Array_Test.time () end; if not !skip_example then begin Vertex_Test.example (); Parser_Test.example (); Model_Test.example () end; exit 0 Index: trunk/omega/tests/comparisons_recola.list =================================================================== --- trunk/omega/tests/comparisons_recola.list (revision 0) +++ trunk/omega/tests/comparisons_recola.list (revision 8253) @@ -0,0 +1,18 @@ +### comparisons_recola.list -- +#! +### -------------------------------------------------------------------- +### thr abs n roots model mode process ... +### -------------------------------------------------------------------- +wwhh 0.10 1E-30 100 10000 SM_Higgs scatter mu+ e- -> numubar nue H H | mu+ e- -> nu_mu~ nu_e H H +wwhhh 0.05 1E-30 100 10000 SM_Higgs scatter mu+ e- -> numubar nue H H H | mu+ e- -> nu_mu~ nu_e H H H +### -------------------------------------------------------------------- +### recola particles +### scalars: 'H', 'p0', 'p+', 'p-' +### vector bosons: 'g', 'A', 'Z', 'W+', 'W-' +### leptons: 'nu_e', 'nu_e~', 'e-', 'e+', +### 'nu_mu', 'nu_mu~', 'mu-', 'mu+', +### 'nu_tau', 'nu_tau~', 'tau-', 'tau+' +### quarks: 'u', 'u~', 'd', 'd~', +### 'c', 'c~', 's', 's~', +### 't', 't~', 'b', 'b~' +### ---------------------------------------------------------------------- Index: trunk/omega/tests/keystones.mli =================================================================== --- trunk/omega/tests/keystones.mli (revision 0) +++ trunk/omega/tests/keystones.mli (revision 8253) @@ -0,0 +1,41 @@ +(* keystones.mli -- + + Copyright (C) 2019-2019 by + + Wolfgang Kilian + Thorsten Ohl + Juergen Reuter + + WHIZARD is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + WHIZARD is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) + +type field = Coupling.lorentz * int + +type argument = + | G of int (* coupling *) + | P of int (* momentum *) + | F of field (* field *) + +type keystone = + { ket : field; + name : string; + args : argument list } + +type vertex = + { tag : string; + keystones : keystone list } + +val generate : + ?reps:int -> ?threshold:float -> ?modules:(string list) -> + vertex list -> unit Index: trunk/omega/tests/compare_recola.f90 =================================================================== --- trunk/omega/tests/compare_recola.f90 (revision 0) +++ trunk/omega/tests/compare_recola.f90 (revision 8253) @@ -0,0 +1,83 @@ +!##################################################################### +! PARTICLES +! Scalars: 'H', 'p0', 'p+', 'p-' +! Vector bosons: 'g', 'A', 'Z', 'W+', 'W-' +! leptons: 'nu_e', 'nu_e~', 'e-', 'e+', +! 'nu_mu', 'nu_mu~', 'mu-', 'mu+', +! 'nu_tau', 'nu_tau~', 'tau-', 'tau+' +! quarks: 'u', 'u~', 'd', 'd~', +! 'c', 'c~', 's', 's~', +! 't', 't~', 'b', 'b~' +!##################################################################### + +module interface_compare_recola + use omega_interface + use omega_amplitude_recola + 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_recola + +program compare_recola + use kinds + use recola + use compare_lib_recola + use parameters_sm_recola + use interface_compare_recola + implicit none + + real(double) :: asq_sum_recola, asq_sum_omega + integer :: failures, attempts, seed + integer, dimension(8) :: date_time + + real(kind=default), parameter :: ROOTS = 10000 + integer, parameter :: N_EVENTS = 100 + real(double), parameter :: THRESHOLD = 0.05 + real(double), parameter :: ABS_THRESHOLD = 0 + + character(len=256) :: process + + process = 'mu+ e- -> nu_mu~ nu_e H H H' +! process = 'mu+ e- -> nu_mu~ nu_e H H' +! process = 'mu+ e- -> nu_mu~ nu_e H' +! process = 'mu+ e- -> nu_mu~ nu_e' + + call date_and_time (values = date_time) + seed = product (date_time) + seed = 24 + + call init_parameters () + call set_output_file_rcl ('recola.log') + call set_print_level_squared_amplitude_rcl (0) + call set_pole_mass_muon_rcl (mass(13), width(13)) + call switchoff_coupling3_rcl ('H','mu+','mu-') + call unset_light_muon_rcl + + call check_recola (load (), process, ROOTS, THRESHOLD, N_EVENTS, & + failures, attempts, seed, ABS_THRESHOLD) + if (failures > 0) then + print *, failures, 'failures in', N_EVENTS, 'attempts' + stop 1 + end if + +end program compare_recola Index: trunk/omega/tests/ward_driver_UFO.sh =================================================================== --- trunk/omega/tests/ward_driver_UFO.sh (revision 0) +++ trunk/omega/tests/ward_driver_UFO.sh (revision 8253) @@ -0,0 +1,159 @@ +#! /bin/sh +# ward_driver_UFO.sh -- +######################################################################## + +omega="$1" +shift + +models="sm_ufo" + +modules="" + +######################################################################## +while read module threshold n roots model unphysical mode process; do + + case $module in + + '#'*) # skip comments + ;; + + '') # skip empty lines + ;; + + '!'*) break + ;; + + *) + ######################################################################## + modules="$modules $module" + eval threshold_$module=$threshold + eval n_$module=$n + eval roots_$module=$roots + eval process_$module="'$process'" + ######################################################################## + + ######################################################################## + + # echo "running $omega_bin -$mode '$process'" 1>&2 + $omega "$@" -model:exec \ + -target:parameter_module parameters_sm_ufo \ + -target:module amplitude_ward_ufo_physical_$module \ + -$mode "$process" 2>/dev/null + $omega "$@" -model:exec \ + -target:parameter_module parameters_sm_ufo \ + -target:module amplitude_ward_ufo_unphysical_$module \ + -$mode "$process" -unphysical $unphysical 2>/dev/null + ;; + esac + +done +######################################################################## + +for module in $modules; do + + for mode in physical unphysical; do + +cat < 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_ward_ufo_${mode}_${module} + +EOF + + done + +done + +######################################################################## + +cat < load +EOF + done +done + +for model in $models; do +cat < setup_parameters +EOF +done + +cat < 0) then + print *, failures, " failures in ", attempts, " attempts" + failed_processes = failed_processes + 1 + end if +EOF +done + +cat < 0) then + print *, failed_processes, " failed processes in ", attempted_processes, " attempts" + stop 1 + end if +end program ward_ufo_driver +EOF + +exit 0 Index: trunk/omega/tests/compare_lib_recola.f90 =================================================================== --- trunk/omega/tests/compare_lib_recola.f90 (revision 0) +++ trunk/omega/tests/compare_lib_recola.f90 (revision 8253) @@ -0,0 +1,155 @@ +! compare_lib.f90 -- +! compare_lib.f90 -- compare two O'Mega versions +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! +! Copyright (C) 1999-2019 by +! Wolfgang Kilian +! Thorsten Ohl +! Juergen Reuter +! Christian Speckner +! +! WHIZARD is free software; you can redistribute it and/or modify it +! under the terms of the GNU General Public License as published by +! the Free Software Foundation; either version 2, or (at your option) +! any later version. +! +! WHIZARD is distributed in the hope that it will be useful, but +! WITHOUT ANY WARRANTY; without even the implied warranty of +! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +! GNU General Public License for more details. +! +! You should have received a copy of the GNU General Public License +! along with this program; if not, write to the Free Software +! Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +module compare_lib_recola + ! use ieee_arithmetic + use kinds + use constants + use tao_random_numbers + use recola + use omega95 + use omega_interface + use omega_testtools + use compare_lib + use parameters_sm_higgs_recola + implicit none + private + public :: check_recola +contains + + elemental function ieee_is_nan (x) result (yorn) + logical :: yorn + real (kind=default), intent(in) :: x + yorn = (x /= x) + end function ieee_is_nan + + elemental function ieee_is_nan_double (x) result (yorn) + logical :: yorn + real (kind=double), intent(in) :: x + yorn = (x /= x) + end function ieee_is_nan_double + + elemental function mass_of_pdg (pdg) result (m) + integer, intent(in) :: pdg + real(kind=default) :: m + m = mass(abs(pdg)) + end function mass_of_pdg + + subroutine check_recola (proc, process, roots, threshold, n, & + failures, attempts, seed, abs_threshold) + type(omega_procedures), intent(in) :: proc + character(*), intent(in) :: process + real(kind=default), intent(in) :: roots, threshold + integer, intent(in) :: n + integer, intent(out) :: failures, attempts + integer, intent(in), optional :: seed + real(kind=default), intent(in), optional :: abs_threshold + logical :: match, passed, error + integer :: i + real(kind=default) :: asq_sum_omega + real(kind=double) :: asq_sum_recola + real(kind=default) :: sum_omega, sum_recola + character(len=80) :: msg + integer, dimension(:,:), allocatable :: flavors + real(kind=default), dimension(:,:), allocatable :: p + real(kind=default), dimension(:), allocatable :: m + logical, parameter :: UNWEIGHTED = .true. + logical, parameter :: QUIET = .true. + real(kind=default) :: weight + + call define_process_rcl (1, trim(process), 'LO') + call generate_processes_rcl + + call omega_flavor_states (proc, flavors) + allocate (m(size(flavors,dim=1))) + allocate (p(0:3,size(flavors,dim=1))) + m = mass_of_pdg (flavors(:,1)) + + call beams (roots, m(1), m(2), p(:,1), p(:,2)) + call proc%reset_helicity_selection (-1.0_default, -1) + + failures = 0 + attempts = 0 + sum_omega = 0 + sum_recola = 0 + + if (present (seed)) then + call tao_random_seed (seed) + end if + + do i = 1, n + attempts = attempts + 1 + if (size(p,dim=2) > 3) then + call rambo (roots, m(3:), p(:,3:), weight, UNWEIGHTED) + call rambo_check (roots, m(3:), p(:,3:), quiet=.true.) + else + p(:,3) = p(:,1) + p(:,2) + end if + + call compute_process_rcl (1, real (p, kind=double), 'LO') + call get_squared_amplitude_rcl (1, 0, 'LO', asq_sum_recola) + + call omega_squared_matrix_element (proc, p, asq_sum_omega, error) + if (error) then + write (*, "(1X,'evt=',I5,': ', A)") i, "O'Mega failed" + failures = failures + 1 + cycle + end if + + passed = .true. + if (ieee_is_nan_double (asq_sum_recola)) then + write (*, "(1X,'evt=',I5,': ', A)") i, "squared recola amplitude NaN" + passed = .false. + end if + if (ieee_is_nan (asq_sum_omega)) then + write (*, "(1X,'evt=',I5,': ', A)") i, "squared O'Mega amplitude NaN" + passed = .false. + end if + write (msg, "(1X,'evt=',I5)") i + call expect (real (asq_sum_recola, kind=default), & + asq_sum_omega, trim(msg), passed, & + quiet=.true., threshold=threshold, & + abs_threshold=abs_threshold) + + if (.not.passed) then + failures = failures + 1 + cycle + end if + + sum_omega = sum_omega + asq_sum_omega + sum_recola = sum_recola + asq_sum_recola + + end do + + call reset_recola_rcl + deallocate (m, p) + + print *, 'Summed results: ' + print *, 'omega, recola = ', sum_omega, sum_recola + + end subroutine check_recola + +end module compare_lib_recola Index: trunk/omega/tests/Makefile.am =================================================================== --- trunk/omega/tests/Makefile.am (revision 8252) +++ trunk/omega/tests/Makefile.am (revision 8253) @@ -1,626 +1,718 @@ # Makefile.am -- Makefile for O'Mega within and without WHIZARD ## ## Process this file with automake to produce Makefile.in ## ######################################################################## # # Copyright (C) 1999-2019 by # Wolfgang Kilian # Thorsten Ohl # Juergen Reuter # with contributions from # cf. main AUTHORS file # # WHIZARD is free software; you can redistribute it and/or modify it # under the terms of the GNU General Public License as published by # the Free Software Foundation; either version 2, or (at your option) # any later version. # # WHIZARD is distributed in the hope that it will be useful, but # WITHOUT ANY WARRANTY; without even the implied warranty of # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the # GNU General Public License for more details. # # You should have received a copy of the GNU General Public License # along with this program; if not, write to the Free Software # Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. # ######################################################################## SUBDIRS = UFO +DIST_SUBDIRS = UFO # OMEGA_SPLIT = -target:single_function OMEGA_SPLIT = -target:split_function 10 # OMEGA_SPLIT = -target:split_module 10 # OMEGA_SPLIT = -target:split_file 10 OMEGA_QED = $(top_builddir)/omega/bin/omega_QED$(OCAML_NATIVE_EXT) OMEGA_QED_OPTS = $(OMEGA_SPLIT) -target:parameter_module parameters_QED OMEGA_QCD = $(top_builddir)/omega/bin/omega_QCD$(OCAML_NATIVE_EXT) OMEGA_QCD_OPTS = $(OMEGA_SPLIT) -target:parameter_module parameters_QCD OMEGA_SYM = $(top_builddir)/omega/bin/omega_SYM$(OCAML_NATIVE_EXT) OMEGA_SYM_OPTS = $(OMEGA_SPLIT) -target:parameter_module parameters_SYM OMEGA_SM = $(top_builddir)/omega/bin/omega_SM$(OCAML_NATIVE_EXT) OMEGA_SM_OPTS = $(OMEGA_SPLIT) -target:parameter_module parameters_SM OMEGA_SM_CKM = $(top_builddir)/omega/bin/omega_SM_CKM$(OCAML_NATIVE_EXT) OMEGA_SM_Higgs = $(top_builddir)/omega/bin/omega_SM_Higgs$(OCAML_NATIVE_EXT) OMEGA_THDM = $(top_builddir)/omega/bin/omega_THDM$(OCAML_NATIVE_EXT) OMEGA_THDM_CKM = $(top_builddir)/omega/bin/omega_THDM_CKM$(OCAML_NATIVE_EXT) OMEGA_HSExt = $(top_builddir)/omega/bin/omega_HSExt$(OCAML_NATIVE_EXT) OMEGA_Zprime = $(top_builddir)/omega/bin/omega_Zprime$(OCAML_NATIVE_EXT) OMEGA_SM_top_anom = $(top_builddir)/omega/bin/omega_SM_top_anom$(OCAML_NATIVE_EXT) OMEGA_SM_top_anom_OPTS = $(OMEGA_SPLIT) -target:parameter_module parameters_SM_top_anom OMEGA_UFO = $(top_builddir)/omega/bin/omega_UFO$(OCAML_NATIVE_EXT) OMEGA_UFO_OPTS = -target:parameter_module parameters_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_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 = +SKIP_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 ######################################################################## 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 ######################################################################## EXTENDED_COLOR_TESTS = \ $(srcdir)/fc_s.ects \ $(srcdir)/fc_a.ects $(srcdir)/cf_a.ects $(srcdir)/fa_f.ects \ $(srcdir)/ca_c.ects $(srcdir)/af_f.ects $(srcdir)/ac_c.ects \ $(srcdir)/aa_a.ects \ $(srcdir)/fc_fc.ects \ $(srcdir)/aa_s.ects $(srcdir)/as_a.ects $(srcdir)/sa_a.ects TESTS += ects EXTRA_PROGRAMS += ects EXTRA_DIST += ects_driver.sh $(EXTENDED_COLOR_TESTS) # Explicitly state dependence on model files ects.f90: $(OMEGA_QCD) $(OMEGA_SYM) $(OMEGA_SM) ects.f90: ects_driver.sh $(EXTENDED_COLOR_TESTS) @if $(AM_V_P); then :; else echo " ECTS_DRIVER"; fi $(AM_V_at)$(SHELL) $(srcdir)/ects_driver.sh \ $(OMEGA_XXX) $(EXTENDED_COLOR_TESTS) > $@ ects_SOURCES = color_test_lib.f90 \ parameters_SM.f90 parameters_QED.f90 parameters_QCD.f90 parameters_SYM.f90 nodist_ects_SOURCES = ects.f90 ects_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la ######################################################################## TESTS += cascade 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 += 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_amplitude_UFO # XFAIL_TESTS += compare_amplitude_UFO +# SKIP_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 " \ + "$(OMEGA_UFO) -model:UFO_dir $(top_srcdir)/omega/tests/UFO/%%%/ -model:exec" \ < $< > $@ +# -model:long_flavors parameters_SM_UFO.f90: $(OMEGA_UFO) $(OMEGA_UFO) \ -model:UFO_dir $(top_srcdir)/omega/tests/UFO/SM/ -model:exec \ -target:parameter_module parameters_sm_ufo -params > $@ 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) ######################################################################## +TESTS += ward_UFO + +# We need more work on the parameters to pass the tests +# at quadruple of 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 \ + parameters_SM_UFO.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 +ward_UFO_LDADD = $(KINDS) $(top_builddir)/omega/src/libomega_core.la + +ward_UFO.o: $(WARD_UFO_LIB_O) + +######################################################################## + 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 ######################################################################## 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 RECOLA_AVAILABLE + +TESTS += compare_amplitude_recola + +# We need more work on the parameters to pass the tests +# at quadruple of 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 *.$(FC_MODULE_EXT) \ *.o *.cmi *.cmo *.cmx amplitude_*.f90 \ - $(EXTRA_PROGRAMS) ects.f90 ward.f90 compare_*.f90 \ - parameters_SM_UFO.f90 \ + $(EXTRA_PROGRAMS) ects.f90 ward.f90 ward_UFO.f90 compare_*.f90 \ + parameters_SM_UFO.f90 keystones_omegalib.f90 keystones_UFO.f90 \ omega_testtools.f90 test_omega95*.f90 benchmark*.f90 \ - *.hbc *wrappers.f90 cascade phase_space + *.hbc *wrappers.f90 cascade phase_space \ + output.rcl recola.log + rm -fr output_cll + if FC_SUBMODULES -rm -f *.smod endif ######################################################################## ## The End. ######################################################################## Index: trunk/omega/tests/keystones_UFO_generate.ml =================================================================== --- trunk/omega/tests/keystones_UFO_generate.ml (revision 0) +++ trunk/omega/tests/keystones_UFO_generate.ml (revision 8253) @@ -0,0 +1,297 @@ +(* keystones_UFO_generate.ml -- + + Copyright (C) 2019-2019 by + + Wolfgang Kilian + Thorsten Ohl + Juergen Reuter + + WHIZARD is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + WHIZARD is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) + +open Coupling +open Keystones +open Format_Fortran + +type ufo_vertex = + { ufo_tag : string; + spins : lorentz array; + tensor : UFOx.Lorentz.t } + +module P = Permutation.Default + +let permute_spins p s = P.array p s + +(* We must permute only the free indices, of course. + Note that we apply the \emph{inverse} permutation to + the indices in order to match the permutation of the + particles/spins. *) +let permute_structure n p l = + let permuted = P.array (P.inverse p) (Array.init n succ) in + let permute_index i = + if i > 0 then + permuted.(pred i) + else + i in + UFOx.Lorentz.map_indices permute_index l + +let permute_vertex n v p = + { ufo_tag = v.ufo_tag ^ "_p" ^ P.to_string p; + spins = permute_spins p v.spins; + tensor = permute_structure n p v.tensor } + +let vertex_permutations v = + let n = Array.length v.spins in + List.map (permute_vertex n v) (P.cyclic n) + +let keystones_of_ufo_vertex { ufo_tag; spins } = + { tag = ufo_tag; + keystones = + let fields = Array.mapi (fun i s -> (s, i)) spins in + let n = Array.length fields in + List.map + (fun p -> + let permuted = P.array p fields in + match Array.to_list permuted with + | [] -> invalid_arg "keystones_of_ufo_vertex" + | ket :: args -> + { ket = ket; + name = ufo_tag ^ "_p" ^ P.to_string p; + args = + G (0) :: + (ThoList.flatmap (fun (s, i) -> [ F (s, i); P (i) ]) args) }) + (P.cyclic n) } + +let merge (ufo_list, omegalib) = + match ufo_list with + | [] -> omegalib + | ufo1 :: _ -> + { tag = ufo1.ufo_tag; + keystones = + (ThoList.flatmap + (fun ufo -> (keystones_of_ufo_vertex ufo).keystones) + ufo_list) + @ omegalib.keystones } + +let fusions ff module_name vertices = + let printf fmt = fprintf ff fmt + and nl () = pp_newline ff () in + printf "module %s" module_name; nl (); + printf " use kinds"; nl (); + printf " use omega95"; nl (); + printf " implicit none"; nl (); + printf " ! private"; nl (); + UFO_targets.Fortran.eps4_g4_g44_decl std_formatter (); + UFO_targets.Fortran.eps4_g4_g44_init std_formatter (); + printf "contains"; nl (); + List.iter + (fun v -> + List.iter + (fun v' -> + printf " ! %s" (String.make 68 '='); nl (); + printf " ! %s" (UFOx.Lorentz.to_string v'.tensor); nl (); + UFO_targets.Fortran.lorentz + std_formatter v'.ufo_tag v'.spins v'.tensor) + (vertex_permutations v)) + vertices; + printf "end module %s" module_name; nl () + +let generate ?reps ?threshold module_name vertices = + fusions std_formatter module_name (ThoList.flatmap fst vertices); + Keystones.generate + ?reps ?threshold ~modules:[module_name] + (List.map merge vertices) + +let equivalent_tensors spins alternatives = + List.map + (fun (ufo_tag, tensor) -> + { ufo_tag; spins; tensor = UFOx.Lorentz.of_string tensor }) + alternatives + +let qed = + equivalent_tensors + [| ConjSpinor; Vector; Spinor |] + [ ("qed", "Gamma(2,1,3)") ] + +let axial = + equivalent_tensors + [| ConjSpinor; Vector; Spinor |] + [ ("axial1", "Gamma5(1,-1)*Gamma(2,-1,3)"); + ("axial2", "-Gamma(2,1,-3)*Gamma5(-3,3)") ] + +let left = + equivalent_tensors + [| ConjSpinor; Vector; Spinor |] + [ ("left1", "(Identity(1,-1)+Gamma5(1,-1))*Gamma(2,-1,3)"); + ("left2", "2*ProjP(1,-1)*Gamma(2,-1,3)"); + ("left3", "Gamma(2,1,-3)*(Identity(-3,3)-Gamma5(-3,3))"); + ("left4", "2*Gamma(2,1,-3)*ProjM(-3,3)") ] + +let right = + equivalent_tensors + [| ConjSpinor; Vector; Spinor |] + [ ("right1", "(Identity(1,-1)-Gamma5(1,-1))*Gamma(2,-1,3)"); + ("right2", "2*ProjM(1,-1)*Gamma(2,-1,3)"); + ("right3", "Gamma(2,1,-3)*(Identity(-3,3)+Gamma5(-3,3))"); + ("right4", "2*Gamma(2,1,-3)*ProjP(-3,3)") ] + +let vector_spinor_current tag = + { tag = Printf.sprintf "vector_spinor_current__%s_ff" tag; + keystones = + [ { ket = (ConjSpinor, 0); + name = Printf.sprintf "f_%sf" tag; + args = [G (0); F (Vector, 1); F (Spinor, 2)] }; + { ket = (Vector, 1); + name = Printf.sprintf "%s_ff" tag; + args = [G (0); F (ConjSpinor, 0); F (Spinor, 2)] }; + { ket = (Spinor, 2); + name = Printf.sprintf "f_f%s" tag; + args = [G (0); F (ConjSpinor, 0); F (Vector, 1)] } ] } + +let fermi_ss = + equivalent_tensors + [| ConjSpinor; Spinor; ConjSpinor; Spinor |] + [ ("fermi_ss", "Identity(1,2)*Identity(3,4)"); + ("fermi_ss_f", + " (1/4) * Identity(1,4)*Identity(3,2)" ^ + " + (1/4) * Gamma(-1,1,4)*Gamma(-1,3,2)" ^ + " + (1/8) * Sigma(-1,-2,1,4)*Sigma(-1,-2,3,2)" ^ + " - (1/4) * Gamma(-1,1,-4)*Gamma5(-4,4)*Gamma(-1,3,-2)*Gamma5(-2,2)" ^ + " + (1/4) * Gamma5(1,4)*Gamma5(3,2)") ] + +let fermi_vv = + equivalent_tensors + [| ConjSpinor; Spinor; ConjSpinor; Spinor |] + [ ("fermi_vv", "Gamma(-1,1,2)*Gamma(-1,3,4)"); + ("fermi_vv_f", + " Identity(1,4)*Identity(3,2)" ^ + " - (1/2) * Gamma(-1,1,4)*Gamma(-1,3,2)" ^ + " - (1/2) * Gamma(-1,1,-4)*Gamma5(-4,4)*Gamma(-1,3,-2)*Gamma5(-2,2)" ^ + " - Gamma5(1,4)*Gamma5(3,2)") ] + +let fermi_tt = + equivalent_tensors + [| ConjSpinor; Spinor; ConjSpinor; Spinor |] + [ ("fermi_tt1", " Sigma(-1,-2,1,2)*Sigma(-1,-2,3,4)"); + ("fermi_tt2", " - Sigma(-1,-2,1,2)*Sigma(-2,-1,3,4)"); + ("fermi_tt3", " - Sigma(-2,-1,1,2)*Sigma(-1,-2,3,4)"); + ("fermi_tt_f", + " 3 * Identity(1,4)*Identity(3,2)" ^ + " - (1/2) * Sigma(-1,-2,1,4)*Sigma(-1,-2,3,2)" ^ + " + 3 * Gamma5(1,4)*Gamma5(3,2)") ] + +let fermi_aa = + equivalent_tensors + [| ConjSpinor; Spinor; ConjSpinor; Spinor |] + [ ("fermi_aa", "Gamma5(1,-2)*Gamma(-1,-2,2)*Gamma5(3,-3)*Gamma(-1,-3,4)"); + ("fermi_aa_f", + " - Identity(1,4)*Identity(3,2)" ^ + " - (1/2) * Gamma(-1,1,4)*Gamma(-1,3,2)" ^ + " - (1/2) * Gamma(-1,1,-4)*Gamma5(-4,4)*Gamma(-1,3,-2)*Gamma5(-2,2)" ^ + " + Gamma5(1,4)*Gamma5(3,2)") ] + +let fermi_pp = + equivalent_tensors + [| ConjSpinor; Spinor; ConjSpinor; Spinor |] + [ ("fermi_pp", "Gamma5(1,2)*Gamma5(3,4)"); + ("fermi_pp_f", + " (1/4) * Identity(1,4)*Identity(3,2)" ^ + " - (1/4) * Gamma(-1,1,4)*Gamma(-1,3,2)" ^ + " + (1/8) * Sigma(-1,-2,1,4)*Sigma(-1,-2,3,2)" ^ + " + (1/4) * Gamma(-1,1,-4)*Gamma5(-4,4)*Gamma(-1,3,-2)*Gamma5(-2,2)" ^ + " + (1/4) * Gamma5(1,4)*Gamma5(3,2)") ] + +let fermi_ll = + equivalent_tensors + [| ConjSpinor; Spinor; ConjSpinor; Spinor |] + [ ("fermi_ll", " Gamma(-1,1,-2)*ProjM(-2,2)*Gamma(-1,3,-4)*ProjM(-4,4)"); + ("fermi_ll_f", " - Gamma(-1,1,-2)*ProjM(-2,4)*Gamma(-1,3,-4)*ProjM(-4,2)") ] + +let fermi_va = + equivalent_tensors + [| ConjSpinor; Spinor; ConjSpinor; Spinor |] + [ ("fermi_va", "Gamma(-1,1,2)*Gamma5(3,-3)*Gamma(-1,-3,4)") ] + +let fermi_av = + equivalent_tensors + [| ConjSpinor; Spinor; ConjSpinor; Spinor |] + [ ("fermi_av", "Gamma5(1,-2)*Gamma(-1,-2,2)*Gamma(-1,3,4)") ] + +let sqed = + equivalent_tensors + [| Scalar; Vector; Scalar |] + [ ("sqed1", "P(2,3)-P(2,1)"); + ("sqed2", "2*P(2,3)+P(2,2)"); + ("sqed3", "-P(2,2)-2*P(2,1)") ] + +let vector_scalar_current = + { tag = "vector_scalar_current__v_ss"; + keystones = + [ { ket = (Vector, 1); + name = "v_ss"; + args = [G (0); F (Scalar, 2); P (2); F (Scalar, 0); P (0)] }; + { ket = (Scalar, 0); + name = "s_vs"; + args = [G (0); F (Vector, 1); P (1); F (Scalar, 2); P (2)] } ] } + +let svv_t = + equivalent_tensors + [| Scalar; Vector; Vector |] + [ ("svv_t", "P(-1,2)*P(-1,3)*Metric(2,3)-P(2,3)*P(3,2)") ] + +let scalar_vector_current tag = + { tag = Printf.sprintf "transversal_vector_current__s_vv_%s" tag; + keystones = [ { ket = (Scalar, 0); + name = Printf.sprintf "s_vv_%s" tag; + args = [G (0); F (Vector, 1); P (1); F (Vector, 2); P (2)] }; + { ket = (Vector, 1); + name = Printf.sprintf "v_sv_%s" tag; + args = [G (0); F (Scalar, 0); P (0); F (Vector, 2); P (2)] } ] } + +let gauge = + equivalent_tensors + [| Vector; Vector; Vector |] + [ ("gauge", " Metric(1,2)*P(3,1) - Metric(1,2)*P(3,2) \ + + Metric(3,1)*P(2,3) - Metric(3,1)*P(2,1) \ + + Metric(2,3)*P(1,2) - Metric(2,3)*P(1,3)") ] + +let gauge_omega = + { tag = "g_gg"; + keystones = + [ { ket = (Vector, 0); + name = "(0,1)*g_gg"; + args = [G (0); F (Vector, 1); P (1); F (Vector, 2); P (2)] } ] } + +let empty = { tag = "empty"; keystones = [ ] } + +let vertices = + [ (qed, vector_spinor_current "v"); + (axial, vector_spinor_current "a"); + (left, vector_spinor_current "vl"); + (right, vector_spinor_current "vr"); + (sqed, vector_scalar_current); + (fermi_ss, empty); + (fermi_vv, empty); + (fermi_tt, empty); + (fermi_aa, empty); + (fermi_pp, empty); + (fermi_ll, empty); + (fermi_va, empty); + (fermi_av, empty); + (svv_t, scalar_vector_current "t"); + (gauge, gauge_omega) ] + +let _ = + generate ~reps:10000 ~threshold:0.70 "fusions" vertices; + exit 0 Index: trunk/omega/tests/keystones.ml =================================================================== --- trunk/omega/tests/keystones.ml (revision 0) +++ trunk/omega/tests/keystones.ml (revision 8253) @@ -0,0 +1,333 @@ +(* keystones.ml -- + + Copyright (C) 2019-2019 by + + Wolfgang Kilian + Thorsten Ohl + Juergen Reuter + + WHIZARD is free software; you can redistribute it and/or modify it + under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 2, or (at your option) + any later version. + + WHIZARD is distributed in the hope that it will be useful, but + WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program; if not, write to the Free Software + Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. *) + +open Coupling + +type field = lorentz * int + +type argument = + | G of int (* coupling *) + | P of int (* momentum *) + | F of field (* field *) + +type keystone = + { ket : field; + name : string; + args : argument list } + +type vertex = + { tag : string; + keystones : keystone list } + +let order_fields (_, i) (_, j) = + compare i j + +let extract_fields { ket; args } = + List.sort + order_fields + (List.fold_left + (fun acc arg -> + match arg with + | F f -> f :: acc + | _ -> acc) + [ket] args) + +let extract_momenta { args } = + List.sort + compare + (List.fold_left + (fun acc arg -> + match arg with + | P i -> i :: acc + | _ -> acc) + [] args) + +let extract_couplings { args } = + List.sort + compare + (List.fold_left + (fun acc arg -> + match arg with + | G i -> i :: acc + | _ -> acc) + [] args) + +let check_indices field_list = + if List.exists + (fun (n, _) -> n > 1) + (ThoList.classify (List.map snd field_list)) then + invalid_arg "check_indices"; + () + +let spin_to_string = function + | Scalar -> "Scalar" + | Spinor -> "Spinor" + | ConjSpinor -> "ConjSpinor" + | Majorana -> "Majorana" + | Vector | Massive_Vector -> "Vector" + | _ -> failwith "spin_to_string" + +let fields_to_string fields = + "[" ^ + String.concat + "; " (List.map + (fun (s, i) -> Printf.sprintf "%s(%d)" (spin_to_string s) i) + fields) ^ "]" + +let check_fields ks_list = + let fields = List.map extract_fields ks_list in + if not (ThoList.homogeneous fields) then + begin + let spins = + "[" ^ String.concat "; " (List.map fields_to_string fields) ^ "]" in + invalid_arg ("check_spins: " ^ spins) + end; + check_indices (List.hd fields) + +open Format_Fortran + +let spin_type = function + | Scalar -> "complex(kind=default)" + | Spinor -> "type(spinor)" + | ConjSpinor -> "type(conjspinor)" + | Majorana -> "type(bispinor)" + | Vector | Massive_Vector -> "type(vector)" + | _ -> failwith "spin_type" + +let type_arg = function + | G _ -> "complex(kind=default)" + | P _ -> "type(momentum)" + | F (s, _) -> spin_type s + +let spin_mnemonic = function + | Scalar -> "phi" + | Spinor -> "psi" + | ConjSpinor -> "psibar" + | Majorana -> "chi" + | Maj_Ghost -> "???" + | Vector -> "a" + | Massive_Vector -> "v" + | _ -> failwith "spin_mnemonic" + +let format_coupling i = + Printf.sprintf "g%d" i + +let format_momentum i = + Printf.sprintf "p%d" i + +let format_field (s, i) = + Printf.sprintf "%s%d" (spin_mnemonic s) i + +let format_arg = function + | G i -> format_coupling i + | P i -> format_momentum i + | F f -> format_field f + +let fusion_to_fortran ff name args = + let printf fmt = fprintf ff fmt in + match args with + | [] -> invalid_arg "fusion_to_fortran" + | arg1 :: arg2n -> + printf "%s (%s" name (format_arg arg1); + List.iter (fun arg -> printf ",@ %s" (format_arg arg)) arg2n; + printf ")" + +let keystone_to_fortran ff (ksv, { ket; name; args }) = + let printf fmt = fprintf ff fmt + and nl = pp_newline ff in + printf " @[<2>%s =@ " ksv; + begin match ket with + | Spinor, _ -> + fusion_to_fortran ff name args; + printf "@ * %s" (format_field ket) + | _, _ -> + printf "%s@ * " (format_field ket); + fusion_to_fortran ff name args + end; + printf "@]"; nl() + +let keystones_to_subroutine ff { tag; keystones } = + check_fields keystones; + let printf fmt = fprintf ff fmt + and nl = pp_newline ff in + printf " @[<4>subroutine@ testks_%s@ (repetitions," tag; + printf "@ passed,@ threshold,@ quiet,@ abs_threshold)@]"; nl (); + printf " integer, intent(in) :: repetitions"; nl (); + printf " logical, intent(inout) :: passed"; nl (); + printf " logical, intent(in), optional :: quiet"; nl (); + printf " @[<2>real(kind=default),@ intent(in),@ optional ::"; + printf "@ threshold,@ abs_threshold@]"; nl (); + printf " integer :: i"; nl (); + let ks1 = List.hd keystones in + let all_momenta = + List.map + (fun i -> P i) + (ThoList.range 0 (List.length (extract_fields ks1) - 1)) in + let variables = + ThoList.uniq (List.sort compare (F (ks1.ket) :: ks1.args @ all_momenta)) in + List.iter + (fun a -> + printf " @[<2>%s :: %s@]" (type_arg a) (format_arg a); nl ()) + variables; + let ks_list = + List.map + (fun (n, ks) -> (Printf.sprintf "ks%d" n, ks)) + (ThoList.enumerate 0 keystones) in + begin match ks_list with + | [] -> failwith "keystones_to_fortran" + | (ksv1, _) :: ks2n -> + printf " @[<2>complex(kind=default) ::@ %s" ksv1; + List.iter (fun (ksv, _) -> printf ",@ %s" ksv) ks2n; + printf "@]"; nl () + end; + printf " do i = 1, repetitions"; nl (); + List.iter + (fun a -> + match a with + | P 0 -> () (* this will be determined by momentum conservation! *) + | a -> + printf " @[<2>call@ make_random@ (%s)@]" (format_arg a); nl ()) + variables; + begin match all_momenta with + | [] -> failwith "keystones_to_fortran" + | p1 :: p2n -> + printf " @[<2>%s =" (format_arg p1); + List.iter (fun p -> printf "@ - %s" (format_arg p)) p2n; + printf "@]"; nl () + end; + List.iter (keystone_to_fortran ff) ks_list; + begin match ks_list with + | [] -> failwith "keystones_to_fortran" + | (ksv1, ks1) :: ks2n -> + List.iter + (fun (ksv, ks) -> + printf " @[<8>call@ expect@ (%s,@ %s," ksv ksv1; + printf "@ '%s: %s <> %s'," tag ks.name ks1.name; + printf "@ passed,@ threshold, quiet, abs_threshold)@]"; + nl ()) + ks2n + end; + printf " end do"; nl (); + printf " @[<2>end@ subroutine@ testks_%s@]" tag; nl () + +let keystones_to_fortran + ff ?(reps=1000) ?(threshold=0.85) + ?(modules=[]) vertices = + let printf fmt = fprintf ff fmt + and nl = pp_newline ff in + printf "program keystones_omegalib_demo"; nl (); + List.iter + (fun m -> printf " use %s" m; nl ()) + ("kinds" :: "constants" :: "omega95" :: + "omega_testtools" :: "keystones_tools" :: modules); + printf " implicit none"; nl (); + printf " logical :: passed"; nl (); + printf " logical, parameter :: quiet = .false."; nl (); + printf " integer, parameter :: reps = %d" reps; nl (); + printf " real(kind=default), parameter :: threshold = %f" threshold; nl (); + printf " real(kind=default), parameter :: abs_threshold = 1E-17"; nl (); + printf " integer, dimension(8) :: date_time"; nl (); + printf " integer :: rsize"; nl (); + printf " call date_and_time (values = date_time)"; nl (); + printf " call random_seed (size = rsize)"; nl (); + printf " @[<8>call random_seed@ (put = spread (product (date_time),"; + printf "@ dim = 1,@ ncopies = rsize))@]"; nl (); + printf " passed = .true."; nl (); + List.iter + (fun v -> + printf " @[<8>call testks_%s@ (reps,@ passed," v.tag; + printf "@ threshold, quiet, abs_threshold)@]"; nl ()) + vertices; + printf " if (passed) then"; nl (); + printf " stop 0"; nl (); + printf " else"; nl (); + printf " stop 1"; nl (); + printf " end if"; nl (); + printf "contains"; nl (); + List.iter (keystones_to_subroutine ff) vertices; + printf "end program keystones_omegalib_demo"; nl () + +let vector_spinor_current tag = + { tag = Printf.sprintf "vector_spinor_current__%s_ff" tag; + keystones = [ { ket = (ConjSpinor, 0); + name = Printf.sprintf "f_%sf" tag; + args = [G (0); F (Vector, 1); F (Spinor, 2)] }; + { ket = (Vector, 1); + name = Printf.sprintf "%s_ff" tag; + args = [G (0); F (ConjSpinor, 0); F (Spinor, 2)] }; + { ket = (Spinor, 2); + name = Printf.sprintf "f_f%s" tag; + args = [G (0); F (ConjSpinor, 0); F (Vector, 1)] } ] } + +let scalar_spinor_current tag = + { tag = Printf.sprintf "scalar_spinor_current__%s_ff" tag; + keystones = [ { ket = (ConjSpinor, 0); + name = Printf.sprintf "f_%sf" tag; + args = [G (0); F (Scalar, 1); F (Spinor, 2)] }; + { ket = (Scalar, 1); + name = Printf.sprintf "%s_ff" tag; + args = [G (0); F (ConjSpinor, 0); F (Spinor, 2)] }; + { ket = (Spinor, 2); + name = Printf.sprintf "f_f%s" tag; + args = [G (0); F (ConjSpinor, 0); F (Scalar, 1)] } ] } + +(* NB: the vertex is anti-symmetric in the scalars and we need to + use a cyclic permutation. *) +let vector_scalar_current = + { tag = "vector_scalar_current__v_ss"; + keystones = [ { ket = (Vector, 0); + name = "v_ss"; + args = [G (0); F (Scalar, 1); P (1); F (Scalar, 2); P (2)] }; + { ket = (Scalar, 2); + name = "s_vs"; + args = [G (0); F (Vector, 0); P (0); F (Scalar, 1); P (1)] } ] } + +let scalar_vector_current tag = + { tag = Printf.sprintf "transversal_vector_current__s_vv_%s" tag; + keystones = [ { ket = (Scalar, 0); + name = Printf.sprintf "s_vv_%s" tag; + args = [G (0); F (Vector, 1); P (1); F (Vector, 2); P (2)] }; + { ket = (Vector, 1); + name = Printf.sprintf "v_sv_%s" tag; + args = [G (0); F (Scalar, 0); P (0); F (Vector, 2); P (2)] } ] } + +let vertices = + List.concat + [ List.map vector_spinor_current ["v"; "a"; "vl"; "vr"]; + List.map scalar_spinor_current ["s"; "p"; "sl"; "sr"]; + [ vector_scalar_current ]; + List.map scalar_vector_current ["t"; "6D"; "6DP"] ] + +let generate ?(reps=1000) ?(threshold=0.85) ?modules vertices = + let my_name = Sys.argv.(0) in + let verbose = ref false + and cat = ref false + and usage = "usage: " ^ my_name ^ " ..." in + Arg.parse + (Arg.align + [ ("-cat", Arg.Set cat, " print test snippets"); + ("-v", Arg.Set verbose, " be more verbose"); + ("-verbose", Arg.Set verbose, " be more verbose") ]) + (fun s -> raise (Arg.Bad s)) + usage; + if !cat then + keystones_to_fortran std_formatter ~reps ~threshold ?modules vertices